diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/relay-pagination-conformance.cabal b/relay-pagination-conformance.cabal new file mode 100644 --- /dev/null +++ b/relay-pagination-conformance.cabal @@ -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 diff --git a/src/Relay/Pagination/Conformance.hs b/src/Relay/Pagination/Conformance.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination/Conformance.hs @@ -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 diff --git a/src/Relay/Pagination/Conformance/Check.hs b/src/Relay/Pagination/Conformance/Check.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination/Conformance/Check.hs @@ -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) diff --git a/src/Relay/Pagination/Conformance/Tasty.hs b/src/Relay/Pagination/Conformance/Tasty.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination/Conformance/Tasty.hs @@ -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)) diff --git a/src/Relay/Pagination/Conformance/Walk.hs b/src/Relay/Pagination/Conformance/Walk.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination/Conformance/Walk.hs @@ -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 + } diff --git a/test/Broken.hs b/test/Broken.hs new file mode 100644 --- /dev/null +++ b/test/Broken.hs @@ -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 + } + } diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/CheckSpec.hs @@ -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 diff --git a/test/DbFixture.hs b/test/DbFixture.hs new file mode 100644 --- /dev/null +++ b/test/DbFixture.hs @@ -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))) diff --git a/test/DbSpec.hs b/test/DbSpec.hs new file mode 100644 --- /dev/null +++ b/test/DbSpec.hs @@ -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) diff --git a/test/Generators.hs b/test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Generators.hs @@ -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} diff --git a/test/HttpSpec.hs b/test/HttpSpec.hs new file mode 100644 --- /dev/null +++ b/test/HttpSpec.hs @@ -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) + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] + ) diff --git a/test/MutationSpec.hs b/test/MutationSpec.hs new file mode 100644 --- /dev/null +++ b/test/MutationSpec.hs @@ -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" + } diff --git a/test/Oracle.hs b/test/Oracle.hs new file mode 100644 --- /dev/null +++ b/test/Oracle.hs @@ -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 diff --git a/test/WalkSpec.hs b/test/WalkSpec.hs new file mode 100644 --- /dev/null +++ b/test/WalkSpec.hs @@ -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}