packages feed

relay-pagination-hasql (empty) → 0.1.0.0

raw patch · 14 files changed

+1274/−0 lines, 14 filesdep +basedep +bytestringdep +ephemeral-pg

Dependencies added: base, bytestring, ephemeral-pg, hasql, hasql-dynamic-statements, relay-pagination, relay-pagination-hasql, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, text, time, uuid

Files

+ CHANGELOG.md view
@@ -0,0 +1,19 @@+# Changelog for relay-pagination-hasql++Versioning follows the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 0.1.0.0 — 2026-07-16++Initial contents:++- Sort specifications: `SortSpec`, existential `KeyColumn`, `SortDirection`,+  and the FNV-1a `sortSpecFingerprint` stamped into every minted cursor.+- Typed key codecs `int8Key`, `textKey`, `uuidKey`, `timestamptzKey`,+  `boolKey` (v1: sort columns must be `NOT NULL`; timestamps travel as exact+  integer microseconds).+- The engine: `paginate` wraps a base-query `Snippet` with an+  expanded-lexicographic keyset `WHERE` (correct for mixed `Asc`/`Desc`+  keys), `ORDER BY`, and `LIMIT n+1`, and assembles a spec-correct+  `Connection` — backward pages are reversed in memory so edges always+  arrive in canonical order. Cursor validation failures surface as+  `Left CursorError` before any SQL runs.
+ 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-hasql.cabal view
@@ -0,0 +1,86 @@+cabal-version:   3.0+name:            relay-pagination-hasql+version:         0.1.0.0+synopsis:+  Keyset-pagination engine producing Relay connections from hasql queries++description:+  Keyset-pagination engine for Relay-style cursors over hasql: declarative+  sort specifications with typed key codecs, generated keyset WHERE/ORDER+  BY/LIMIT clauses with all cursor values as typed SQL parameters, and+  assembly of spec-correct Connection responses.++license:         BSD-3-Clause+license-file:    LICENSE+author:          Nadeem Bitar+maintainer:      Nadeem Bitar+category:        Database, 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+    MultilineStrings+    OverloadedLabels+    OverloadedStrings++library+  import:          lang+  hs-source-dirs:  src+  exposed-modules:+    Relay.Pagination.Hasql+    Relay.Pagination.Hasql.Connection+    Relay.Pagination.Hasql.KeyCodec+    Relay.Pagination.Hasql.SortSpec+    Relay.Pagination.Hasql.Sql++  build-depends:+    , base                      >=4.21     && <5+    , bytestring                >=0.11     && <0.13+    , hasql                     >=1.10     && <1.11+    , hasql-dynamic-statements  >=0.5.1    && <0.6+    , relay-pagination          ^>=0.1.0.0+    , text                      >=2.0      && <2.2+    , time                      >=1.12     && <1.15+    , uuid                      >=1.3      && <1.4++test-suite relay-pagination-hasql-tests+  import:         lang+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  other-modules:+    Test.Codec+    Test.Connection+    Test.Fingerprint+    Test.Integration+    Test.SqlGolden++  build-depends:+    , base+    , bytestring+    , ephemeral-pg+    , hasql+    , hasql-dynamic-statements+    , relay-pagination          ^>=0.1.0.0+    , relay-pagination-hasql+    , tasty+    , tasty-golden+    , tasty-hunit+    , tasty-quickcheck+    , text+    , time+    , uuid
+ src/Relay/Pagination/Hasql.hs view
@@ -0,0 +1,74 @@+-- | Keyset-pagination engine for Relay-style cursors over hasql.+--+-- Given a base query 'Snippet' (filters included, no @ORDER BY@, no+-- @LIMIT@), a 'SortSpec' (ordered sort columns ending in a unique+-- tie-breaker, each with a typed codec), and a row decoder, 'paginate'+-- produces a 'Statement' that fetches one validated page and assembles a+-- spec-correct 'Connection'. Cursor values always travel as typed SQL+-- parameters; malformed cursors surface as 'CursorError' before any SQL+-- runs.+module Relay.Pagination.Hasql+  ( -- * Sort specifications+    SortDirection (..),+    KeyColumn (..),+    SortSpec (..),+    sortSpecFingerprint,++    -- * Codecs+    KeyCodec (..),+    int8Key,+    textKey,+    uuidKey,+    timestamptzKey,+    boolKey,++    -- * Engine+    paginate,+    paginateSnippet,+    mkConnection,+    mintCursor,+  )+where++import Hasql.Decoders qualified as Decoders+import Hasql.DynamicStatements.Snippet (Snippet)+import Hasql.DynamicStatements.Snippet qualified as Snippet+import Hasql.Statement (Statement)+import Relay.Pagination (Connection, CursorError, PageRequest)+import Relay.Pagination.Hasql.Connection (mintCursor, mkConnection)+import Relay.Pagination.Hasql.KeyCodec+  ( KeyCodec (..),+    boolKey,+    int8Key,+    textKey,+    timestamptzKey,+    uuidKey,+  )+import Relay.Pagination.Hasql.SortSpec+  ( KeyColumn (..),+    SortDirection (..),+    SortSpec (..),+    sortSpecFingerprint,+  )+import Relay.Pagination.Hasql.Sql (paginateSnippet)++-- | The whole engine in one function: validate the request's cursor against+-- the sort specification, generate the keyset query, and post-process the+-- fetched rows into a 'Connection'.+--+-- 'Left' means the cursor failed to decode against this spec (wrong+-- fingerprint, key count, or key types) — surfaced before any SQL runs;+-- handlers map it to HTTP 400. The statement is unpreparable (dynamic SQL;+-- see hasql-dynamic-statements). Run it with e.g.+-- @Hasql.Session.statement () stmt@.+paginate ::+  SortSpec row ->+  PageRequest ->+  -- | Base query: @SELECT <cols> FROM ... WHERE <filters>@; no @ORDER BY@,+  -- no @LIMIT@.+  Snippet ->+  Decoders.Row row ->+  Either CursorError (Statement () (Connection row))+paginate spec req base rowDecoder = do+  snippet <- paginateSnippet spec req base+  Right (mkConnection spec req <$> Snippet.toStatement snippet (Decoders.rowList rowDecoder))
+ src/Relay/Pagination/Hasql/Connection.hs view
@@ -0,0 +1,82 @@+-- | Turning fetched rows into a spec-correct Relay 'Connection': cursor+-- minting (in Haskell, from the decoded row — never in SQL) and PageInfo+-- assembly per the semantics table this module encodes.+module Relay.Pagination.Hasql.Connection+  ( mintCursor,+    mkConnection,+  )+where++import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (isJust, listToMaybe)+import Relay.Pagination+  ( Connection (..),+    Cursor,+    CursorPayload (..),+    Direction (..),+    Edge (..),+    PageInfo (..),+    PageRequest (..),+    cursorVersion,+    encodeCursor,+  )+import Relay.Pagination.Hasql.KeyCodec (KeyCodec (..))+import Relay.Pagination.Hasql.SortSpec (KeyColumn (..), SortSpec (..), sortSpecFingerprint)++-- | Mint the cursor addressing one row's position: extract each sort-key+-- value from the decoded row (in spec order, tie-breaker last), stamp the+-- spec's fingerprint, and encode. The values that go into the cursor are the+-- very values the row decoder produced, so the DB → cursor → parameter loop+-- is exact by construction.+mintCursor :: SortSpec row -> row -> Cursor+mintCursor spec@(SortSpec cols) row =+  encodeCursor+    CursorPayload+      { version = cursorVersion,+        fingerprint = sortSpecFingerprint spec,+        keys =+          [ toKeyValue (extract row)+          | KeyColumn {extract, codec = KeyCodec {toKeyValue}} <- NonEmpty.toList cols+          ]+      }++-- | Assemble the Relay connection from the raw fetched rows (up to+-- @pageSize + 1@, in /fetched/ order). This function is the PageInfo+-- semantics table:+--+-- +----------+---------------------+---------------------+------------------++-- | Direction| hasNextPage         | hasPreviousPage     | edge order       |+-- +==========+=====================+=====================+==================++-- | Forward  | probe row existed   | @after@ was given   | canonical        |+-- +----------+---------------------+---------------------+------------------++-- | Backward | @before@ was given  | probe row existed   | canonical        |+-- |          |                     |                     | (rows reversed   |+-- |          |                     |                     | in memory)       |+-- +----------+---------------------+---------------------+------------------++--+-- The probe answers "is there more in the direction I am walking"; the mere+-- presence of a cursor answers "is there something behind me" (the row the+-- cursor was minted from is itself behind you).+mkConnection :: SortSpec row -> PageRequest -> [row] -> Connection row+mkConnection spec PageRequest {pageSize, direction, cursor} rows =+  Connection {edges, pageInfo}+  where+    probe = length rows > pageSize+    kept = take pageSize rows+    -- Backward fetches walk the flipped order, so kept rows arrive+    -- canonically last-to-first; reverse them into canonical order.+    canonical = case direction of+      Forward -> kept+      Backward -> reverse kept+    cursors = map (mintCursor spec) canonical+    edges = zipWith (\r c -> Edge {node = r, cursor = c}) canonical cursors+    (nextPage, previousPage) = case direction of+      Forward -> (probe, isJust cursor)+      Backward -> (isJust cursor, probe)+    pageInfo =+      PageInfo+        { hasNextPage = nextPage,+          hasPreviousPage = previousPage,+          startCursor = listToMaybe cursors,+          endCursor = listToMaybe (reverse cursors)+        }
+ src/Relay/Pagination/Hasql/KeyCodec.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE BlockArguments #-}++-- | Typed codecs for sort-key values: how one column's value converts to and+-- from the cursor's 'KeyValue' representation, and how it travels as a typed+-- SQL parameter. The five built-ins cover the v1 column types; all of them+-- reject 'KvNull' — sort-key columns must be @NOT NULL@ in v1.+module Relay.Pagination.Hasql.KeyCodec+  ( KeyCodec (..),+    int8Key,+    textKey,+    uuidKey,+    timestamptzKey,+    boolKey,++    -- * Timestamp conversions+    utcTimeToMicros,+    microsToUtcTime,+  )+where++import Data.Int (Int64)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.Time.Clock (nominalDiffTimeToSeconds, secondsToNominalDiffTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Data.UUID (UUID)+import Hasql.Encoders qualified as Encoders+import Relay.Pagination (CursorError (..), KeyValue (..))++-- | How one sort-key value type moves between a decoded row, the cursor's+-- 'KeyValue' payload, and a typed SQL parameter. 'codecTag' participates in+-- the sort-spec fingerprint, so changing a column's codec invalidates+-- outstanding cursors at decode time.+data KeyCodec v = KeyCodec+  { toKeyValue :: v -> KeyValue,+    fromKeyValue :: KeyValue -> Either CursorError v,+    paramEncoder :: !(Encoders.Value v),+    codecTag :: !Text+  }++mismatch :: Text -> KeyValue -> CursorError+mismatch tag kv = KeyTypeMismatch {expectedTag = tag, actualValue = kv}++-- | @int8@ / 'Int64' sort keys ('KvInt').+int8Key :: KeyCodec Int64+int8Key =+  KeyCodec+    { toKeyValue = KvInt,+      fromKeyValue = \case+        KvInt n -> Right n+        other -> Left (mismatch "int8" other),+      paramEncoder = Encoders.int8,+      codecTag = "int8"+    }++-- | @text@ / 'Text' sort keys ('KvText').+textKey :: KeyCodec Text+textKey =+  KeyCodec+    { toKeyValue = KvText,+      fromKeyValue = \case+        KvText t -> Right t+        other -> Left (mismatch "text" other),+      paramEncoder = Encoders.text,+      codecTag = "text"+    }++-- | @uuid@ / 'UUID' sort keys ('KvUuid').+uuidKey :: KeyCodec UUID+uuidKey =+  KeyCodec+    { toKeyValue = KvUuid,+      fromKeyValue = \case+        KvUuid u -> Right u+        other -> Left (mismatch "uuid" other),+      paramEncoder = Encoders.uuid,+      codecTag = "uuid"+    }++-- | @bool@ / 'Bool' sort keys ('KvBool').+boolKey :: KeyCodec Bool+boolKey =+  KeyCodec+    { toKeyValue = KvBool,+      fromKeyValue = \case+        KvBool b -> Right b+        other -> Left (mismatch "bool" other),+      paramEncoder = Encoders.bool,+      codecTag = "bool"+    }++-- | @timestamptz@ / 'UTCTime' sort keys ('KvTimestampMicros').+--+-- PostgreSQL @timestamptz@ has exactly microsecond resolution, and hasql 1.10+-- encodes\/decodes it over the binary integer-microseconds wire format, so for+-- every value read from the database the DB → Haskell → cursor → parameter+-- round-trip is /exact/ — no floating point is involved anywhere. 'round'+-- (banker's rounding on the fixed-point 'Data.Fixed.Pico' seconds) only+-- engages for hand-constructed sub-microsecond 'UTCTime's, which are+-- normalized to the nearest microsecond.+timestamptzKey :: KeyCodec UTCTime+timestamptzKey =+  KeyCodec+    { toKeyValue = KvTimestampMicros . utcTimeToMicros,+      fromKeyValue = \case+        KvTimestampMicros us -> Right (microsToUtcTime us)+        other -> Left (mismatch "timestamptz" other),+      paramEncoder = Encoders.timestamptz,+      codecTag = "timestamptz"+    }++-- | Whole microseconds since the Unix epoch. Exact for every microsecond-+-- resolution 'UTCTime' (i.e. everything PostgreSQL can produce); rounds+-- sub-microsecond remainders.+utcTimeToMicros :: UTCTime -> Int64+utcTimeToMicros t = round (nominalDiffTimeToSeconds (utcTimeToPOSIXSeconds t) * 1_000_000)++-- | Inverse of 'utcTimeToMicros'; exact ('Data.Fixed.Pico' is fixed-point and+-- 10^6 divides 10^12).+microsToUtcTime :: Int64 -> UTCTime+microsToUtcTime us =+  posixSecondsToUTCTime (secondsToNominalDiffTime (fromIntegral us / 1_000_000))
+ src/Relay/Pagination/Hasql/SortSpec.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ExistentialQuantification #-}++-- | Sort specifications: the ordered list of sort-key columns that defines an+-- endpoint's canonical order, and the 32-bit fingerprint that ties cursors to+-- one specification.+module Relay.Pagination.Hasql.SortSpec+  ( SortDirection (..),+    KeyColumn (..),+    SortSpec (..),+    sortSpecFingerprint,+    fingerprintBytes,+  )+where++import Data.Bits (xor)+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as LBS+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Data.Text.Encoding qualified as Text+import Data.Word (Word32)+import Relay.Pagination.Hasql.KeyCodec (KeyCodec (..))++-- | Sort direction of one column, as declared (paging backward flips the+-- effective direction internally; the declaration never changes).+data SortDirection = Asc | Desc+  deriving stock (Eq, Show)++-- | One sort-key column. The @forall v.@ hides the column's value type so+-- heterogeneous columns live in one list; pattern-match with explicit field+-- puns (e.g. @KeyColumn {extract, codec}@) to bring 'extract' and 'codec'+-- into scope at a shared, opaque @v@.+--+-- __Warning:__ 'columnExpr' is spliced /verbatim/ into generated SQL. It is a+-- developer-authored, trusted SQL expression over the base query's output+-- columns — exactly as trusted as any hand-written query text. It must+-- __never contain user input__; doing so is SQL injection. All /values/+-- (cursor keys, the LIMIT) travel as typed parameters and are never+-- interpolated into SQL text.+data KeyColumn row = forall v. KeyColumn+  { columnExpr :: !Text,+    sortDir :: !SortDirection,+    extract :: row -> v,+    codec :: !(KeyCodec v)+  }++-- | An endpoint's canonical sort order: columns in significance order.+--+-- __The last column must be unique per row__ (and in v1 every column must be+-- @NOT NULL@). Uniqueness of the tie-breaker is what makes the order total,+-- which is what makes keyset pagination skip-free and duplicate-free; the+-- library cannot verify it — the conformance suite is how a consumer proves+-- their spec obeys it.+newtype SortSpec row = SortSpec (NonEmpty (KeyColumn row))++-- | 32-bit FNV-1a over 'fingerprintBytes'. This is the value stamped into+-- every minted cursor and demanded of every decoded one: change a column+-- expression, direction, or codec and outstanding cursors are rejected at+-- decode time instead of being silently misread.+sortSpecFingerprint :: SortSpec row -> Word32+sortSpecFingerprint = fnv1a . fingerprintBytes++-- | The fingerprint's exact byte serialization (pinned by golden tests): one+-- salt byte @0x01@ (cursor format version), then per column the UTF-8 bytes+-- of 'columnExpr', @0x00@, one direction byte (@0x00@ Asc, @0x01@ Desc),+-- @0x00@, the UTF-8 bytes of the codec tag, @0x00@.+fingerprintBytes :: SortSpec row -> ByteString+fingerprintBytes (SortSpec cols) =+  LBS.toStrict . Builder.toLazyByteString $+    Builder.word8 0x01 <> foldMap columnBytes cols+  where+    columnBytes KeyColumn {columnExpr, sortDir, codec = KeyCodec {codecTag}} =+      Builder.byteString (Text.encodeUtf8 columnExpr)+        <> Builder.word8 0x00+        <> Builder.word8 (directionByte sortDir)+        <> Builder.word8 0x00+        <> Builder.byteString (Text.encodeUtf8 codecTag)+        <> Builder.word8 0x00+    directionByte = \case+      Asc -> 0x00+      Desc -> 0x01++fnv1a :: ByteString -> Word32+fnv1a = ByteString.foldl' step 2166136261+  where+    step h b = (h `xor` fromIntegral b) * 16777619
+ src/Relay/Pagination/Hasql/Sql.hs view
@@ -0,0 +1,124 @@+-- | Keyset SQL generation. Given a base query (no @ORDER BY@, no @LIMIT@),+-- a sort specification, and a validated page request, produce the wrapped,+-- fully parameterized snippet:+--+-- > SELECT * FROM (<base>) AS rp_base [WHERE <keyset predicate>]+-- >   ORDER BY <order clause> LIMIT <pageSize+1>+--+-- All cursor values and the LIMIT travel as typed SQL parameters; only the+-- developer-authored column expressions are spliced as text. The generator+-- deliberately emits one-line SQL with single spaces so golden files stay+-- byte-stable.+module Relay.Pagination.Hasql.Sql+  ( paginateSnippet,+  )+where++import Control.Monad (zipWithM)+import Data.Int (Int64)+import Data.List qualified as List+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import Hasql.DynamicStatements.Snippet (Snippet)+import Hasql.DynamicStatements.Snippet qualified as Snippet+import Hasql.Encoders qualified as Encoders+import Relay.Pagination+  ( Cursor,+    CursorError (..),+    CursorPayload (..),+    Direction (..),+    KeyValue,+    PageRequest (..),+    decodeCursor,+  )+import Relay.Pagination.Hasql.KeyCodec (KeyCodec (..))+import Relay.Pagination.Hasql.SortSpec (KeyColumn (..), SortDirection (..), SortSpec (..), sortSpecFingerprint)++-- | Wrap a base query with the keyset predicate, order clause, and+-- @LIMIT pageSize+1@ for the given page request.+--+-- The base query must be a @SELECT@ with any filters and parameters of its+-- own but __no @ORDER BY@ and no @LIMIT@__ (an inner @ORDER BY@ would be+-- discarded by the wrapping subquery anyway).+--+-- Returns 'Left' when the request's cursor does not decode against this sort+-- specification (wrong fingerprint, key count, or key types) — surfaced+-- before any SQL runs, so handlers can map it to HTTP 400.+paginateSnippet :: SortSpec row -> PageRequest -> Snippet -> Either CursorError Snippet+paginateSnippet spec@(SortSpec cols) req base = do+  whereClause <- case cursor req of+    Nothing -> Right mempty+    Just c -> do+      params <- decodeAgainst spec c+      Right (Snippet.sql " WHERE " <> predicate (zip ordered params))+  Right $+    Snippet.sql "SELECT * FROM ("+      <> base+      <> Snippet.sql ") AS rp_base"+      <> whereClause+      <> Snippet.sql " ORDER BY "+      <> orderBy ordered+      <> Snippet.sql " LIMIT "+      <> limitParam+  where+    ordered =+      [ (columnExpr, effectiveDir (direction req) sortDir)+      | KeyColumn {columnExpr, sortDir} <- NonEmpty.toList cols+      ]+    limitParam =+      Snippet.encoderAndParam+        (Encoders.nonNullable Encoders.int8)+        (fromIntegral (pageSize req + 1) :: Int64)++-- | Paging backward walks the same total order from the other end: every+-- column's direction (and, downstream, every comparator) flips.+effectiveDir :: Direction -> SortDirection -> SortDirection+effectiveDir Forward d = d+effectiveDir Backward Asc = Desc+effectiveDir Backward Desc = Asc++-- | Decode and validate a cursor against the spec, producing one pre-encoded+-- parameter snippet per column (built inside the existential scope where the+-- column's value type is known).+decodeAgainst :: SortSpec row -> Cursor -> Either CursorError [Snippet]+decodeAgainst spec@(SortSpec cols) c = do+  payload <- decodeCursor (sortSpecFingerprint spec) c+  let colList = NonEmpty.toList cols+      ks = keys payload+  if length ks /= length colList+    then Left KeyCountMismatch {expectedCount = length colList, actualCount = length ks}+    else zipWithM columnParam colList ks+  where+    columnParam :: KeyColumn row -> KeyValue -> Either CursorError Snippet+    columnParam KeyColumn {codec = KeyCodec {fromKeyValue, paramEncoder}} kv = do+      v <- fromKeyValue kv+      Right (Snippet.encoderAndParam (Encoders.nonNullable paramEncoder) v)++-- | The expanded lexicographic keyset predicate: an OR over prefix arms,+-- arm i asserting "equal on the first i-1 keys and strictly past the cursor+-- on key i". Correct for mixed Asc/Desc specs, unlike row-value comparison.+-- Parameter snippets recur across arms; each occurrence allocates a fresh+-- placeholder encoding the same value.+predicate :: [((Text, SortDirection), Snippet)] -> Snippet+predicate cols = joinWith " OR " [arm (take i cols) | i <- [1 .. length cols]]+  where+    arm prefixAndPivot =+      let eqs = init prefixAndPivot+          ((expr, dir), p) = last prefixAndPivot+          equalities = [Snippet.sql e <> Snippet.sql " = " <> q | ((e, _), q) <- eqs]+          pivot = Snippet.sql expr <> Snippet.sql (comparator dir) <> p+       in Snippet.sql "(" <> joinWith " AND " (equalities <> [pivot]) <> Snippet.sql ")"+    comparator = \case+      Asc -> " > "+      Desc -> " < "++orderBy :: [(Text, SortDirection)] -> Snippet+orderBy = joinWith ", " . map one+  where+    one (expr, dir) = Snippet.sql expr <> Snippet.sql (directionSql dir)+    directionSql = \case+      Asc -> " ASC"+      Desc -> " DESC"++joinWith :: Text -> [Snippet] -> Snippet+joinWith sep = mconcat . List.intersperse (Snippet.sql sep)
+ test/Main.hs view
@@ -0,0 +1,20 @@+module Main (main) where++import Test.Codec qualified+import Test.Connection qualified+import Test.Fingerprint qualified+import Test.Integration qualified+import Test.SqlGolden qualified+import Test.Tasty++main :: IO ()+main =+  defaultMain $+    testGroup+      "relay-pagination-hasql"+      [ Test.Codec.tests,+        Test.Fingerprint.tests,+        Test.SqlGolden.tests,+        Test.Connection.tests,+        Test.Integration.tests+      ]
+ test/Test/Codec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BlockArguments #-}++-- | Round-trip and rejection tests for the built-in key codecs.+module Test.Codec (tests) where++import Data.Int (Int64)+import Data.Text qualified as Text+import Data.UUID qualified as UUID+import Relay.Pagination (CursorError (..), KeyValue (..))+import Relay.Pagination.Hasql.KeyCodec+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++tests :: TestTree+tests =+  testGroup+    "codecs"+    [ testProperty "int8 round-trip" $+        \(n :: Int64) -> fromKeyValue int8Key (toKeyValue int8Key n) === Right n,+      testProperty "text round-trip" $+        \(s :: String) ->+          let t = Text.pack s+           in fromKeyValue textKey (toKeyValue textKey t) === Right t,+      testProperty "uuid round-trip" $+        forAll arbitraryUuid \u ->+          fromKeyValue uuidKey (toKeyValue uuidKey u) === Right u,+      testProperty "bool round-trip" $+        \(b :: Bool) -> fromKeyValue boolKey (toKeyValue boolKey b) === Right b,+      testProperty "timestamptz microsecond round-trip" $+        forAll arbitraryMicros \us ->+          let t = microsToUtcTime us+           in utcTimeToMicros t === us+                .&&. fromKeyValue timestamptzKey (toKeyValue timestamptzKey t) === Right t,+      testCase "rejects wrong KeyValue constructors incl. KvNull" do+        rejects int8Key "int8" [KvText "x", KvUuid UUID.nil, KvTimestampMicros 0, KvBool True, KvNull]+        rejects textKey "text" [KvInt 0, KvUuid UUID.nil, KvTimestampMicros 0, KvBool True, KvNull]+        rejects uuidKey "uuid" [KvInt 0, KvText "x", KvTimestampMicros 0, KvBool True, KvNull]+        rejects timestamptzKey "timestamptz" [KvInt 0, KvText "x", KvUuid UUID.nil, KvBool True, KvNull]+        rejects boolKey "bool" [KvInt 0, KvText "x", KvUuid UUID.nil, KvTimestampMicros 0, KvNull]+    ]++rejects :: (Eq v, Show v) => KeyCodec v -> Text.Text -> [KeyValue] -> Assertion+rejects codec tag wrongValues =+  mapM_+    ( \kv ->+        fromKeyValue codec kv+          @?= Left KeyTypeMismatch {expectedTag = tag, actualValue = kv}+    )+    wrongValues++arbitraryUuid :: Gen UUID.UUID+arbitraryUuid = UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++-- | Whole-microsecond timestamps within about ±1,100 years of the epoch,+-- comfortably covering PostgreSQL-realistic dates.+arbitraryMicros :: Gen Int64+arbitraryMicros = choose (-(2 ^ (55 :: Int)), 2 ^ (55 :: Int))
+ test/Test/Connection.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE BlockArguments #-}++-- | Pure unit tests of connection assembly: the probe row, the+-- exact-boundary hasNextPage regression, backward reversal to canonical+-- order, empty pages, and cursor minting round-trips.+module Test.Connection (tests) where++import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (isNothing, listToMaybe)+import Data.Text (Text)+import Data.Time (UTCTime)+import Relay.Pagination+  ( Connection (..),+    Cursor,+    CursorPayload (..),+    Direction (..),+    Edge (..),+    KeyValue (..),+    PageInfo (..),+    PageRequest (..),+    decodeCursor,+  )+import Relay.Pagination.Hasql.Connection (mkConnection)+import Relay.Pagination.Hasql.KeyCodec (microsToUtcTime, textKey, timestamptzKey, utcTimeToMicros)+import Relay.Pagination.Hasql.SortSpec (KeyColumn (..), SortDirection (..), SortSpec (..), sortSpecFingerprint)+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "connection"+    [ testCase "probe row: 4 fetched at pageSize 3 => 3 edges, hasNextPage" do+        let conn = mk Forward Nothing [a, b, c, d]+        nodesOf conn @?= [a, b, c]+        hasNextPage (pageInfo conn) @?= True+        hasPreviousPage (pageInfo conn) @?= False,+      testCase "exact boundary: 3 fetched at pageSize 3 with cursor => hasNextPage False" do+        -- The reference implementation's `length == pageSize` heuristic+        -- reports a phantom next page here; the probe does not.+        let conn = mk Forward (Just someCursor) [a, b, c]+        nodesOf conn @?= [a, b, c]+        hasNextPage (pageInfo conn) @?= False+        hasPreviousPage (pageInfo conn) @?= True,+      testCase "forward without cursor: hasPreviousPage False" do+        let conn = mk Forward Nothing [a, b, c]+        hasPreviousPage (pageInfo conn) @?= False,+      testCase "empty page: no edges, null cursors, flags per table" do+        let conn = mk Forward (Just someCursor) []+        nodesOf conn @?= []+        hasNextPage (pageInfo conn) @?= False+        hasPreviousPage (pageInfo conn) @?= True+        assertBool "startCursor is Nothing" (isNothing (startCursor (pageInfo conn)))+        assertBool "endCursor is Nothing" (isNothing (endCursor (pageInfo conn))),+      testCase "backward: flipped rows reversed to canonical order" do+        -- Backward SQL walks the flipped order: fetching the last 3 of+        -- [a,b,c,d] arrives as d,c,b (+ probe a). Edges must come out b,c,d.+        let conn = mk Backward Nothing [d, c, b, a]+        nodesOf conn @?= [b, c, d]+        hasPreviousPage (pageInfo conn) @?= True+        hasNextPage (pageInfo conn) @?= False,+      testCase "backward with cursor: hasNextPage True" do+        let conn = mk Backward (Just someCursor) [d, c, b, a]+        hasNextPage (pageInfo conn) @?= True,+      testCase "minted cursors decode back to the row's exact key values" do+        let conn = mk Forward Nothing [a, b, c, d]+            fp = sortSpecFingerprint spec+        mapM_+          ( \(Edge {node = Item i t, cursor = cur}) ->+              decodeCursor fp cur+                @?= Right (CursorPayload 1 fp [KvTimestampMicros (utcTimeToMicros t), KvText i])+          )+          (edges conn),+      testCase "start/end cursors are the first/last edge's" do+        let conn = mk Forward Nothing [a, b, c, d]+            cursorsOf = [cur | Edge {cursor = cur} <- edges conn]+        length cursorsOf @?= 3+        startCursor (pageInfo conn) @?= listToMaybe cursorsOf+        endCursor (pageInfo conn) @?= listToMaybe (reverse cursorsOf)+    ]+  where+    mk dir mc rows =+      mkConnection spec PageRequest {pageSize = 3, direction = dir, cursor = mc} rows+    nodesOf conn = [n | Edge {node = n} <- edges conn]++data Item = Item !Text !UTCTime+  deriving stock (Eq, Show)++-- | Canonical order under the spec (updated_at DESC, member_id ASC):+-- a (newest) then b, c (timestamp tie broken by id), then d (oldest).+a, b, c, d :: Item+a = item "i01" 4000000+b = item "i02" 3000000+c = item "i03" 3000000+d = item "i04" 1000000++item :: Text -> Int64 -> Item+item i us = Item i (microsToUtcTime us)++spec :: SortSpec Item+spec =+  SortSpec+    ( KeyColumn "updated_at" Desc (\(Item _ t) -> t) timestamptzKey+        :| [KeyColumn "member_id" Asc (\(Item i _) -> i) textKey]+    )++someCursor :: Cursor+someCursor = case edges one of+  Edge {cursor = cur} : _ -> cur+  [] -> error "someCursor: no edges"+  where+    one =+      mkConnection+        spec+        PageRequest {pageSize = 1, direction = Forward, cursor = Nothing}+        [a]
+ test/Test/Fingerprint.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BlockArguments #-}++-- | Golden and sensitivity tests for the sort-spec fingerprint. The golden+-- numbers are pinned by the ExecPlan; if one fails, the serialization has+-- deviated from the plan — fix the code, not the test.+module Test.Fingerprint (tests) where++import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Relay.Pagination.Hasql.KeyCodec+import Relay.Pagination.Hasql.SortSpec+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "fingerprint"+    [ testCase "members-like spec == 3101933007" $+        sortSpecFingerprint membersSpec @?= 3101933007,+      testCase "first column Asc == 2542715508" $+        sortSpecFingerprint membersAscSpec @?= 2542715508,+      testCase "second codec tag int8 == 3017546679" $+        sortSpecFingerprint membersInt8Spec @?= 3017546679,+      testCase "single-column property spec == 3884902590" $+        sortSpecFingerprint propertySpec @?= 3884902590,+      testCase "expression/direction/tag sensitivity" do+        let fps =+              [ sortSpecFingerprint membersSpec,+                sortSpecFingerprint membersAscSpec,+                sortSpecFingerprint membersInt8Spec,+                sortSpecFingerprint membersRenamedSpec+              ]+        assertBool "all fingerprints distinct" (allDistinct fps)+    ]+  where+    allDistinct xs = and [a /= b | (i, a) <- zip [0 :: Int ..] xs, (j, b) <- zip [0 ..] xs, i < j]++-- | Stand-in row for fingerprint-only specs: extraction is never evaluated.+type FRow = (Text, Int64)++membersSpec :: SortSpec FRow+membersSpec =+  SortSpec+    ( KeyColumn "updated_at" Desc (const (microsToUtcTime 0)) timestamptzKey+        :| [KeyColumn "member_id" Asc fst textKey]+    )++membersAscSpec :: SortSpec FRow+membersAscSpec =+  SortSpec+    ( KeyColumn "updated_at" Asc (const (microsToUtcTime 0)) timestamptzKey+        :| [KeyColumn "member_id" Asc fst textKey]+    )++membersInt8Spec :: SortSpec FRow+membersInt8Spec =+  SortSpec+    ( KeyColumn "updated_at" Desc (const (microsToUtcTime 0)) timestamptzKey+        :| [KeyColumn "member_id" Asc snd int8Key]+    )++membersRenamedSpec :: SortSpec FRow+membersRenamedSpec =+  SortSpec+    ( KeyColumn "modified_at" Desc (const (microsToUtcTime 0)) timestamptzKey+        :| [KeyColumn "member_id" Asc fst textKey]+    )++propertySpec :: SortSpec FRow+propertySpec = SortSpec (KeyColumn "property_id" Asc fst textKey :| [])
+ test/Test/Integration.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE BlockArguments #-}++-- | Integration tests against a real ephemeral PostgreSQL: adversarial+-- 25-row fixture (ten-way timestamp ties, a microsecond-adjacent pair, a+-- final page that is exactly full), walked forward and backward.+module Test.Integration (tests, demo) where++import Control.Monad (forM_)+import Data.Int (Int64)+import Data.List (sortBy)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (isNothing)+import Data.Ord (Down (..), comparing)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import EphemeralPg qualified as Pg+import Hasql.Connection qualified as Connection+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 Relay.Pagination+  ( Connection (..),+    CursorPayload (..),+    Direction (..),+    Edge (..),+    KeyValue (..),+    PageInfo (..),+    PageRequest (..),+    decodeCursor,+  )+import Relay.Pagination.Hasql+  ( KeyColumn (..),+    SortDirection (..),+    SortSpec (..),+    mintCursor,+    paginate,+    sortSpecFingerprint,+    textKey,+    timestamptzKey,+  )+import Relay.Pagination.Hasql.KeyCodec (microsToUtcTime)+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests = withResource acquire release \getDb ->+  testGroup+    "integration (ephemeral-pg)"+    [ testCase "forward walk: 5 pages, no skip/dup, flags per table" do+        (_, conn) <- getDb+        pages <- walk conn Forward+        length pages @?= 5+        concatMap nodesOf pages @?= canonical+        map (hasNextPage . pageInfo) pages @?= [True, True, True, True, False]+        map (hasPreviousPage . pageInfo) pages @?= [False, True, True, True, True],+      testCase "fetch beyond the end" do+        (_, conn) <- getDb+        page <-+          fetch conn PageRequest {pageSize = 5, direction = Forward, cursor = Just (mintCursor spec (last canonical))}+        nodesOf page @?= []+        hasNextPage (pageInfo page) @?= False+        hasPreviousPage (pageInfo page) @?= True+        assertBool "startCursor Nothing" (isNothing (startCursor (pageInfo page)))+        assertBool "endCursor Nothing" (isNothing (endCursor (pageInfo page))),+      testCase "backward walk mirrors forward pages" do+        (_, conn) <- getDb+        fpages <- walk conn Forward+        bpages <- walk conn Backward+        length bpages @?= 5+        map edges (reverse bpages) @?= map edges fpages+        map (hasPreviousPage . pageInfo) bpages @?= [True, True, True, True, False]+        map (hasNextPage . pageInfo) bpages @?= [False, True, True, True, True],+      testCase "microsecond-adjacent boundary at pageSize 1" do+        (_, conn) <- getDb+        let boundaryBase =+              Snippet.sql "SELECT item_id, updated_at FROM items WHERE item_id IN ('i21', 'i22')"+        p1 <- fetchWith conn boundaryBase PageRequest {pageSize = 1, direction = Forward, cursor = Nothing}+        map fst (nodesOf p1) @?= ["i22"]+        hasNextPage (pageInfo p1) @?= True+        p2 <- fetchWith conn boundaryBase PageRequest {pageSize = 1, direction = Forward, cursor = endCursor (pageInfo p1)}+        map fst (nodesOf p2) @?= ["i21"]+        hasNextPage (pageInfo p2) @?= False,+      testCase "cursor-parameter exactness (25 rows)" do+        (_, conn) <- getDb+        forM_ seedRows \row -> do+          payload <-+            either (fail . show) pure $+              decodeCursor (sortSpecFingerprint spec) (mintCursor spec row)+          (t, i) <- case keys payload of+            [KvTimestampMicros us, KvText i] -> pure (microsToUtcTime us, i)+            other -> fail ("unexpected cursor keys: " <> show other)+          n <- run conn (Session.statement () (countStatement t i))+          n @?= 1+    ]++-- * Engine wiring++spec :: SortSpec (Text, UTCTime)+spec =+  SortSpec+    ( KeyColumn "updated_at" Desc snd timestamptzKey+        :| [KeyColumn "item_id" Asc fst textKey]+    )++itemsBase :: Snippet+itemsBase = Snippet.sql "SELECT item_id, updated_at FROM items"++rowDecoder :: Decoders.Row (Text, UTCTime)+rowDecoder =+  (,)+    <$> Decoders.column (Decoders.nonNullable Decoders.text)+    <*> Decoders.column (Decoders.nonNullable Decoders.timestamptz)++fetch :: Connection.Connection -> PageRequest -> IO (Connection (Text, UTCTime))+fetch conn = fetchWith conn itemsBase++fetchWith :: Connection.Connection -> Snippet -> PageRequest -> IO (Connection (Text, UTCTime))+fetchWith conn base req =+  case paginate spec req base rowDecoder of+    Left err -> fail ("cursor rejected: " <> show err)+    Right stmt -> run conn (Session.statement () stmt)++-- | Walk every page in the given direction, following endCursor (Forward)+-- or startCursor (Backward). Bounded so an engine bug cannot loop forever.+walk :: Connection.Connection -> Direction -> IO [Connection (Text, UTCTime)]+walk conn dir = go (10 :: Int) Nothing+  where+    go 0 _ = fail "walk exceeded 10 pages: engine is looping"+    go fuel cur = do+      page <- fetch conn PageRequest {pageSize = 5, direction = dir, cursor = cur}+      let info = pageInfo page+      case dir of+        Forward+          | hasNextPage info -> (page :) <$> go (fuel - 1) (endCursor info)+          | otherwise -> pure [page]+        Backward+          | hasPreviousPage info -> (page :) <$> go (fuel - 1) (startCursor info)+          | otherwise -> pure [page]++nodesOf :: Connection (Text, UTCTime) -> [(Text, UTCTime)]+nodesOf page = [n | Edge {node = n} <- edges page]++countStatement :: UTCTime -> Text -> Statement () Int64+countStatement t i =+  Snippet.toStatement+    ( Snippet.sql "SELECT count(*) FROM items WHERE updated_at = "+        <> Snippet.encoderAndParam (Encoders.nonNullable Encoders.timestamptz) t+        <> Snippet.sql " AND item_id = "+        <> Snippet.encoderAndParam (Encoders.nonNullable Encoders.text) i+    )+    (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))++-- * Fixture++-- | 25 rows: i01-i10 share one timestamp (ten-way tie), i11-i20 share+-- another, i21/i22 are one microsecond apart, i23-i25 sit at distinct+-- earlier whole seconds. 25 rows at pageSize 5 make the final page exactly+-- full — the reference implementation's length == pageSize heuristic would+-- report a phantom next page there.+seed :: [(Text, Int64)]+seed =+  [(itemName n, 1767323045123456) | n <- [1 .. 10]]+    <> [(itemName n, 1767323044123456) | n <- [11 .. 20]]+    <> [ ("i21", 1767323043000001),+         ("i22", 1767323043000002),+         ("i23", 1767323042000000),+         ("i24", 1767323041000000),+         ("i25", 1767323040000000)+       ]++itemName :: Int -> Text+itemName n = "i" <> (if n < 10 then "0" else "") <> Text.pack (show n)++seedRows :: [(Text, UTCTime)]+seedRows = [(i, microsToUtcTime us) | (i, us) <- seed]++-- | The canonical order under the spec: updated_at DESC, item_id ASC.+canonical :: [(Text, UTCTime)]+canonical = sortBy (comparing (Down . snd) <> comparing fst) seedRows++-- * Database lifecycle++acquire :: IO (Pg.Database, Connection.Connection)+acquire = do+  db <-+    either (fail . Text.unpack . Pg.renderStartError) pure+      =<< Pg.startCached Pg.defaultConfig Pg.defaultCacheConfig+  conn <- either (fail . show) pure =<< Connection.acquire (Pg.connectionSettings db)+  run conn createSchema+  run conn (mapM_ insertRow seedRows)+  pure (db, conn)++release :: (Pg.Database, Connection.Connection) -> IO ()+release (db, conn) = Connection.release conn *> Pg.stop db++run :: Connection.Connection -> Session.Session a -> IO a+run conn session = either (fail . show) pure =<< Connection.use conn session++createSchema :: Session.Session ()+createSchema =+  Session.script+    """+    CREATE TABLE items (+      item_id text PRIMARY KEY,+      updated_at timestamptz NOT NULL+    );+    """++insertRow :: (Text, UTCTime) -> Session.Session ()+insertRow (i, t) =+  Session.statement () $+    Snippet.toStatement+      ( Snippet.sql "INSERT INTO items (item_id, updated_at) VALUES ("+          <> Snippet.encoderAndParam (Encoders.nonNullable Encoders.text) i+          <> Snippet.sql ", "+          <> Snippet.encoderAndParam (Encoders.nonNullable Encoders.timestamptz) t+          <> Snippet.sql ")"+      )+      Decoders.noResult++-- * Demo++-- | Runnable from GHCi: seeds the fixture into a fresh throwaway database+-- and prints two pages in each direction. See the ExecPlan's Validation+-- section for the expected transcript.+demo :: IO ()+demo = do+  result <- Pg.with \db -> do+    conn <- either (fail . show) pure =<< Connection.acquire (Pg.connectionSettings db)+    run conn createSchema+    run conn (mapM_ insertRow seedRows)+    p1 <- fetch conn PageRequest {pageSize = 5, direction = Forward, cursor = Nothing}+    printPage "forward page 1: " p1+    p2 <- fetch conn PageRequest {pageSize = 5, direction = Forward, cursor = endCursor (pageInfo p1)}+    printPage "forward page 2: " p2+    b1 <- fetch conn PageRequest {pageSize = 5, direction = Backward, cursor = Nothing}+    printPage "backward page 1:" b1+    b2 <- fetch conn PageRequest {pageSize = 5, direction = Backward, cursor = startCursor (pageInfo b1)}+    printPage "backward page 2:" b2+    Connection.release conn+  either (fail . Text.unpack . Pg.renderStartError) pure result++printPage :: String -> Connection (Text, UTCTime) -> IO ()+printPage label page =+  putStrLn+    ( label+        <> " "+        <> unwords [Text.unpack i | (i, _) <- nodesOf page]+        <> "   hasNext="+        <> show (hasNextPage (pageInfo page))+        <> " hasPrev="+        <> show (hasPreviousPage (pageInfo page))+    )
+ test/Test/SqlGolden.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BlockArguments #-}++-- | Golden tests pinning the generated SQL (rendered with Snippet.toSql, so+-- the files hold exactly the text sent to the server), plus the cursor+-- error paths.+module Test.SqlGolden (tests) where++import Data.ByteString.Lazy qualified as LBS+import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Data.Text.Encoding qualified as Text+import Data.Time (UTCTime)+import Data.Word (Word32)+import Hasql.DynamicStatements.Snippet (Snippet)+import Hasql.DynamicStatements.Snippet qualified as Snippet+import Hasql.Encoders qualified as Encoders+import Relay.Pagination+  ( Cursor,+    CursorError (..),+    CursorPayload (..),+    Direction (..),+    KeyValue (..),+    PageRequest (..),+    encodeCursor,+  )+import Relay.Pagination.Hasql.Connection (mintCursor)+import Relay.Pagination.Hasql.KeyCodec (microsToUtcTime, textKey, timestamptzKey)+import Relay.Pagination.Hasql.SortSpec (KeyColumn (..), SortDirection (..), SortSpec (..), sortSpecFingerprint)+import Relay.Pagination.Hasql.Sql (paginateSnippet)+import Test.Tasty+import Test.Tasty.Golden (goldenVsString)+import Test.Tasty.HUnit++tests :: TestTree+tests =+  testGroup+    "sql golden"+    [ golden "members-forward-no-cursor" (page Forward Nothing) membersBase,+      golden "members-forward-cursor" (page Forward (Just membersCursor)) membersBase,+      golden "members-backward-no-cursor" (page Backward Nothing) membersBase,+      golden "members-backward-cursor" (page Backward (Just membersCursor)) membersBase,+      goldenWith+        propertySpec+        "property-forward-cursor"+        (PageRequest {pageSize = 5, direction = Forward, cursor = Just propertyCursor})+        propertyBase,+      golden "members-forward-cursor-parameterized-base" (page Forward (Just membersCursor)) parameterizedBase,+      errorPathTests+    ]+  where+    golden = goldenWith memberishSpec+    goldenWith spec name req base =+      goldenVsString name ("test/golden/" <> name <> ".sql") do+        either (assertFailure . show) (pure . renderSql) (paginateSnippet spec req base)+    renderSql = LBS.fromStrict . Text.encodeUtf8 . Snippet.toSql+    page dir mc = PageRequest {pageSize = 5, direction = dir, cursor = mc}++errorPathTests :: TestTree+errorPathTests =+  testGroup+    "cursor error paths"+    [ testCase "foreign fingerprint is rejected" $+        run (encodeCursor (CursorPayload 1 12345 [KvTimestampMicros ts, KvText "i05"]))+          @?= Left FingerprintMismatch {expected = memberishFp, actual = 12345},+      testCase "wrong key count yields arity error" $+        run (encodeCursor (CursorPayload 1 memberishFp [KvText "i05"]))+          @?= Left KeyCountMismatch {expectedCount = 2, actualCount = 1},+      testCase "wrong key type yields type-mismatch error" $+        run (encodeCursor (CursorPayload 1 memberishFp [KvInt 42, KvText "i05"]))+          @?= Left KeyTypeMismatch {expectedTag = "timestamptz", actualValue = KvInt 42}+    ]+  where+    run c =+      fmap+        (const ())+        ( paginateSnippet+            memberishSpec+            PageRequest {pageSize = 5, direction = Forward, cursor = Just c}+            membersBase+        )++-- | Stand-in for a decoded members row.+data Item = Item+  { itemId :: !Text,+    itemUpdatedAt :: !UTCTime+  }++memberishSpec :: SortSpec Item+memberishSpec =+  SortSpec+    ( KeyColumn "updated_at" Desc itemUpdatedAt timestamptzKey+        :| [KeyColumn "member_id" Asc itemId textKey]+    )++memberishFp :: Word32+memberishFp = sortSpecFingerprint memberishSpec++propertySpec :: SortSpec Text+propertySpec = SortSpec (KeyColumn "property_id" Asc id textKey :| [])++membersBase :: Snippet+membersBase = Snippet.sql "SELECT member_id, updated_at FROM members"++parameterizedBase :: Snippet+parameterizedBase =+  Snippet.sql "SELECT member_id, updated_at FROM members WHERE mls = "+    <> Snippet.encoderAndParam (Encoders.nonNullable Encoders.text) ("CRMLS" :: Text)++propertyBase :: Snippet+propertyBase = Snippet.sql "SELECT property_id FROM properties"++-- | 2026-01-02T03:04:05.123456Z as integer microseconds.+ts :: Int64+ts = 1767323045123456++-- | A real cursor minted off a fixture row (equivalent to+-- @encodeCursor (CursorPayload 1 fp [KvTimestampMicros ts, KvText "i05"])@).+membersCursor :: Cursor+membersCursor =+  mintCursor memberishSpec Item {itemId = "i05", itemUpdatedAt = microsToUtcTime ts}++propertyCursor :: Cursor+propertyCursor =+  encodeCursor (CursorPayload 1 (sortSpecFingerprint propertySpec) [KvText "p05"])