relay-pagination-conformance (empty) → 0.1.0.0
raw patch · 17 files changed
+1892/−0 lines, 17 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, ephemeral-pg, hasql, hasql-dynamic-statements, http-client, quickcheck-instances, relay-pagination, relay-pagination-conformance, relay-pagination-hasql, relay-pagination-servant, servant, servant-client, servant-client-core, servant-server, sop-core, tasty, tasty-hunit, tasty-quickcheck, text, time, uuid-types, warp
Files
- CHANGELOG.md +16/−0
- LICENSE +30/−0
- relay-pagination-conformance.cabal +103/−0
- src/Relay/Pagination/Conformance.hs +14/−0
- src/Relay/Pagination/Conformance/Check.hs +411/−0
- src/Relay/Pagination/Conformance/Tasty.hs +33/−0
- src/Relay/Pagination/Conformance/Walk.hs +132/−0
- test/Broken.hs +148/−0
- test/CheckSpec.hs +116/−0
- test/DbFixture.hs +148/−0
- test/DbSpec.hs +52/−0
- test/Generators.hs +101/−0
- test/HttpSpec.hs +139/−0
- test/Main.hs +21/−0
- test/MutationSpec.hs +269/−0
- test/Oracle.hs +58/−0
- test/WalkSpec.hs +101/−0
+ CHANGELOG.md view
@@ -0,0 +1,16 @@+# Changelog for relay-pagination-conformance++Versioning follows the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 0.1.0.0 — 2026-07-16++Initial contents:++- The page walker (`walkForward`/`walkBackward`) over a plain+ `FetchPage row = PageRequest -> IO (Connection row)` callback, defended+ against cursor loops and non-terminating paginators.+- The invariant checker (`checkConformance`, `ConformanceReport`,+ `renderConformanceReport`): completeness, backward symmetry, boundary+ honesty, cursor determinism, edge-order invariance, and pageInfo–cursor+ consistency.+- A one-line tasty adapter (`testConformance`).
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2025, Nadeem Bitar++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ relay-pagination-conformance.cabal view
@@ -0,0 +1,103 @@+cabal-version: 3.0+name: relay-pagination-conformance+version: 0.1.0.0+synopsis: Conformance suite proving no-skip/no-duplicate pagination+description:+ A conformance suite that services run against their own paginated+ endpoints to prove no-skip/no-duplicate behavior: a page walker with+ cursor-loop detection and an invariant checker producing human-readable+ reports. Pages are fetched through a plain callback, so the suite stays+ decoupled from any session runner or HTTP client.++license: BSD-3-Clause+license-file: LICENSE+author: Nadeem Bitar+maintainer: Nadeem Bitar+category: Testing, Web+build-type: Simple+extra-doc-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/shinzui/relay-pagination++common warnings+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages++common lang+ import: warnings+ default-language: GHC2024+ default-extensions:+ DeriveAnyClass+ DuplicateRecordFields+ OverloadedLabels+ OverloadedStrings++library+ import: lang+ hs-source-dirs: src+ exposed-modules:+ Relay.Pagination.Conformance+ Relay.Pagination.Conformance.Check+ Relay.Pagination.Conformance.Tasty+ Relay.Pagination.Conformance.Walk++ build-depends:+ , base >=4.21 && <5+ , bytestring >=0.11 && <0.13+ , containers >=0.7 && <0.9+ , relay-pagination ^>=0.1.0.0+ , tasty >=1.4 && <1.6+ , tasty-hunit >=0.10 && <0.11+ , text >=2.0 && <2.2++test-suite relay-pagination-conformance-test+ import: lang+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs++ -- MultilineStrings: fixture DDL and the multi-row insert (ADR 1)+ default-extensions: MultilineStrings++ -- warp (M6 HTTP walk) requires the threaded RTS+ ghc-options: -threaded+ other-modules:+ Broken+ CheckSpec+ DbFixture+ DbSpec+ Generators+ HttpSpec+ MutationSpec+ Oracle+ WalkSpec++ build-depends:+ , aeson >=2.2 && <2.3+ , base+ , bytestring+ , containers+ , ephemeral-pg+ , hasql >=1.10 && <1.11+ , hasql-dynamic-statements >=0.5 && <0.6+ , http-client >=0.7 && <0.8+ , quickcheck-instances >=0.3 && <0.4+ , relay-pagination ^>=0.1.0.0+ , relay-pagination-conformance+ , relay-pagination-hasql ^>=0.1.0.0+ , relay-pagination-servant ^>=0.1.0.0+ , servant >=0.20.3 && <0.21+ , servant-client >=0.20.3 && <0.21+ , servant-client-core+ , servant-server+ , sop-core >=0.5 && <0.6+ , tasty >=1.4 && <1.6+ , tasty-hunit >=0.10 && <0.11+ , tasty-quickcheck >=0.10 && <0.12+ , text+ , time >=1.12 && <1.15+ , uuid-types >=1.0 && <1.1+ , warp >=3.3 && <3.5
+ src/Relay/Pagination/Conformance.hs view
@@ -0,0 +1,14 @@+-- | Conformance suite for Relay-style paginated endpoints: walk an endpoint+-- through a plain 'FetchPage' callback and check that it can never skip or+-- duplicate a record. This facade re-exports the whole public API; the+-- submodules exist for focused imports.+module Relay.Pagination.Conformance+ ( module Relay.Pagination.Conformance.Walk,+ module Relay.Pagination.Conformance.Check,+ module Relay.Pagination.Conformance.Tasty,+ )+where++import Relay.Pagination.Conformance.Check+import Relay.Pagination.Conformance.Tasty+import Relay.Pagination.Conformance.Walk
+ src/Relay/Pagination/Conformance/Check.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE BlockArguments #-}++-- | The invariant checker: walk an endpoint forward (and backward), then+-- assert the six conformance invariants against the expected result set.+-- Each invariant guards a way infinite scrolling breaks in production:+--+-- ['Completeness'] The forward walk returns exactly the expected rows —+-- same elements, same multiplicity, same order. A missing key is a record+-- the user never sees no matter how far they scroll (the classic lossy-+-- cursor bug); a duplicated key renders twice in the feed; an order+-- divergence means pages do not tile the result set.+--+-- ['BackwardSymmetry'] The backward walk yields the same keys in the same+-- canonical order as the forward walk. Paging backward is how a client+-- fills in history above the viewport; if the directions disagree, the two+-- scroll directions show different data. (Compared by node keys, not cursor+-- bytes — the Relay spec does not require byte-identical cursors across+-- directions.)+--+-- ['BoundaryHonesty'] Every non-final page reports a continuation, the+-- final page does not, and the final page is non-empty unless the whole+-- result set is empty. @length == pageSize@ heuristics necessarily emit a+-- trailing phantom empty page whenever the result size is an exact multiple+-- of the page size — at best a wasted round trip, at worst a spinner that+-- never resolves.+--+-- ['CursorDeterminism'] Re-issuing every request the forward walk sent+-- yields identical pages. Cursors are bookmarks; clients hold them for+-- minutes and retry after network failures. Skipped when+-- 'checkDeterminism' is off (e.g. the source mutates during the run).+--+-- ['EdgeOrderInvariance'] Within every page, from both walks, edges appear+-- in canonical order (each page is a contiguous slice of the expected+-- sequence). Catches backward pages returned in reversed (SQL-flipped)+-- order, which renders history blocks upside-down.+--+-- ['PageInfoCursorConsistency'] On every page, @startCursor@/@endCursor@+-- equal the first/last edge's cursor, and are 'Nothing' iff the page is+-- empty. Clients paginate from @pageInfo.endCursor@ without reading edges;+-- if it disagrees with the edges, the next request continues from the+-- wrong position.+--+-- A walk that aborts ('WalkFailure') is reported under 'WalkTerminated' —+-- a paginator that loops forever is maximally non-conformant.+module Relay.Pagination.Conformance.Check+ ( ConformanceConfig (..),+ defaultConformanceConfig,+ InvariantName (..),+ ConformanceViolation (..),+ ConformanceReport (..),+ conformancePassed,+ renderConformanceReport,+ checkConformance,+ )+where++import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Relay.Pagination+import Relay.Pagination.Conformance.Walk++-- | What to check and how far to walk.+data ConformanceConfig = ConformanceConfig+ { -- | Page size for every request the checker issues.+ pageSize :: !Int,+ -- | Forwarded to the walker.+ maxWalkPages :: !Int,+ -- | Off for forward-only endpoints.+ checkBackward :: !Bool,+ -- | Off when the source mutates during the run.+ checkDeterminism :: !Bool+ }+ deriving stock (Eq, Show)++-- | All checks on, walker cap 10 000.+defaultConformanceConfig :: Int -> ConformanceConfig+defaultConformanceConfig size =+ ConformanceConfig+ { pageSize = size,+ maxWalkPages = 10000,+ checkBackward = True,+ checkDeterminism = True+ }++-- | The six invariants (see the module haddock), plus 'WalkTerminated' for+-- walks that abort.+data InvariantName+ = Completeness+ | BackwardSymmetry+ | BoundaryHonesty+ | CursorDeterminism+ | EdgeOrderInvariance+ | PageInfoCursorConsistency+ | WalkTerminated+ deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | One observed violation.+data ConformanceViolation = ConformanceViolation+ { invariant :: !InvariantName,+ -- | Which page (by walk index), when page-scoped.+ pageIndex :: !(Maybe Int),+ -- | Human-readable specifics, offending keys included.+ detail :: !Text+ }+ deriving stock (Eq, Show)++-- | The checker's verdict.+data ConformanceReport = ConformanceReport+ { violations :: ![ConformanceViolation],+ pagesWalked :: !Int+ }+ deriving stock (Eq, Show)++-- | True iff the report contains no violations.+conformancePassed :: ConformanceReport -> Bool+conformancePassed report = null (violations report)++-- | One summary line, then one @FAIL@ block per violation.+renderConformanceReport :: ConformanceReport -> Text+renderConformanceReport report =+ Text.intercalate "\n" (summary : map renderViolation (violations report))+ where+ summary+ | conformancePassed report =+ "relay-pagination conformance: OK (" <> pages <> " walked)"+ | otherwise =+ "relay-pagination conformance: "+ <> tshow (length (violations report))+ <> " violation(s) across "+ <> pages+ <> " walked"+ pages = tshow (pagesWalked report) <> " page(s)"+ renderViolation ConformanceViolation {invariant = name, pageIndex = mPage, detail = d} =+ "FAIL "+ <> tshow name+ <> maybe "" (\i -> " (page " <> tshow i <> ")") mPage+ <> ": "+ <> d++-- | Walk the endpoint and check every enabled invariant. The @expected@+-- list is the full result set in canonical order; @keyOf@ projects the+-- identity used for comparison and reporting.+checkConformance ::+ (Ord key, Show key) =>+ ConformanceConfig ->+ (row -> key) ->+ FetchPage row ->+ [row] ->+ IO ConformanceReport+checkConformance config keyOf fetchPage expected = do+ let ConformanceConfig+ { pageSize = size,+ maxWalkPages = cap,+ checkBackward = doBackward,+ checkDeterminism = doDeterminism+ } = config+ walkConfig = WalkConfig {maxWalkPages = cap}+ expectedKeys = map keyOf expected++ forwardResult <- walkForwardWith walkConfig fetchPage size+ case forwardResult of+ Left failure ->+ pure+ ConformanceReport+ { violations = [walkTerminated "forward" failure],+ pagesWalked = 0+ }+ Right forward -> do+ determinismViolations <-+ if doDeterminism+ then determinismCheck keyOf fetchPage forward+ else pure []+ (backwardViolations, backwardPages) <-+ if doBackward+ then do+ backwardResult <- walkBackwardWith walkConfig fetchPage size+ pure case backwardResult of+ Left failure -> ([walkTerminated "backward" failure], 0)+ Right backward ->+ ( symmetryViolations keyOf forward backward+ <> boundaryViolations "hasPreviousPage" (null expected) (walkPages backward)+ <> orderViolations keyOf expectedKeys "backward" (walkPages backward)+ <> pageInfoViolations "backward" (walkPages backward),+ length (walkPages backward)+ )+ else pure ([], 0)+ pure+ ConformanceReport+ { violations =+ completenessViolations keyOf expectedKeys forward+ <> boundaryViolations "hasNextPage" (null expected) (walkPages forward)+ <> orderViolations keyOf expectedKeys "forward" (walkPages forward)+ <> pageInfoViolations "forward" (walkPages forward)+ <> backwardViolations+ <> determinismViolations,+ pagesWalked = length (walkPages forward) + backwardPages+ }+ where+ walkTerminated whichWalk failure =+ ConformanceViolation+ { invariant = WalkTerminated,+ pageIndex = Nothing,+ detail = whichWalk <> " walk aborted: " <> tshow failure+ }++-- | Invariant 1: same elements, same multiplicity, same order.+completenessViolations ::+ (Ord key, Show key) => (row -> key) -> [key] -> Walk row -> [ConformanceViolation]+completenessViolations keyOf expectedKeys forward =+ concat+ [ [ violation ("skipped keys (never returned): " <> tshowKeys (multisetKeys skipped))+ | not (Map.null skipped)+ ],+ [ violation ("duplicated keys (returned more often than expected): " <> tshowKeys (multisetKeys surplus))+ | not (Map.null surplus)+ ],+ [ violation divergenceDetail+ | Map.null skipped,+ Map.null surplus,+ Just divergenceDetail <- [firstDivergence expectedKeys actualKeys]+ ]+ ]+ where+ actualKeys = [keyOf n | Edge {node = n} <- walkEdges forward]+ expectedCounts = multiset expectedKeys+ actualCounts = multiset actualKeys+ skipped = multisetMinus expectedCounts actualCounts+ surplus = multisetMinus actualCounts expectedCounts+ violation d =+ ConformanceViolation {invariant = Completeness, pageIndex = Nothing, detail = d}+ firstDivergence es as =+ case [ (i, e, a) | (i, e, a) <- zip3 [0 :: Int ..] es as, e /= a+ ] of+ (i, e, a) : _ ->+ Just+ ( "same rows, wrong order: first divergence at position "+ <> tshow i+ <> ": expected "+ <> tshow e+ <> ", got "+ <> tshow a+ )+ [] -> Nothing++-- | Invariant 2: backward keys equal forward keys, same order.+symmetryViolations ::+ (Ord key, Show key) => (row -> key) -> Walk row -> Walk row -> [ConformanceViolation]+symmetryViolations keyOf forward backward+ | forwardKeys == backwardKeys = []+ | otherwise =+ [ ConformanceViolation+ { invariant = BackwardSymmetry,+ pageIndex = Nothing,+ detail =+ "backward walk disagrees with forward walk: forward has "+ <> tshow (length forwardKeys)+ <> " keys, backward has "+ <> tshow (length backwardKeys)+ <> divergence+ }+ ]+ where+ forwardKeys = [keyOf n | Edge {node = n} <- walkEdges forward]+ backwardKeys = [keyOf n | Edge {node = n} <- walkEdges backward]+ divergence =+ case [(i, f, b) | (i, f, b) <- zip3 [0 :: Int ..] forwardKeys backwardKeys, f /= b] of+ (i, f, b) : _ ->+ "; first divergence at position "+ <> tshow i+ <> ": forward "+ <> tshow f+ <> ", backward "+ <> tshow b+ [] -> ""++-- | Invariant 3: continuation flags honest, no phantom trailing page.+boundaryViolations :: Text -> Bool -> [WalkedPage row] -> [ConformanceViolation]+boundaryViolations flagName expectedEmpty pages =+ case reverse pages of+ [] -> []+ finalPage : earlier ->+ concat+ [ [ violation (indexOf finalPage) $+ "page is empty but the result set is not; an empty trailing page "+ <> "indicates a length == pageSize heuristic"+ | pageEmpty finalPage,+ not expectedEmpty+ ],+ [ violation (indexOf prev) $+ "final non-empty page reports "+ <> flagName+ <> " = True; a phantom page was fetched and came back empty"+ | pageEmpty finalPage,+ prev : _ <- [earlier],+ not (pageEmpty prev)+ ],+ [ violation (indexOf w) ("empty page mid-walk claims " <> flagName <> " = True")+ | w <- earlier,+ pageEmpty w+ ]+ ]+ where+ pageEmpty w = null (edges (pageOf w))+ violation i d =+ ConformanceViolation {invariant = BoundaryHonesty, pageIndex = Just i, detail = d}++-- | Invariant 5: every page is a contiguous slice of the expected sequence.+orderViolations ::+ (Ord key, Show key) => (row -> key) -> [key] -> Text -> [WalkedPage row] -> [ConformanceViolation]+orderViolations keyOf expectedKeys whichWalk pages =+ [ ConformanceViolation+ { invariant = EdgeOrderInvariance,+ pageIndex = Just (indexOf w),+ detail =+ whichWalk+ <> " page is not a contiguous slice of the expected order; page keys: "+ <> tshowKeys (pageKeys w)+ }+ | w <- pages,+ not (pageKeys w `isInfixOf` expectedKeys)+ ]+ where+ pageKeys w = [keyOf n | Edge {node = n} <- edges (pageOf w)]++-- | Invariant 6: PageInfo cursors match the edges on every page.+pageInfoViolations :: Text -> [WalkedPage row] -> [ConformanceViolation]+pageInfoViolations whichWalk pages =+ concatMap check pages+ where+ check w =+ let cursors = [c | Edge {cursor = c} <- edges (pageOf w)]+ info = pageInfo (pageOf w)+ expectStart = case cursors of+ c : _ -> Just c+ [] -> Nothing+ expectEnd = case reverse cursors of+ c : _ -> Just c+ [] -> Nothing+ violation d =+ ConformanceViolation+ { invariant = PageInfoCursorConsistency,+ pageIndex = Just (indexOf w),+ detail = whichWalk <> " page: " <> d+ }+ in concat+ [ [ violation "startCursor does not equal the first edge's cursor"+ | startCursor info /= expectStart+ ],+ [ violation "endCursor does not equal the last edge's cursor"+ | endCursor info /= expectEnd+ ]+ ]++-- | Invariant 4: re-issuing the forward walk's requests reproduces the+-- pages byte for byte (keys, edge cursors, PageInfo).+determinismCheck ::+ (Ord key, Show key) => (row -> key) -> FetchPage row -> Walk row -> IO [ConformanceViolation]+determinismCheck keyOf fetchPage forward =+ concat <$> traverse recheck (walkPages forward)+ where+ recheck w = do+ again <- fetchPage (requestOf w)+ let firstKeys = [keyOf n | Edge {node = n} <- edges (pageOf w)]+ againKeys = [keyOf n | Edge {node = n} <- edges again]+ firstCursors = [c | Edge {cursor = c} <- edges (pageOf w)]+ againCursors = [c | Edge {cursor = c} <- edges again]+ violation d =+ ConformanceViolation+ { invariant = CursorDeterminism,+ pageIndex = Just (indexOf w),+ detail = "re-issuing the same request gave a different " <> d+ }+ pure $+ concat+ [ [ violation ("edge key sequence: first " <> tshowKeys firstKeys <> ", then " <> tshowKeys againKeys)+ | firstKeys /= againKeys+ ],+ [violation "edge cursor sequence" | firstCursors /= againCursors],+ [violation "PageInfo" | pageInfo (pageOf w) /= pageInfo again]+ ]++-- * Field access helpers (DuplicateRecordFields makes bare selectors ambiguous here)++indexOf :: WalkedPage row -> Int+indexOf WalkedPage {pageIndex = i} = i++pageOf :: WalkedPage row -> Connection row+pageOf WalkedPage {page = p} = p++requestOf :: WalkedPage row -> PageRequest+requestOf WalkedPage {requestSent = r} = r++-- * Multiset helpers++multiset :: (Ord key) => [key] -> Map.Map key Int+multiset ks = Map.fromListWith (+) [(k, 1) | k <- ks]++multisetMinus :: (Ord key) => Map.Map key Int -> Map.Map key Int -> Map.Map key Int+multisetMinus a b =+ Map.filter (> 0) (Map.differenceWith (\x y -> Just (x - y)) a b)++multisetKeys :: Map.Map key Int -> [key]+multisetKeys = Map.keys++tshow :: (Show a) => a -> Text+tshow = Text.pack . show++tshowKeys :: (Show key) => [key] -> Text+tshowKeys ks = Text.intercalate ", " (map tshow ks)
+ src/Relay/Pagination/Conformance/Tasty.hs view
@@ -0,0 +1,33 @@+-- | One-liner tasty adapter over the conformance checker. Non-tasty users+-- (hspec, sydtest, bespoke harnesses) can call+-- 'Relay.Pagination.Conformance.Check.checkConformance' directly and render+-- the report themselves.+module Relay.Pagination.Conformance.Tasty+ ( testConformance,+ )+where++import Data.Text qualified as Text+import Relay.Pagination.Conformance.Check+import Relay.Pagination.Conformance.Walk (FetchPage)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.HUnit (assertFailure, testCase)++-- | Run 'checkConformance' as a test case; a failing report becomes the+-- assertion message, rendered by 'renderConformanceReport'.+testConformance ::+ (Ord key, Show key) =>+ TestName ->+ ConformanceConfig ->+ (row -> key) ->+ FetchPage row ->+ -- | Expected rows in canonical order, fetched at test run time.+ IO [row] ->+ TestTree+testConformance name config keyOf fetchPage getExpected =+ testCase name $ do+ expected <- getExpected+ report <- checkConformance config keyOf fetchPage expected+ if conformancePassed report+ then pure ()+ else assertFailure (Text.unpack (renderConformanceReport report))
+ src/Relay/Pagination/Conformance/Walk.hs view
@@ -0,0 +1,132 @@+-- | Page walker: fetch every page of a paginated endpoint in one direction,+-- following cursors, defended against paginators that never terminate.+--+-- The walker's only handle on the system under test is a 'FetchPage'+-- callback, so it works over a hasql session, an HTTP client, or a pure+-- fake. Two independent defenses bound the walk (see 'WalkFailure'): a set+-- of every cursor already followed catches genuine cycles, and a page cap+-- catches non-cycling divergence (a paginator that mints a fresh bogus+-- cursor every page). Both failure modes exist in the wild and neither+-- check subsumes the other.+module Relay.Pagination.Conformance.Walk+ ( FetchPage,+ WalkConfig (..),+ defaultWalkConfig,+ WalkFailure (..),+ WalkedPage (..),+ Walk (..),+ walkForward,+ walkBackward,+ walkForwardWith,+ walkBackwardWith,+ )+where++import Data.ByteString (ByteString)+import Data.Set qualified as Set+import Relay.Pagination++-- | How the conformance walker fetches a page from the system under test.+type FetchPage row = PageRequest -> IO (Connection row)++-- | Walker limits. 'maxWalkPages' bounds the number of pages fetched in one+-- walk; a conforming endpoint with more pages than this cannot be checked+-- without raising the cap.+data WalkConfig = WalkConfig+ { maxWalkPages :: !Int+ }+ deriving stock (Eq, Show)++-- | 10 000 pages.+defaultWalkConfig :: WalkConfig+defaultWalkConfig = WalkConfig {maxWalkPages = 10000}++-- | Why a walk aborted instead of reaching the end of the result set.+data WalkFailure+ = -- | The cursor the walker was about to follow (raw wire bytes) had+ -- already been followed earlier in this walk: the paginator re-issued+ -- an old cursor and the walk would cycle. The 'Int' is the index of the+ -- page the walker was about to fetch.+ WalkCursorLoop !Int !ByteString+ | -- | The walk did not terminate within 'maxWalkPages' pages (the 'Int'+ -- is that cap): either the result set is genuinely bigger than the cap,+ -- or the paginator diverges by minting fresh cursors forever.+ WalkPageLimitExceeded !Int+ | -- | The page at this index claims a continuation ('hasNextPage' forward,+ -- 'hasPreviousPage' backward) but provides no cursor to continue from+ -- ('endCursor' / 'startCursor' is 'Nothing').+ WalkMissingCursor !Int+ deriving stock (Eq, Show)++-- | One fetched page plus the exact request that produced it — the evidence+-- the invariant checker needs.+data WalkedPage row = WalkedPage+ { pageIndex :: !Int,+ requestSent :: !PageRequest,+ page :: !(Connection row)+ }+ deriving stock (Show)++-- | A completed walk.+data Walk row = Walk+ { -- | All edges in canonical order, regardless of walk direction.+ walkEdges :: ![Edge row],+ -- | Every page in visit order ('pageIndex' ascending).+ walkPages :: ![WalkedPage row]+ }+ deriving stock (Show)++-- | Walk forward from the beginning: first request has no cursor, then+-- follow 'endCursor' while 'hasNextPage' is true.+walkForward :: FetchPage row -> Int -> IO (Either WalkFailure (Walk row))+walkForward = walkForwardWith defaultWalkConfig++-- | Walk backward from the end: first request has no cursor, then follow+-- 'startCursor' while 'hasPreviousPage' is true.+walkBackward :: FetchPage row -> Int -> IO (Either WalkFailure (Walk row))+walkBackward = walkBackwardWith defaultWalkConfig++-- | 'walkForward' with explicit limits.+walkForwardWith :: WalkConfig -> FetchPage row -> Int -> IO (Either WalkFailure (Walk row))+walkForwardWith = walkWith Forward++-- | 'walkBackward' with explicit limits.+walkBackwardWith :: WalkConfig -> FetchPage row -> Int -> IO (Either WalkFailure (Walk row))+walkBackwardWith = walkWith Backward++walkWith :: Direction -> WalkConfig -> FetchPage row -> Int -> IO (Either WalkFailure (Walk row))+walkWith dir config fetchPage size = go 0 Set.empty Nothing []+ where+ go i followed currentCursor visited+ | i >= maxWalkPages config = pure (Left (WalkPageLimitExceeded (maxWalkPages config)))+ | otherwise = do+ let request = PageRequest {pageSize = size, direction = dir, cursor = currentCursor}+ fetched <- fetchPage request+ let walked = WalkedPage {pageIndex = i, requestSent = request, page = fetched}+ visited' = walked : visited+ info = pageInfo fetched+ (continues, nextCursor) = case dir of+ Forward -> (hasNextPage info, endCursor info)+ Backward -> (hasPreviousPage info, startCursor info)+ if not continues+ then pure (Right (assemble visited'))+ else case nextCursor of+ Nothing -> pure (Left (WalkMissingCursor i))+ Just next@(Cursor bytes)+ | Set.member bytes followed -> pure (Left (WalkCursorLoop (i + 1) bytes))+ | otherwise -> go (i + 1) (Set.insert bytes followed) (Just next) visited'++ -- Each page is internally canonical in both directions. A backward walk+ -- visits pages last-to-first, so concatenating pages in *reverse visit+ -- order* restores the full canonical sequence; the prepend-accumulated+ -- `visited` list is already in that order. A forward walk needs visit+ -- order, i.e. `reverse visited`.+ assemble visited =+ let visitOrder = reverse visited+ canonicalPages = case dir of+ Forward -> visitOrder+ Backward -> visited+ in Walk+ { walkEdges = concatMap (\w -> edges (page w)) canonicalPages,+ walkPages = visitOrder+ }
+ test/Broken.hs view
@@ -0,0 +1,148 @@+-- | Deliberately broken paginators, each reproducing a real production+-- failure mode, used to prove the conformance suite has teeth. A+-- conformance suite that cannot fail is worthless.+module Broken+ ( brokenBoundary,+ brokenBackwardOrder,+ FloatRow (..),+ floatCursorBytes,+ floatRoundTripMicros,+ brokenFloatCursor,+ )+where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as Char8+import Data.Int (Int64)+import Data.Text (Text)+import Data.Text.Encoding qualified as Text+import Oracle (oraclePaginate)+import Relay.Pagination++-- | Production Bug A verbatim: delegate to the correct oracle, then+-- overwrite the walk-direction boundary flag with @length == pageSize@.+-- Whenever the remaining row count is an exact multiple of the page size,+-- the final full page claims a continuation and clients fetch a phantom+-- empty page.+brokenBoundary :: (row -> ByteString) -> [row] -> PageRequest -> Connection row+brokenBoundary cursorOf rows req@PageRequest {pageSize = size, direction = dir} =+ let correct = oraclePaginate cursorOf rows req+ full = length (edges correct) == size+ PageInfo+ { hasNextPage = nextFlag,+ hasPreviousPage = prevFlag,+ startCursor = sc,+ endCursor = ec+ } = pageInfo correct+ dishonest = case dir of+ Forward ->+ PageInfo {hasNextPage = full, hasPreviousPage = prevFlag, startCursor = sc, endCursor = ec}+ Backward ->+ PageInfo {hasNextPage = nextFlag, hasPreviousPage = full, startCursor = sc, endCursor = ec}+ in Connection {edges = edges correct, pageInfo = dishonest}++-- | The reference implementation's third failure mode: backward pages+-- returned in reversed (SQL-flipped) order, start/end cursors swapped to+-- match. Violates backward symmetry and edge-order invariance.+brokenBackwardOrder :: (row -> ByteString) -> [row] -> PageRequest -> Connection row+brokenBackwardOrder cursorOf rows req@PageRequest {direction = dir} =+ let correct = oraclePaginate cursorOf rows req+ in case dir of+ Forward -> correct+ Backward ->+ let PageInfo+ { hasNextPage = nextFlag,+ hasPreviousPage = prevFlag,+ startCursor = sc,+ endCursor = ec+ } = pageInfo correct+ in Connection+ { edges = reverse (edges correct),+ pageInfo =+ PageInfo+ { hasNextPage = nextFlag,+ hasPreviousPage = prevFlag,+ startCursor = ec,+ endCursor = sc+ }+ }++-- | A row whose sort key is an exact integer-microsecond timestamp; ordered+-- ascending by @(rowStamp, rowIdent)@ with 'rowIdent' unique.+data FloatRow = FloatRow+ { rowStamp :: !Int64,+ rowIdent :: !Text+ }+ deriving stock (Eq, Ord, Show)++-- | Production Bug B's cursor shape: the timestamp rendered through+-- floating-point epoch seconds, then the identity. Modeled with+-- single-precision 'Float' because a 'Double' of epoch seconds happens to+-- round-trip microseconds exactly at 2026 epoch magnitudes (ulp ≈ 0.24 µs,+-- under the 0.5 µs rounding threshold) — the same bug class, reliably+-- reproducible.+floatCursorBytes :: FloatRow -> ByteString+floatCursorBytes r =+ Char8.pack (show (microsToFloatSeconds (rowStamp r)))+ <> ":"+ <> Text.encodeUtf8 (rowIdent r)++-- | What the timestamp becomes after the cursor round trip: micros →+-- 'Float' seconds → micros. Not the identity; tests must pick a stamp where+-- the round trip lands *above* the original (and assert that it does).+floatRoundTripMicros :: Int64 -> Int64+floatRoundTripMicros us = round (realToFrac (microsToFloatSeconds us) * 1e6 :: Double)++microsToFloatSeconds :: Int64 -> Float+microsToFloatSeconds us = fromIntegral us / 1e6++-- | Production Bug B: the keyset boundary is computed by re-parsing the+-- lossy 'Double' out of the cursor and comparing *exact* row stamps against+-- the *reconstructed* stamp. When reconstruction rounds up, every remaining+-- row sharing the boundary timestamp is skipped. Forward-only model; tests+-- run it with 'checkBackward' off.+brokenFloatCursor :: [FloatRow] -> PageRequest -> Connection FloatRow+brokenFloatCursor rows PageRequest {pageSize = size, direction = dir, cursor = mCursor} =+ case dir of+ Backward ->+ -- Never exercised: the teeth test disables the backward walk.+ Connection+ { edges = [],+ pageInfo =+ PageInfo+ { hasNextPage = False,+ hasPreviousPage = False,+ startCursor = Nothing,+ endCursor = Nothing+ }+ }+ Forward ->+ let rest = case mCursor of+ Nothing -> rows+ Just (Cursor bytes) ->+ let (stampField, identField) = Char8.break (== ':') bytes+ reconstructedMicros =+ round (realToFrac (read (Char8.unpack stampField) :: Float) * 1e6 :: Double) :: Int64+ boundaryIdent = Text.decodeUtf8Lenient (Char8.drop 1 identField)+ in -- BUG: exact stamps compared against the lossy reconstruction.+ filter+ (\r -> (rowStamp r, rowIdent r) > (reconstructedMicros, boundaryIdent))+ rows+ slice = take size rest+ probeExists = length rest > size+ in Connection+ { edges = [Edge {node = r, cursor = Cursor (floatCursorBytes r)} | r <- slice],+ pageInfo =+ PageInfo+ { hasNextPage = probeExists,+ hasPreviousPage = case mCursor of+ Just _ -> True+ Nothing -> False,+ startCursor = case slice of+ r : _ -> Just (Cursor (floatCursorBytes r))+ [] -> Nothing,+ endCursor = case reverse slice of+ r : _ -> Just (Cursor (floatCursorBytes r))+ [] -> Nothing+ }+ }
+ test/CheckSpec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE BlockArguments #-}++-- | The checker against the known-good oracle (must pass) and against the+-- three deliberately broken paginators (must fail, with readable reports).+module CheckSpec (tests) where++import Broken+import Data.ByteString.Char8 qualified as Char8+import Data.List (nub, sort)+import Data.Text qualified as Text+import Oracle (oraclePaginate)+import Relay.Pagination+import Relay.Pagination.Conformance.Check+import Relay.Pagination.Conformance.Tasty (testConformance)+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+ testGroup+ "checker"+ [ testGroup+ "oracle passes with zero violations"+ [ testCase (show n <> " rows, page size 3") do+ report <-+ checkConformance+ (defaultConformanceConfig 3)+ id+ (\req -> pure (oraclePaginate intBytes [1 .. n] req))+ [1 .. n]+ violations report @?= []+ assertBool "conformancePassed" (conformancePassed report)+ | n <- [0, 1, 7 :: Int]+ ],+ testConformance+ "tasty adapter: oracle passes"+ (defaultConformanceConfig 3)+ id+ (\req -> pure (oraclePaginate intBytes [1 .. 10 :: Int] req))+ (pure [1 .. 10]),+ testGroup+ "teeth"+ [ testCaseInfo "brokenBoundary fails BoundaryHonesty (report below)" do+ -- 9 rows at page size 3: the remaining count is always an exact+ -- multiple of the page size, the worst case for Bug A.+ report <-+ checkConformance+ forwardOnly3+ id+ (\req -> pure (brokenBoundary intBytes [1 .. 9 :: Int] req))+ [1 .. 9]+ assertBool "must fail" (not (conformancePassed report))+ nub (map invariant (violations report)) @?= [BoundaryHonesty]+ sort (map pageIndex (violations report)) @?= [Just 2, Just 3]+ pure (Text.unpack (renderConformanceReport report)),+ testCase "brokenFloatCursor fails Completeness with skipped keys" do+ -- Pick a stamp whose micros -> Float seconds -> micros round+ -- trip rounds UP, so the lossy comparison skips the whole tie+ -- run; assert the skew exists so this test can never silently+ -- test nothing. If the base's round trip lands below it, one+ -- microsecond under that landing point must round trip upward.+ let landed = floatRoundTripMicros baseStamp+ stamp = if landed > baseStamp then baseStamp else landed - 1+ assertBool+ ("round trip must skew upward, got " <> show (stamp, floatRoundTripMicros stamp))+ (floatRoundTripMicros stamp > stamp)+ let rows =+ [ FloatRow {rowStamp = stamp, rowIdent = identFor n}+ | n <- [1 .. 20 :: Int]+ ]+ report <-+ checkConformance+ ConformanceConfig+ { pageSize = 6,+ maxWalkPages = 10000,+ checkBackward = False, -- forward-only model+ checkDeterminism = True+ }+ rowIdent+ (\req -> pure (brokenFloatCursor rows req))+ rows+ assertBool "must fail" (not (conformancePassed report))+ let completeness = [v | v <- violations report, invariant v == Completeness]+ assertBool "has a Completeness violation" (not (null completeness))+ assertBool+ "the report names the first skipped key"+ (any (\v -> "f07" `Text.isInfixOf` detail v) completeness),+ testCase "brokenBackwardOrder fails BackwardSymmetry and EdgeOrderInvariance" do+ report <-+ checkConformance+ (defaultConformanceConfig 3)+ id+ (\req -> pure (brokenBackwardOrder intBytes [1 .. 7 :: Int] req))+ [1 .. 7]+ assertBool "must fail" (not (conformancePassed report))+ let names = nub (sort (map invariant (violations report)))+ assertBool "BackwardSymmetry violated" (BackwardSymmetry `elem` names)+ assertBool "EdgeOrderInvariance violated" (EdgeOrderInvariance `elem` names)+ ]+ ]+ where+ forwardOnly3 =+ ConformanceConfig+ { pageSize = 3,+ maxWalkPages = 10000,+ checkBackward = False,+ checkDeterminism = True+ }++ intBytes :: Int -> Char8.ByteString+ intBytes = Char8.pack . show++ identFor n = "f" <> (if n < 10 then "0" else "") <> Text.pack (show n)++ -- Around 2026-01-02T03:04:05 UTC in microseconds.+ baseStamp = 1767323045123456
+ test/DbFixture.hs view
@@ -0,0 +1,148 @@+-- | Shared ephemeral-pg fixture for the database-backed groups: one+-- throwaway PostgreSQL server and one hasql connection for the whole suite+-- (via tasty 'Test.Tasty.withResource'); per-case isolation is a cheap+-- 'resetRows' TRUNCATE, since the schema never changes between cases.+--+-- The table exercises the reference service's exact sort shape: a tie-prone+-- timestamp ordered descending with a unique ascending tie-breaker+-- (@updated_at DESC, row_id ASC@).+module DbFixture+ ( TestRow (..),+ canonicalOrder,+ acquireDb,+ releaseDb,+ resetRows,+ insertRows,+ fetchViaEngine,+ testSortSpec,+ testRowDecoder,+ run,+ )+where++import Data.Aeson (FromJSON, ToJSON)+import Data.Functor.Contravariant ((>$<))+import Data.List.NonEmpty (NonEmpty (..))+import Data.Ord (Down (..), comparing)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import Data.UUID.Types (UUID)+import EphemeralPg qualified as Pg+import GHC.Generics (Generic)+import Hasql.Connection qualified as HasqlConn+import Hasql.Decoders qualified as Decoders+import Hasql.DynamicStatements.Snippet (Snippet)+import Hasql.DynamicStatements.Snippet qualified as Snippet+import Hasql.Encoders qualified as Encoders+import Hasql.Session qualified as Session+import Hasql.Statement (Statement)+import Hasql.Statement qualified as Statement+import Relay.Pagination (Connection, PageRequest)+import Relay.Pagination.Hasql+ ( KeyColumn (..),+ SortDirection (..),+ SortSpec (..),+ paginate,+ timestamptzKey,+ uuidKey,+ )++data TestRow = TestRow+ { rowId :: !UUID,+ updatedAt :: !UTCTime,+ payload :: !Text+ }+ deriving stock (Eq, Show, Generic)+ -- JSON instances for the M6 HTTP walk (aeson round-trips UTCTime at+ -- microsecond precision losslessly).+ deriving anyclass (ToJSON, FromJSON)++-- | The canonical order under 'testSortSpec': @updated_at DESC, row_id ASC@.+canonicalOrder :: TestRow -> TestRow -> Ordering+canonicalOrder = comparing (Down . updatedAt) <> comparing rowId++-- | @updated_at DESC, row_id ASC@ from EP-3's built-in codecs; the mixed+-- directions force the engine's expanded lexicographic predicate.+testSortSpec :: SortSpec TestRow+testSortSpec =+ SortSpec+ ( KeyColumn "updated_at" Desc updatedAt timestamptzKey+ :| [KeyColumn "row_id" Asc rowId uuidKey]+ )++baseQuery :: Snippet+baseQuery = Snippet.sql "SELECT row_id, updated_at, payload FROM conformance_rows"++testRowDecoder :: Decoders.Row TestRow+testRowDecoder =+ TestRow+ <$> Decoders.column (Decoders.nonNullable Decoders.uuid)+ <*> Decoders.column (Decoders.nonNullable Decoders.timestamptz)+ <*> Decoders.column (Decoders.nonNullable Decoders.text)++-- | EP-3's engine wired as the conformance suite's 'FetchPage' callback.+-- Every cursor in these tests is minted by the engine itself, so a 'Left'+-- (cursor rejected against the spec) is a test failure.+fetchViaEngine :: HasqlConn.Connection -> PageRequest -> IO (Connection TestRow)+fetchViaEngine conn req =+ case paginate testSortSpec req baseQuery testRowDecoder of+ Left err -> fail ("cursor rejected by the engine: " <> show err)+ Right stmt -> run conn (Session.statement () stmt)++-- | One cached-initdb server plus one connection, with the schema created.+acquireDb :: IO (Pg.Database, HasqlConn.Connection)+acquireDb = do+ db <-+ either (fail . Text.unpack . Pg.renderStartError) pure+ =<< Pg.startCached Pg.defaultConfig Pg.defaultCacheConfig+ conn <- either (fail . show) pure =<< HasqlConn.acquire (Pg.connectionSettings db)+ run conn createSchema+ pure (db, conn)++releaseDb :: (Pg.Database, HasqlConn.Connection) -> IO ()+releaseDb (db, conn) = HasqlConn.release conn *> Pg.stop db++run :: HasqlConn.Connection -> Session.Session a -> IO a+run conn session = either (fail . show) pure =<< HasqlConn.use conn session++createSchema :: Session.Session ()+createSchema =+ Session.script+ """+ CREATE TABLE conformance_rows (+ row_id uuid PRIMARY KEY,+ updated_at timestamptz NOT NULL,+ payload text NOT NULL+ );+ """++-- | Per-case isolation.+resetRows :: HasqlConn.Connection -> IO ()+resetRows conn = run conn (Session.script "TRUNCATE conformance_rows")++-- | One multi-row insert via @unnest@ (loop insertion is too slow at+-- hundreds of rows per property case); the generated values stay typed+-- hasql parameters, never interpolated into the SQL.+insertRows :: HasqlConn.Connection -> [TestRow] -> IO ()+insertRows conn rows =+ run conn $+ Session.statement+ (unzip3 [(rowId r, updatedAt r, payload r) | r <- rows])+ insertStatement++insertStatement :: Statement ([UUID], [UTCTime], [Text]) ()+insertStatement = Statement.preparable sql encoder Decoders.noResult+ where+ sql =+ """+ INSERT INTO conformance_rows (row_id, updated_at, payload)+ SELECT * FROM unnest($1::uuid[], $2::timestamptz[], $3::text[])+ """+ encoder =+ ((\(ids, _, _) -> ids) >$< arrayParam Encoders.uuid)+ <> ((\(_, stamps, _) -> stamps) >$< arrayParam Encoders.timestamptz)+ <> ((\(_, _, payloads) -> payloads) >$< arrayParam Encoders.text)+ arrayParam value =+ Encoders.param+ (Encoders.nonNullable (Encoders.foldableArray (Encoders.nonNullable value)))
+ test/DbSpec.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE BlockArguments #-}++-- | The conformance suite pointed at the real EP-3 keyset engine over+-- ephemeral-pg, fed by the adversarial generators. Every property inserts a+-- generated dataset, computes the expected canonical order in Haskell, and+-- requires a clean 'ConformanceReport'; failures print the rendered report+-- as the QuickCheck counterexample.+module DbSpec (tests) where++import Data.List (sortBy)+import Data.Text qualified as Text+import DbFixture+import Generators+import Hasql.Connection qualified as HasqlConn+import Relay.Pagination.Conformance.Check+import Test.Tasty+import Test.Tasty.QuickCheck++tests :: TestTree+tests = withResource acquireDb releaseDb \getDb ->+ -- Database-backed properties cost real time; 20 cases each is plenty+ -- given how adversarial the generators are. The group is sequential:+ -- its tests share one connection and one table, and the -threaded RTS+ -- (needed for warp in HttpSpec) lets tasty run tests concurrently.+ localOption (QuickCheckTests 20) $+ sequentialTestGroup+ "db (EP-3 engine over ephemeral-pg)"+ AllFinish+ [ conformanceProperty getDb "heavy ties: boundaries inside tie runs" genHeavyTies,+ conformanceProperty getDb "adjacent microseconds" genAdjacentMicros,+ conformanceProperty getDb "exact page-boundary sizes" genExactBoundaries,+ conformanceProperty getDb "extreme page sizes (1 and 100)" genExtremeSizes+ ]++conformanceProperty ::+ IO (db, HasqlConn.Connection) ->+ TestName ->+ Gen (Int, [TestRow]) ->+ TestTree+conformanceProperty getDb name gen =+ testProperty name $+ forAll gen \(size, rows) -> ioProperty do+ (_, conn) <- getDb+ resetRows conn+ insertRows conn rows+ let expected = sortBy canonicalOrder rows+ report <-+ checkConformance (defaultConformanceConfig size) rowId (fetchViaEngine conn) expected+ pure $+ counterexample+ (Text.unpack (renderConformanceReport report))+ (conformancePassed report)
+ test/Generators.hs view
@@ -0,0 +1,101 @@+-- | QuickCheck generators for the datasets that historically break+-- paginators. Each yields @(pageSize, rows)@; rows are unsorted (the+-- property computes the canonical order itself).+--+-- Timestamps are built from integer microseconds+-- ('Relay.Pagination.Hasql.KeyCodec.microsToUtcTime'), never from 'Double'+-- seconds — otherwise the test itself would reintroduce the lossy-cursor+-- bug it exists to catch.+module Generators+ ( genHeavyTies,+ genAdjacentMicros,+ genExactBoundaries,+ genExtremeSizes,+ genMutationCase,+ )+where++import Data.Int (Int64)+import Data.Text qualified as Text+import DbFixture (TestRow (..))+import Relay.Pagination.Hasql.KeyCodec (microsToUtcTime)+import Test.QuickCheck.Instances ()+import Test.Tasty.QuickCheck++-- | 100–300 rows spread over only 1–3 distinct timestamps: ordering rests+-- entirely on the unique tie-breaker, and every page boundary falls inside+-- a tie run. Trips lossy-timestamp cursors (reference Bug B).+genHeavyTies :: Gen (Int, [TestRow])+genHeavyTies = do+ stampCount <- chooseInt (1, 3)+ stamps <- vectorOf stampCount genStampMicros+ rowCount <- chooseInt (100, 300)+ rows <- vectorOf rowCount (genRowAmong stamps)+ size <- chooseInt (2, 10)+ pure (size, rows)++-- | Rows at successive 1-microsecond offsets (PostgreSQL @timestamptz@+-- resolution): catches any code path that truncates or rounds sub-second+-- precision.+genAdjacentMicros :: Gen (Int, [TestRow])+genAdjacentMicros = do+ base <- genStampMicros+ rowCount <- chooseInt (50, 150)+ rows <-+ traverse+ (\offset -> genRowAt (base + fromIntegral offset))+ [0 .. rowCount - 1]+ size <- chooseInt (2, 10)+ pure (size, rows)++-- | Row counts of exactly 0, 1, n, n+1, 2n, and 2n+1 for page size n — the+-- sizes at which @length == pageSize@ heuristics and probe-row logic go+-- wrong (reference Bug A).+genExactBoundaries :: Gen (Int, [TestRow])+genExactBoundaries = do+ size <- chooseInt (2, 10)+ rowCount <- elements [0, 1, size, size + 1, 2 * size, 2 * size + 1]+ stamps <- vectorOf 2 genStampMicros+ rows <- vectorOf rowCount (genRowAmong stamps)+ pure (size, rows)++-- | Page size 1 (every row is its own page: maximal boundary count, capped+-- rows to keep the walk affordable) and page size 100 (a representative+-- endpoint maximum; EP-3's 'paginate' takes no 'PageConfig', so the+-- constant stands in for @maxPageSize@).+genExtremeSizes :: Gen (Int, [TestRow])+genExtremeSizes = do+ size <- elements [1, 100]+ rowCount <- chooseInt (0, if size == 1 then 40 else 250)+ stamps <- vectorOf 3 genStampMicros+ rows <- vectorOf rowCount (genRowAmong stamps)+ pure (size, rows)++-- | For the mutation-under-walk properties: @(pageSize, initial, extras)@.+-- The initial dataset spans at least @3·pageSize + 1@ rows (four or more+-- pages, so mutating before page 2 happens mid-walk), with ties included.+-- The extras are row templates whose ids/payloads are used for mid-walk+-- inserts; their timestamps are overwritten at mutation time relative to+-- the observed cursor boundary.+genMutationCase :: Gen (Int, [TestRow], [TestRow])+genMutationCase = do+ size <- chooseInt (2, 6)+ stamps <- vectorOf 3 genStampMicros+ rowCount <- chooseInt (3 * size + 1, 6 * size)+ initial <- vectorOf rowCount (genRowAmong stamps)+ extraCount <- chooseInt (1, size)+ extras <- vectorOf extraCount (genRowAmong stamps)+ pure (size, initial, extras)++-- | 2023-11..2027-01 in whole microseconds.+genStampMicros :: Gen Int64+genStampMicros = choose (1_700_000_000_000_000, 1_800_000_000_000_000)++genRowAmong :: [Int64] -> Gen TestRow+genRowAmong stamps = genRowAt =<< elements stamps++genRowAt :: Int64 -> Gen TestRow+genRowAt stamp = do+ rowIdValue <- arbitrary+ payloadValue <- Text.pack <$> resize 12 (listOf (elements ['a' .. 'z']))+ pure TestRow {rowId = rowIdValue, updatedAt = microsToUtcTime stamp, payload = payloadValue}
+ test/HttpSpec.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE BlockArguments #-}++-- | The three packages composed over real HTTP: a warp server exposing the+-- EP-3 engine through EP-2's 'RelayPage' combinator in a 'NamedRoutes'+-- record, walked by the same 'checkConformance' the direct-session tests+-- use — with 'FetchPage' wired through servant-client. This proves the+-- combinator's request parsing, the typed 'MultiVerb' result, and core's+-- JSON round-trip do not perturb the conformance guarantees.+module HttpSpec (tests) where++import Control.Monad.IO.Class (liftIO)+import Data.List (sortBy)+import Data.Proxy (Proxy (..))+import Data.SOP (I (..), NS (..))+import Data.Text qualified as Text+import Data.UUID.Types qualified as UUID+import DbFixture+import GHC.Generics (Generic)+import Hasql.Connection qualified as HasqlConn+import Network.HTTP.Client qualified as HttpClient+import Network.Wai.Handler.Warp (testWithApplication)+import Relay.Pagination+import Relay.Pagination.Conformance.Check+import Relay.Pagination.Conformance.Walk (FetchPage)+import Relay.Pagination.Hasql.KeyCodec (microsToUtcTime)+import Relay.Pagination.Servant+import Servant (Application, serve)+import Servant.API (JSON, NamedRoutes, StdMethod (GET), (:-), (:>))+import Servant.API.MultiVerb (AsUnion (..), MultiVerb, Respond)+import Servant.Client (BaseUrl (..), ClientM, Scheme (Http), mkClientEnv, runClientM)+import Servant.Client.Generic (AsClientT, genericClient)+import Servant.Server.Generic (AsServerT)+import Servant.Server.Internal (Handler)+import Test.Tasty+import Test.Tasty.HUnit++type RowsPageResponses =+ '[ Respond 200 "Page of rows" (Connection TestRow),+ Respond 400 "Invalid pagination" RelayPageError+ ]++data RowsPageResult+ = RowsPageOk !(Connection TestRow)+ | RowsPageBadRequest !RelayPageError+ deriving stock (Show)++-- | Hand-written, per ADR 1: status/constructor mapping breaks at compile+-- time if the response list changes.+instance AsUnion RowsPageResponses RowsPageResult where+ toUnion = \case+ RowsPageOk value -> Z (I value)+ RowsPageBadRequest err -> S (Z (I err))+ fromUnion = \case+ Z (I value) -> RowsPageOk value+ S (Z (I err)) -> RowsPageBadRequest err+ S (S impossible) -> case impossible of {}++data RowsRoutes mode = RowsRoutes+ { rows ::+ mode+ :- "rows"+ :> RelayPage 5 50+ :> MultiVerb 'GET '[JSON] RowsPageResponses RowsPageResult+ }+ deriving stock (Generic)++-- | One proxy for both @serve@ and @genericClient@, so the served and+-- called route types cannot drift apart.+rowsApi :: Proxy (NamedRoutes RowsRoutes)+rowsApi = Proxy++rowsServer :: HasqlConn.Connection -> RowsRoutes (AsServerT Handler)+rowsServer conn =+ RowsRoutes {rows = \pageRequest -> liftIO (RowsPageOk <$> fetchViaEngine conn pageRequest)}++rowsApp :: HasqlConn.Connection -> Application+rowsApp conn = serve rowsApi (rowsServer conn)++rowsClient :: RowsRoutes (AsClientT ClientM)+rowsClient = genericClient++-- | Translate the walker's 'PageRequest' back into Relay query arguments:+-- Forward becomes @first@ + @after@, Backward becomes @last@ + @before@.+toClientPage :: PageRequest -> ClientPage+toClientPage PageRequest {pageSize = size, direction = dir, cursor = mCursor} =+ case dir of+ Forward -> forwardPage size mCursor+ Backward -> backwardPage size mCursor++tests :: TestTree+tests = withResource acquireDb releaseDb \getDb ->+ testGroup+ "http (RelayPage over warp)"+ [ testCase "conformance walk through servant-client" do+ (_, conn) <- getDb+ resetRows conn+ insertRows conn fixtureRows+ testWithApplication (pure (rowsApp conn)) \port -> do+ manager <- HttpClient.newManager HttpClient.defaultManagerSettings+ let env = mkClientEnv manager (BaseUrl Http "127.0.0.1" port "")+ fetchPage :: FetchPage TestRow+ fetchPage req =+ runClientM (rows rowsClient (toClientPage req)) env >>= \case+ Right (RowsPageOk page) -> pure page+ Right (RowsPageBadRequest err) ->+ fail ("server rejected pagination: " <> show err)+ Left clientError -> fail ("transport failure: " <> show clientError)+ report <-+ checkConformance+ (defaultConformanceConfig 5)+ rowId+ fetchPage+ (sortBy canonicalOrder fixtureRows)+ assertBool+ (Text.unpack (renderConformanceReport report))+ (conformancePassed report)+ ]++-- | 25 deterministic rows in the EP-3 integration fixture's adversarial+-- shape: two ten-way timestamp ties, a microsecond-adjacent pair, three+-- distinct older stamps. 25 rows at page size 5 make the final page exactly+-- full.+fixtureRows :: [TestRow]+fixtureRows =+ [row n 1767323045123456 | n <- [1 .. 10]]+ <> [row n 1767323044123456 | n <- [11 .. 20]]+ <> [ row 21 1767323043000001,+ row 22 1767323043000002,+ row 23 1767323042000000,+ row 24 1767323041000000,+ row 25 1767323040000000+ ]+ where+ row n stamp =+ TestRow+ { rowId = UUID.fromWords 0 0 0 (fromIntegral (n :: Int)),+ updatedAt = microsToUtcTime stamp,+ payload = "row-" <> Text.pack (show n)+ }
+ test/Main.hs view
@@ -0,0 +1,21 @@+module Main (main) where++import CheckSpec qualified+import DbSpec qualified+import HttpSpec qualified+import MutationSpec qualified+import Test.Tasty+import WalkSpec qualified++main :: IO ()+main =+ defaultMain+ ( testGroup+ "relay-pagination-conformance"+ [ WalkSpec.tests,+ CheckSpec.tests,+ DbSpec.tests,+ MutationSpec.tests,+ HttpSpec.tests+ ]+ )
+ test/MutationSpec.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE BlockArguments #-}++-- | Mutation under walk: the infinite-scroll guarantee that justifies+-- keyset pagination's existence.+--+-- A keyset cursor names a /position in key space/ — "after+-- (updated_at = T, row_id = U)". Whether a row sorts before or after that+-- position depends only on the row's own key values; inserting or deleting+-- /other/ rows cannot move it across the boundary. An OFFSET cursor names a+-- /count/ — "skip 40 rows" — so every insert behind the client's position+-- shifts which row comes next, silently duplicating or swallowing+-- pre-existing rows. Keyset pagination therefore guarantees: **every row+-- that existed at walk start and still exists at walk end is visited+-- exactly once.** Rows inserted mid-walk behind the cursor are legitimately+-- missed; rows inserted ahead may legitimately appear; neither may displace+-- a pre-existing row. These properties are that sentence, transliterated.+--+-- Mutations run through the fetch callback itself (an invocation counter+-- fires the INSERT/DELETE before page 2 is served); the public walker API+-- has no mid-walk hook.+module MutationSpec (tests) where++import Control.Monad (when)+import Data.ByteString.Char8 qualified as Char8+import Data.Functor.Contravariant ((>$<))+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.Int (Int64)+import Data.List (sortBy)+import Data.Map.Strict qualified as Map+import Data.Time (addUTCTime)+import Data.UUID.Types (UUID)+import Data.UUID.Types qualified as UUID+import DbFixture+import Generators (genMutationCase)+import Hasql.Connection qualified as HasqlConn+import Hasql.Decoders qualified as Decoders+import Hasql.Encoders qualified as Encoders+import Hasql.Session qualified as Session+import Hasql.Statement (Statement)+import Hasql.Statement qualified as Statement+import Relay.Pagination+import Relay.Pagination.Conformance.Walk+import Relay.Pagination.Hasql.KeyCodec (microsToUtcTime)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++tests :: TestTree+tests = withResource acquireDb releaseDb \getDb ->+ -- Sequential: these tests share one connection and one table (see DbSpec).+ localOption (QuickCheckTests 15) $+ sequentialTestGroup+ "mutation under walk"+ AllFinish+ [ testProperty "engine: insert behind the cursor — initial rows exactly once, inserted rows never" $+ forAll genMutationCase \(size, initial, extras) -> ioProperty do+ (_, conn) <- getDb+ resetRows conn+ insertRows conn initial+ (result, _tracked) <- walkMutatingAtPage2 (fetchViaEngine conn) size \_ boundary -> do+ -- Strictly newer stamps sort strictly before the boundary+ -- under updated_at DESC: behind the cursor.+ let newRows =+ [ TestRow+ { rowId = rowId t,+ updatedAt = addUTCTime (fromIntegral i + 1) (updatedAt boundary),+ payload = payload t+ }+ | (i, t) <- zip [0 :: Int ..] extras+ ]+ insertRows conn newRows+ pure newRows+ pure $ propertyFromWalk result \visitedKeys ->+ counterexample "initial rows must be visited exactly once, in order, with no inserted row" $+ visitedKeys === map rowId (sortBy canonicalOrder initial),+ testProperty "engine: insert ahead of the cursor — initial rows exactly once, inserted at most once, order canonical" $+ forAll genMutationCase \(size, initial, extras) -> ioProperty do+ (_, conn) <- getDb+ resetRows conn+ insertRows conn initial+ let oldestInitial = minimum (map updatedAt initial)+ (result, tracked) <- walkMutatingAtPage2 (fetchViaEngine conn) size \_ _boundary -> do+ -- Strictly older stamps sort strictly after every initial row:+ -- ahead of the cursor, at the end of the walk.+ let newRows =+ [ TestRow+ { rowId = rowId t,+ updatedAt = addUTCTime (negate (fromIntegral i + 1)) oldestInitial,+ payload = payload t+ }+ | (i, t) <- zip [0 :: Int ..] extras+ ]+ insertRows conn newRows+ pure newRows+ pure $ propertyFromWalk result \visitedKeys ->+ let insertedKeys = map rowId tracked+ initialVisited = filter (`notElem` insertedKeys) visitedKeys+ insertedCounts = [c | (k, c) <- Map.toList (occurrences visitedKeys), k `elem` insertedKeys, c > 1]+ in conjoin+ [ counterexample "initial rows must be visited exactly once, in order" $+ initialVisited === map rowId (sortBy canonicalOrder initial),+ counterexample "inserted rows must appear at most once" $+ property (null insertedCounts)+ ],+ testProperty "engine: delete visited rows — surviving and deleted rows each visited exactly once" $+ forAll genMutationCase \(size, initial, _extras) -> ioProperty do+ (_, conn) <- getDb+ resetRows conn+ insertRows conn initial+ (result, _tracked) <- walkMutatingAtPage2 (fetchViaEngine conn) size \visitedSoFar _boundary -> do+ -- Delete 1..pageSize rows the walk has already emitted.+ let victims = take (max 1 size) visitedSoFar+ deleteRows conn (map rowId victims)+ pure victims+ pure $ propertyFromWalk result \visitedKeys ->+ -- Deleted rows were emitted before deletion; surviving rows are+ -- untouched ahead of the cursor: the full initial canonical+ -- sequence, each exactly once.+ counterexample "every initial row (deleted or surviving) must be visited exactly once, in order" $+ visitedKeys === map rowId (sortBy canonicalOrder initial),+ offsetCounterexample getDb+ ]++-- | The suite's teeth for M5: an otherwise-correct OFFSET/LIMIT paginator+-- must fail the insert-behind schedule that the keyset engine survives.+offsetCounterexample :: IO (db, HasqlConn.Connection) -> TestTree+offsetCounterexample getDb =+ testCaseInfo "OFFSET paginator violates insert-behind (detected, report below)" do+ (_, conn) <- getDb+ resetRows conn+ let initial = [deterministicRow n | n <- [1 .. 12]]+ insertRows conn initial+ (result, tracked) <- walkMutatingAtPage2 (offsetFetch conn) 3 \_ boundary -> do+ -- Two rows strictly behind the boundary (between rows 5 and 6).+ let newRows =+ [ TestRow+ { rowId = UUID.fromWords 0 0 1 (100 + fromIntegral i),+ updatedAt = addUTCTime (0.5 + fromIntegral i * 0.1) (updatedAt boundary),+ payload = "inserted"+ }+ | i <- [0 :: Int, 1]+ ]+ insertRows conn newRows+ pure newRows+ walk <- either (fail . show) pure result+ let visitedKeys = [rowId n | Edge {node = n} <- walkEdges walk]+ expectedKeys = map rowId (sortBy canonicalOrder initial)+ duplicated = [k | (k, c) <- Map.toList (occurrences visitedKeys), c > 1]+ missing = [k | k <- expectedKeys, k `notElem` visitedKeys]+ insertedSeen = [k | k <- map rowId tracked, k `elem` visitedKeys]+ assertBool+ "the OFFSET paginator must violate the insert-behind property"+ (visitedKeys /= expectedKeys)+ pure+ ( "detected expected violation:\n"+ <> " rows visited twice (pre-existing rows displaced by the insert): "+ <> show duplicated+ <> "\n rows never visited: "+ <> show missing+ <> "\n mid-walk inserted rows that leaked into the walk: "+ <> show insertedSeen+ )++-- | Walk forward, firing the mutation exactly once, before page 2 is+-- served. The mutation callback receives the rows visited so far and the+-- boundary row (the last node of the previous page) and returns the rows it+-- inserted or deleted, for the caller's assertions.+walkMutatingAtPage2 ::+ FetchPage TestRow ->+ Int ->+ ([TestRow] -> TestRow -> IO [TestRow]) ->+ IO (Either WalkFailure (Walk TestRow), [TestRow])+walkMutatingAtPage2 innerFetch size mutate = do+ counter <- newIORef (0 :: Int)+ visitedRef <- newIORef []+ boundaryRef <- newIORef Nothing+ trackedRef <- newIORef []+ let fetch req = do+ n <- atomicModifyIORef' counter \i -> (i + 1, i)+ when (n == 2) do+ mBoundary <- readIORef boundaryRef+ case mBoundary of+ Just boundary -> do+ visitedSoFar <- readIORef visitedRef+ tracked <- mutate (reverse visitedSoFar) boundary+ modifyIORef' trackedRef (<> tracked)+ Nothing -> pure ()+ fetched <- innerFetch req+ let nodes = [node | Edge {node} <- edges fetched]+ modifyIORef' visitedRef (reverse nodes <>)+ case reverse nodes of+ lastNode : _ -> writeIORef boundaryRef (Just lastNode)+ [] -> pure ()+ pure fetched+ result <- walkForward fetch size+ tracked <- readIORef trackedRef+ pure (result, tracked)++propertyFromWalk ::+ Either WalkFailure (Walk TestRow) ->+ ([UUID] -> Property) ->+ Property+propertyFromWalk result buildProperty = case result of+ Left failure -> counterexample ("walk aborted: " <> show failure) (property False)+ Right walk -> buildProperty [rowId n | Edge {node = n} <- walkEdges walk]++occurrences :: (Ord k) => [k] -> Map.Map k Int+occurrences ks = Map.fromListWith (+) [(k, 1) | k <- ks]++deleteRows :: HasqlConn.Connection -> [UUID] -> IO ()+deleteRows conn keys = run conn (Session.statement keys deleteStatement)++deleteStatement :: Statement [UUID] ()+deleteStatement =+ Statement.preparable+ "DELETE FROM conformance_rows WHERE row_id = ANY($1::uuid[])"+ (Encoders.param (Encoders.nonNullable (Encoders.foldableArray (Encoders.nonNullable Encoders.uuid))))+ Decoders.noResult++-- | An otherwise-correct OFFSET/LIMIT paginator over the same table: honest+-- n+1 probe, honest PageInfo cursors — only the offset addressing is at+-- fault. Forward-only.+offsetFetch :: HasqlConn.Connection -> PageRequest -> IO (Connection TestRow)+offsetFetch conn PageRequest {pageSize = size, direction = dir, cursor = mCursor} = do+ offset <- case dir of+ Backward -> fail "offsetFetch models a forward-only paginator"+ Forward -> pure case mCursor of+ Nothing -> 0 :: Int64+ Just (Cursor bytes) -> read (Char8.unpack bytes)+ fetched <-+ run conn (Session.statement (offset, fromIntegral size + 1) offsetStatement)+ let slice = take size fetched+ probeExists = length fetched > size+ positionCursor i = Cursor (Char8.pack (show (offset + fromIntegral i)))+ edgeList = [Edge {node = r, cursor = positionCursor i} | (i, r) <- zip [1 :: Int ..] slice]+ pure+ Connection+ { edges = edgeList,+ pageInfo =+ PageInfo+ { hasNextPage = probeExists,+ hasPreviousPage = offset > 0,+ startCursor = case edgeList of+ Edge {cursor = c} : _ -> Just c+ [] -> Nothing,+ endCursor = case reverse edgeList of+ Edge {cursor = c} : _ -> Just c+ [] -> Nothing+ }+ }++offsetStatement :: Statement (Int64, Int64) [TestRow]+offsetStatement =+ Statement.preparable+ "SELECT row_id, updated_at, payload FROM conformance_rows ORDER BY updated_at DESC, row_id ASC LIMIT $2 OFFSET $1"+ ( (fst >$< Encoders.param (Encoders.nonNullable Encoders.int8))+ <> (snd >$< Encoders.param (Encoders.nonNullable Encoders.int8))+ )+ (Decoders.rowList testRowDecoder)++-- | Distinct descending stamps and deterministic UUIDs: canonical order is+-- row 1, row 2, … row 12.+deterministicRow :: Int -> TestRow+deterministicRow n =+ TestRow+ { rowId = UUID.fromWords 0 0 0 (fromIntegral n),+ updatedAt = microsToUtcTime (1_767_000_000_000_000 - fromIntegral n * 1_000_000),+ payload = "row"+ }
+ test/Oracle.hs view
@@ -0,0 +1,58 @@+-- | A known-good, pure Relay paginator over an in-memory canonical list —+-- the executable form of the PageInfo semantics table. The walker and+-- checker are tested against it before they are allowed to judge anything.+--+-- Cursors are a stable per-row token (the row's unique key rendered to+-- bytes), never a positional offset.+module Oracle (oraclePaginate) where++import Data.ByteString (ByteString)+import Data.Maybe (isJust)+import Relay.Pagination++-- | Pure Relay pagination over @rows@, which must be the full result set in+-- canonical order. Forward with no cursor: the first @pageSize@ rows; with a+-- cursor: the @pageSize@ rows after the matching row. Backward mirrors it+-- from the end, always preserving canonical order within the page.+-- Boundary flags follow the PageInfo semantics table: the walk-direction+-- flag reflects whether more rows exist beyond the slice, the opposite flag+-- reflects whether a cursor was provided.+oraclePaginate ::+ (row -> ByteString) ->+ [row] ->+ PageRequest ->+ Connection row+oraclePaginate cursorOf rows PageRequest {pageSize = size, direction = dir, cursor = mCursor} =+ case dir of+ Forward ->+ let rest = case mCursor of+ Nothing -> rows+ Just c -> drop 1 (dropWhile (\r -> Cursor (cursorOf r) /= c) rows)+ slice = take size rest+ probeExists = length rest > size+ in connectionOf slice probeExists (isJust mCursor)+ Backward ->+ let preceding = case mCursor of+ Nothing -> rows+ Just c -> takeWhile (\r -> Cursor (cursorOf r) /= c) rows+ slice = lastN size preceding+ probeExists = length preceding > size+ in connectionOf slice (isJust mCursor) probeExists+ where+ connectionOf slice nextFlag prevFlag =+ Connection+ { edges = [Edge {node = r, cursor = Cursor (cursorOf r)} | r <- slice],+ pageInfo =+ PageInfo+ { hasNextPage = nextFlag,+ hasPreviousPage = prevFlag,+ startCursor = case slice of+ r : _ -> Just (Cursor (cursorOf r))+ [] -> Nothing,+ endCursor = case reverse slice of+ r : _ -> Just (Cursor (cursorOf r))+ [] -> Nothing+ }+ }++ lastN n xs = drop (max 0 (length xs - n)) xs
+ test/WalkSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE BlockArguments #-}++-- | The walker, tested against the pure oracle and against fakes that loop,+-- diverge, or drop their continuation cursor.+module WalkSpec (tests) where++import Data.ByteString.Char8 qualified as Char8+import Data.IORef (atomicModifyIORef', newIORef)+import Oracle (oraclePaginate)+import Relay.Pagination+import Relay.Pagination.Conformance.Walk+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+ testGroup+ "walker"+ [ testGroup "reassembles the oracle's rows, forward" (walkCase walkForward <$> sizes),+ testGroup "reassembles the oracle's rows, backward" (walkCase walkBackward <$> sizes),+ testCase "forward walk records pages and boundary flags" do+ Right walk <- walkForward (oracleFetch [1 .. 7]) 3+ map pageIndex (walkPages walk) @?= [0, 1, 2]+ [hasNextPage (pageInfo (page w)) | w <- walkPages walk] @?= [True, True, False]+ [c | w <- walkPages walk, let PageRequest {cursor = c} = requestSent w]+ @?= [Nothing, Just (cursorFor 3), Just (cursorFor 6)],+ testCase "constant-cursor paginator aborts with WalkCursorLoop on page 2" do+ result <- walkForward (\_ -> pure loopingPage) 3+ failureOf result @?= WalkCursorLoop 2 "42",+ testCase "fresh-cursor diverging paginator aborts with WalkPageLimitExceeded" do+ counter <- newIORef (0 :: Int)+ let diverging _ = do+ n <- atomicModifyIORef' counter \i -> (i + 1, i)+ pure (pageWithEnd (Char8.pack (show n)))+ result <- walkForwardWith WalkConfig {maxWalkPages = 5} diverging 3+ failureOf result @?= WalkPageLimitExceeded 5,+ testCase "continuation without a cursor aborts with WalkMissingCursor" do+ let missing _ =+ pure+ Connection+ { edges = [intEdge 1],+ pageInfo =+ PageInfo+ { hasNextPage = True,+ hasPreviousPage = False,+ startCursor = Just (cursorFor 1),+ endCursor = Nothing+ }+ }+ result <- walkForward missing 3+ failureOf result @?= WalkMissingCursor 0+ ]+ where+ sizes = [0, 1, 7, 10]++ walkCase walker n =+ testCase (show n <> " rows, page size 3") do+ result <- walker (oracleFetch [1 .. n]) 3+ case result of+ Right walk -> [node e | e <- walkEdges walk] @?= [1 .. n]+ Left failure -> assertFailure ("walk aborted: " <> show failure)++ failureOf :: Either WalkFailure (Walk Int) -> WalkFailure+ failureOf = either id (\walk -> error ("walk unexpectedly succeeded: " <> show (length (walkEdges walk)) <> " edges"))++ loopingPage =+ Connection+ { edges = [intEdge 42],+ pageInfo =+ PageInfo+ { hasNextPage = True,+ hasPreviousPage = False,+ startCursor = Just (cursorFor 42),+ endCursor = Just (cursorFor 42)+ }+ }++ pageWithEnd bytes =+ Connection+ { edges = [intEdge 0],+ pageInfo =+ PageInfo+ { hasNextPage = True,+ hasPreviousPage = False,+ startCursor = Just (Cursor bytes),+ endCursor = Just (Cursor bytes)+ }+ }++-- | The shared oracle wired as a 'FetchPage' over a list of Ints.+oracleFetch :: [Int] -> FetchPage Int+oracleFetch rows req = pure (oraclePaginate intCursorBytes rows req)++intCursorBytes :: Int -> Char8.ByteString+intCursorBytes = Char8.pack . show++cursorFor :: Int -> Cursor+cursorFor = Cursor . intCursorBytes++intEdge :: Int -> Edge Int+intEdge n = Edge {node = n, cursor = cursorFor n}