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 + +Versioning follows the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## 0.1.0.0 — 2026-07-16 + +Initial contents: + +- Relay connection wire types: `Connection`, `Edge`, `PageInfo`, with + hand-written, field-order-stable JSON instances. +- Versioned, fingerprinted opaque cursor codec (`Cursor`, `CursorPayload`, + `KeyValue`, `encodeCursor`, `decodeCursor`): unpadded base64url over compact + JSON, timestamps as exact integer microseconds, deliberately no float key + type. `FromHttpApiData`/`ToHttpApiData` instances for `Cursor`. +- Request validation (`PageConfig`, `PageRequest`, `mkPageRequest`): strict + `first`+`after` / `last`+`before` argument families, size bounds. 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.cabal b/relay-pagination.cabal new file mode 100644 --- /dev/null +++ b/relay-pagination.cabal @@ -0,0 +1,71 @@ +cabal-version: 3.0 +name: relay-pagination +version: 0.1.0.0 +synopsis: + Relay-style cursor pagination wire types and opaque cursor codec + +description: + Core wire types for Relay Cursor Connections-style pagination over REST: + the Connection/Edge/PageInfo response envelope with Relay-conventional JSON, + first/after/last/before request validation, and a versioned, fingerprinted, + base64url-encoded opaque cursor with an exact, golden-tested wire format. + +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: Nadeem Bitar +category: Web, Database +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 + Relay.Pagination.Connection + Relay.Pagination.Cursor + Relay.Pagination.Request + + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , base64-bytestring >=1.2 && <1.3 + , bytestring >=0.11 && <0.13 + , http-api-data >=0.6 && <0.7 + , text >=2.0 && <2.2 + , uuid-types >=1.0 && <1.1 + +test-suite relay-pagination-test + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + , aeson + , base + , http-api-data + , quickcheck-instances >=0.3 && <0.4 + , relay-pagination + , tasty >=1.4 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , tasty-quickcheck >=0.10 && <0.12 + , uuid-types diff --git a/src/Relay/Pagination.hs b/src/Relay/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination.hs @@ -0,0 +1,13 @@ +-- | Relay-style cursor pagination: wire types and the opaque cursor codec. +-- This facade re-exports the whole public API; the submodules exist for +-- focused imports. +module Relay.Pagination + ( module Relay.Pagination.Connection, + module Relay.Pagination.Cursor, + module Relay.Pagination.Request, + ) +where + +import Relay.Pagination.Connection +import Relay.Pagination.Cursor +import Relay.Pagination.Request diff --git a/src/Relay/Pagination/Connection.hs b/src/Relay/Pagination/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination/Connection.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE BlockArguments #-} + +-- | The Relay connection response envelope. JSON encoding follows the Relay +-- convention exactly: {"edges":[{"node":...,"cursor":"..."}],"pageInfo": +-- {"hasNextPage":...,"hasPreviousPage":...,"startCursor":...,"endCursor":...}} +-- with null cursors on empty pages. Encodings are hand-written with fixed +-- field order so tests can pin exact bytes. +module Relay.Pagination.Connection + ( Connection (..), + Edge (..), + PageInfo (..), + ) +where + +import Data.Aeson ((.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import GHC.Generics (Generic) +import Relay.Pagination.Cursor (Cursor) + +-- | One returned row ('node') plus the cursor that addresses its position. +data Edge a = Edge + { node :: !a, + cursor :: !Cursor + } + deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic) + +instance (Aeson.ToJSON a) => Aeson.ToJSON (Edge a) where + toJSON e = Aeson.object ["node" .= node e, "cursor" .= cursor e] + toEncoding e = Aeson.pairs ("node" .= node e <> "cursor" .= cursor e) + +instance (Aeson.FromJSON a) => Aeson.FromJSON (Edge a) where + parseJSON = Aeson.withObject "Edge" \o -> Edge <$> o .: "node" <*> o .: "cursor" + +-- | Relay pageInfo. 'startCursor' / 'endCursor' are the first/last edge's +-- cursors, or Nothing (JSON null) when the page is empty. +data PageInfo = PageInfo + { hasNextPage :: !Bool, + hasPreviousPage :: !Bool, + startCursor :: !(Maybe Cursor), + endCursor :: !(Maybe Cursor) + } + deriving stock (Eq, Show, Generic) + +instance Aeson.ToJSON PageInfo where + toJSON p = + Aeson.object + [ "hasNextPage" .= hasNextPage p, + "hasPreviousPage" .= hasPreviousPage p, + "startCursor" .= startCursor p, + "endCursor" .= endCursor p + ] + toEncoding p = + Aeson.pairs + ( "hasNextPage" .= hasNextPage p + <> "hasPreviousPage" .= hasPreviousPage p + <> "startCursor" .= startCursor p + <> "endCursor" .= endCursor p + ) + +instance Aeson.FromJSON PageInfo where + parseJSON = Aeson.withObject "PageInfo" \o -> + PageInfo + <$> o .: "hasNextPage" + <*> o .: "hasPreviousPage" + <*> o .:? "startCursor" + <*> o .:? "endCursor" + +-- | A page of results in Relay connection shape. Edges are always in the +-- endpoint's canonical sort order regardless of paging direction. +data Connection a = Connection + { edges :: ![Edge a], + pageInfo :: !PageInfo + } + deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic) + +instance (Aeson.ToJSON a) => Aeson.ToJSON (Connection a) where + toJSON c = Aeson.object ["edges" .= edges c, "pageInfo" .= pageInfo c] + toEncoding c = Aeson.pairs ("edges" .= edges c <> "pageInfo" .= pageInfo c) + +instance (Aeson.FromJSON a) => Aeson.FromJSON (Connection a) where + parseJSON = Aeson.withObject "Connection" \o -> + Connection <$> o .: "edges" <*> o .: "pageInfo" diff --git a/src/Relay/Pagination/Cursor.hs b/src/Relay/Pagination/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination/Cursor.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE BlockArguments #-} + +-- | The opaque pagination cursor: wire representation, payload, and (M4) codec. +-- +-- Wire format (version 1): a cursor is unpadded base64url over compact JSON +-- @{"v":1,"f":,"k":[...]}@. Field order is fixed by 'Aeson.pairs' so +-- encoded bytes are stable; decoding accepts any key order. See the ExecPlan +-- (docs/plans/1-scaffold-the-repository-and-the-relay-pagination-core-package.md) +-- and, once distilled, docs/adr/2-cursor-wire-format.md. +module Relay.Pagination.Cursor + ( Cursor (..), + KeyValue (..), + CursorPayload (..), + CursorError (..), + cursorVersion, + encodeCursor, + decodeCursor, + cursorToText, + cursorFromText, + ) +where + +import Data.Aeson ((.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString.Base64.URL qualified as Base64Url +import Data.ByteString.Lazy qualified as LBS +import Data.Int (Int64) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.UUID.Types (UUID) +import Data.Word (Word32, Word8) +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) + +-- | An opaque cursor, stored exactly as it travels on the wire: unpadded +-- base64url ASCII bytes. Construction from a payload happens only via +-- 'encodeCursor'; inspection only via 'decodeCursor'. The JSON instances are +-- pass-throughs (a cursor is a JSON string) and never validate — validation +-- is the job of the endpoint that knows its expected fingerprint. +newtype Cursor = Cursor ByteString + deriving stock (Show) + deriving newtype (Eq, Ord) + +instance Aeson.ToJSON Cursor where + toJSON (Cursor wire) = Aeson.String (Text.decodeUtf8Lenient wire) + toEncoding (Cursor wire) = Aeson.toEncoding (Text.decodeUtf8Lenient wire) + +instance Aeson.FromJSON Cursor where + parseJSON = Aeson.withText "Cursor" (pure . Cursor . Text.encodeUtf8) + +-- | Renders the wire bytes ('cursorToText'); infallible, like the JSON +-- encoding. +instance ToHttpApiData Cursor where + toUrlPiece = cursorToText + +-- | Unlike the JSON instance, parsing a query parameter rejects text that is +-- not well-formed unpadded base64url ('cursorFromText'), so an HTTP layer can +-- answer 400 without knowing anything about the payload. +instance FromHttpApiData Cursor where + parseUrlPiece = cursorFromText + +-- | One sort-key value inside a cursor. Exact scalar payloads only: +-- deliberately no Double constructor, so float precision loss at page +-- boundaries is unrepresentable. Timestamps are integer microseconds since +-- the Unix epoch (UTC). +data KeyValue + = KvInt !Int64 + | KvText !Text + | KvUuid !UUID + | KvTimestampMicros !Int64 + | KvBool !Bool + | KvNull + deriving stock (Eq, Ord, Show) + +instance Aeson.ToJSON KeyValue where + toJSON = \case + KvInt n -> Aeson.object ["t" .= ("i" :: Text), "v" .= n] + KvText t -> Aeson.object ["t" .= ("s" :: Text), "v" .= t] + KvUuid u -> Aeson.object ["t" .= ("u" :: Text), "v" .= u] + KvTimestampMicros n -> Aeson.object ["t" .= ("ts" :: Text), "v" .= n] + KvBool b -> Aeson.object ["t" .= ("b" :: Text), "v" .= b] + KvNull -> Aeson.object ["t" .= ("n" :: Text)] + toEncoding = \case + KvInt n -> Aeson.pairs ("t" .= ("i" :: Text) <> "v" .= n) + KvText t -> Aeson.pairs ("t" .= ("s" :: Text) <> "v" .= t) + KvUuid u -> Aeson.pairs ("t" .= ("u" :: Text) <> "v" .= u) + KvTimestampMicros n -> Aeson.pairs ("t" .= ("ts" :: Text) <> "v" .= n) + KvBool b -> Aeson.pairs ("t" .= ("b" :: Text) <> "v" .= b) + KvNull -> Aeson.pairs ("t" .= ("n" :: Text)) + +instance Aeson.FromJSON KeyValue where + parseJSON = Aeson.withObject "KeyValue" \o -> do + tag :: Text <- o .: "t" + case tag of + "i" -> KvInt <$> o .: "v" + "s" -> KvText <$> o .: "v" + "u" -> KvUuid <$> o .: "v" + "ts" -> KvTimestampMicros <$> o .: "v" + "b" -> KvBool <$> o .: "v" + "n" -> pure KvNull + other -> fail ("unknown KeyValue tag: " <> Text.unpack other) + +-- | The decoded content of a cursor: format version, the fingerprint of the +-- sort specification that minted it, and one 'KeyValue' per sort column (in +-- sort-specification order, tie-breaker last). +data CursorPayload = CursorPayload + { version :: !Word8, + fingerprint :: !Word32, + keys :: ![KeyValue] + } + deriving stock (Eq, Show) + +instance Aeson.ToJSON CursorPayload where + toJSON p = Aeson.object ["v" .= version p, "f" .= fingerprint p, "k" .= keys p] + toEncoding p = Aeson.pairs ("v" .= version p <> "f" .= fingerprint p <> "k" .= keys p) + +instance Aeson.FromJSON CursorPayload where + parseJSON = Aeson.withObject "CursorPayload" \o -> + CursorPayload <$> o .: "v" <*> o .: "f" <*> o .: "k" + +-- | The current cursor format version. Bumping it is a breaking wire change +-- requiring a Decision Log + ADR entry. +cursorVersion :: Word8 +cursorVersion = 1 + +-- | Everything that can go wrong turning wire bytes back into a payload. +-- KeyTypeMismatch / KeyCountMismatch are raised by relay-pagination-hasql's +-- key codecs (EP-3), not by 'decodeCursor' itself; they live here so the +-- whole cursor pipeline shares one error type. +data CursorError + = BadBase64 + | BadJson !Text + | WrongVersion !Word8 + | FingerprintMismatch + { expected :: !Word32, + actual :: !Word32 + } + | KeyTypeMismatch + { expectedTag :: !Text, + actualValue :: !KeyValue + } + | KeyCountMismatch + { expectedCount :: !Int, + actualCount :: !Int + } + deriving stock (Eq, Show) + +-- | Mint the wire form of a payload: compact JSON, then unpadded base64url. +encodeCursor :: CursorPayload -> Cursor +encodeCursor = Cursor . Base64Url.encodeUnpadded . LBS.toStrict . Aeson.encode + +-- | Render a cursor as text, e.g. for a query parameter. The wire bytes are +-- already unpadded base64url ASCII, so this never fails and never needs +-- percent-encoding. +cursorToText :: Cursor -> Text +cursorToText (Cursor wire) = Text.decodeUtf8Lenient wire + +-- | Parse cursor text received over HTTP, accepting exactly the strings +-- 'cursorToText' produces: well-formed unpadded base64url. The payload stays +-- opaque here — version, fingerprint, and key validation happen later, in +-- 'decodeCursor', at the endpoint that knows its expected fingerprint. +cursorFromText :: Text -> Either Text Cursor +cursorFromText t = + let wire = Text.encodeUtf8 t + in case Base64Url.decodeUnpadded wire of + Left err -> Left ("not unpadded base64url: " <> Text.pack err) + Right _ -> Right (Cursor wire) + +-- | Decode and validate a cursor received from a client. The caller supplies +-- the fingerprint its own sort specification expects; a cursor minted under +-- any other specification is rejected with 'FingerprintMismatch'. +decodeCursor :: Word32 -> Cursor -> Either CursorError CursorPayload +decodeCursor expectedFingerprint (Cursor wire) = do + raw <- first (const BadBase64) (Base64Url.decodeUnpadded wire) + payload :: CursorPayload <- + first (BadJson . Text.pack) (Aeson.eitherDecodeStrict raw) + if version payload /= cursorVersion + then Left (WrongVersion (version payload)) + else + if fingerprint payload /= expectedFingerprint + then Left FingerprintMismatch {expected = expectedFingerprint, actual = fingerprint payload} + else Right payload diff --git a/src/Relay/Pagination/Request.hs b/src/Relay/Pagination/Request.hs new file mode 100644 --- /dev/null +++ b/src/Relay/Pagination/Request.hs @@ -0,0 +1,85 @@ +-- | Validation of the four Relay request arguments (first/after/last/before) +-- into a 'PageRequest'. Strict subset of the Relay spec: first+last together +-- is rejected rather than tolerated, and page sizes above the endpoint's +-- maximum are rejected rather than clamped. +module Relay.Pagination.Request + ( Direction (..), + PageConfig (..), + PageRequest (..), + PageRequestError (..), + mkPageRequest, + ) +where + +import Relay.Pagination.Cursor (Cursor) + +-- | Which way a page walks the canonical sort order. Forward serves +-- first/after; Backward serves last/before. Edges are returned in canonical +-- order either way (the SQL layer reverses backward pages in memory). +data Direction = Forward | Backward + deriving stock (Eq, Show) + +-- | Per-endpoint pagination policy, written once by the service author. +-- Precondition (unchecked): 0 < defaultPageSize <= maxPageSize. +data PageConfig = PageConfig + { defaultPageSize :: !Int, + maxPageSize :: !Int + } + deriving stock (Eq, Show) + +-- | A validated page request: how many rows, which direction, from where. +-- 'cursor' is Nothing for the first page in the given direction. +data PageRequest = PageRequest + { pageSize :: !Int, + direction :: !Direction, + cursor :: !(Maybe Cursor) + } + deriving stock (Eq, Show) + +-- | Why a combination of first/after/last/before was rejected. Checked in +-- declaration order; the first applicable error wins. +data PageRequestError + = FirstAndLastBothGiven + | AfterAndBeforeBothGiven + | FirstWithBefore + | LastWithAfter + | NegativePageSize !Int + | PageSizeTooLarge + { requested :: !Int, + allowedMax :: !Int + } + deriving stock (Eq, Show) + +-- | Validate the four Relay arguments, in the order they appear in a query +-- string: @first@, @after@, @last@, @before@. +mkPageRequest :: + PageConfig -> + -- | @first@ + Maybe Int -> + -- | @after@ + Maybe Cursor -> + -- | @last@ + Maybe Int -> + -- | @before@ + Maybe Cursor -> + Either PageRequestError PageRequest +mkPageRequest config mFirst mAfter mLast mBefore + | Just _ <- mFirst, Just _ <- mLast = Left FirstAndLastBothGiven + | Just _ <- mAfter, Just _ <- mBefore = Left AfterAndBeforeBothGiven + | Just _ <- mFirst, Just _ <- mBefore = Left FirstWithBefore + | Just _ <- mLast, Just _ <- mAfter = Left LastWithAfter + | Just n <- mFirst = do + size <- checkedSize n + Right PageRequest {pageSize = size, direction = Forward, cursor = mAfter} + | Just n <- mLast = do + size <- checkedSize n + Right PageRequest {pageSize = size, direction = Backward, cursor = mBefore} + | Just _ <- mBefore = + Right PageRequest {pageSize = defaultPageSize config, direction = Backward, cursor = mBefore} + | otherwise = + Right PageRequest {pageSize = defaultPageSize config, direction = Forward, cursor = mAfter} + where + checkedSize n + | n < 0 = Left (NegativePageSize n) + | n > maxPageSize config = Left PageSizeTooLarge {requested = n, allowedMax = maxPageSize config} + | otherwise = Right n diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE BlockArguments #-} + +module Main (main) where + +import Data.Aeson qualified as Aeson +import Data.Maybe (fromJust) +import Data.UUID.Types qualified as UUID +import Relay.Pagination +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Web.HttpApiData (parseUrlPiece, toUrlPiece) + +main :: IO () +main = + defaultMain $ + testGroup + "relay-pagination" + [keyValueJsonTests, connectionJsonTests, cursorCodecTests, httpApiDataTests, pageRequestTests] + +-- * KeyValue JSON shape (M3) + +keyValueJsonTests :: TestTree +keyValueJsonTests = + testGroup + "KeyValue JSON" + [ testCase "KvInt" $ Aeson.encode (KvInt 42) @?= "{\"t\":\"i\",\"v\":42}", + testCase "KvText" $ Aeson.encode (KvText "abc") @?= "{\"t\":\"s\",\"v\":\"abc\"}", + testCase "KvUuid" $ + Aeson.encode (KvUuid exampleUuid) + @?= "{\"t\":\"u\",\"v\":\"0dc4ca2f-6f6a-4f28-9f7f-3f2a1b2c3d4e\"}", + testCase "KvTimestampMicros" $ + Aeson.encode (KvTimestampMicros 1720000000123456) + @?= "{\"t\":\"ts\",\"v\":1720000000123456}", + testCase "KvBool" $ Aeson.encode (KvBool True) @?= "{\"t\":\"b\",\"v\":true}", + testCase "KvNull" $ Aeson.encode KvNull @?= "{\"t\":\"n\"}", + testCase "decoding accepts reordered keys" $ + Aeson.decode "{\"v\":7,\"t\":\"i\"}" @?= Just (KvInt 7), + testCase "unknown tag is rejected" $ + Aeson.decode @KeyValue "{\"t\":\"x\"}" @?= Nothing, + testCase "fractional numbers are rejected" $ + Aeson.decode @KeyValue "{\"t\":\"i\",\"v\":1.5}" @?= Nothing, + testProperty "KeyValue JSON round-trips" $ + forAll arbitraryKeyValue \kv -> Aeson.decode (Aeson.encode kv) === Just kv + ] + +-- * Connection JSON shape (M3) + +connectionJsonTests :: TestTree +connectionJsonTests = + testGroup + "Connection JSON" + [ testCase "Relay-conventional shape, exact bytes" $ + Aeson.encode exampleConnection + @?= "{\"edges\":[\ + \{\"node\":\"first\",\"cursor\":\"eyJ2IjoxLCJmIjo3LCJrIjpbeyJ0IjoiaSIsInYiOjF9XX0\"},\ + \{\"node\":\"second\",\"cursor\":\"eyJ2IjoxLCJmIjo3LCJrIjpbeyJ0IjoiaSIsInYiOjJ9XX0\"}],\ + \\"pageInfo\":{\"hasNextPage\":true,\"hasPreviousPage\":false,\ + \\"startCursor\":\"eyJ2IjoxLCJmIjo3LCJrIjpbeyJ0IjoiaSIsInYiOjF9XX0\",\ + \\"endCursor\":\"eyJ2IjoxLCJmIjo3LCJrIjpbeyJ0IjoiaSIsInYiOjJ9XX0\"}}", + testCase "empty page has null cursors" $ + Aeson.encode (Connection {edges = [], pageInfo = PageInfo False False Nothing Nothing} :: Connection Bool) + @?= "{\"edges\":[],\"pageInfo\":{\"hasNextPage\":false,\"hasPreviousPage\":false,\ + \\"startCursor\":null,\"endCursor\":null}}", + testCase "Connection JSON round-trips" $ + Aeson.decode (Aeson.encode exampleConnection) @?= Just exampleConnection + ] + where + c1 = encodeCursor (CursorPayload 1 7 [KvInt 1]) + c2 = encodeCursor (CursorPayload 1 7 [KvInt 2]) + exampleConnection :: Connection String + exampleConnection = + Connection + { edges = [Edge "first" c1, Edge "second" c2], + pageInfo = PageInfo True False (Just c1) (Just c2) + } + +-- * Cursor codec (M4) + +cursorCodecTests :: TestTree +cursorCodecTests = + testGroup + "cursor codec" + [ testProperty "round-trips any version-1 payload" $ + forAll arbitraryPayload \p -> + decodeCursor (fingerprint p) (encodeCursor p) === Right p, + testProperty "any other fingerprint is rejected" $ + forAll arbitraryPayload \p -> \other -> + other /= fingerprint p ==> + decodeCursor other (encodeCursor p) + === Left FingerprintMismatch {expected = other, actual = fingerprint p}, + testCase "golden encode: kitchen sink" $ + encodeCursor kitchenSink @?= Cursor kitchenSinkWire, + testCase "golden decode: kitchen sink" $ + decodeCursor 305419896 (Cursor kitchenSinkWire) @?= Right kitchenSink, + testCase "golden encode: small" $ + encodeCursor (CursorPayload 1 1 [KvInt 7]) + @?= Cursor "eyJ2IjoxLCJmIjoxLCJrIjpbeyJ0IjoiaSIsInYiOjd9XX0", + testCase "golden decode: small" $ + decodeCursor 1 (Cursor "eyJ2IjoxLCJmIjoxLCJrIjpbeyJ0IjoiaSIsInYiOjd9XX0") + @?= Right (CursorPayload 1 1 [KvInt 7]), + testCase "BadBase64 on non-alphabet bytes" $ + decodeCursor 1 (Cursor "%%%") @?= Left BadBase64, + testCase "BadJson on well-formed base64 of non-payload" $ + case decodeCursor 1 (Cursor "aGVsbG8") of -- base64url("hello") + Left (BadJson _) -> pure () + other -> assertFailure ("expected BadJson, got " <> show other), + testCase "WrongVersion on a version-2 payload" $ + decodeCursor 1 (encodeCursor (CursorPayload 2 1 [])) @?= Left (WrongVersion 2) + ] + where + kitchenSink = + CursorPayload + 1 + 305419896 + [ KvTimestampMicros 1720000000123456, + KvInt 42, + KvText "abc", + KvUuid exampleUuid, + KvBool True, + KvNull + ] + kitchenSinkWire = + "eyJ2IjoxLCJmIjozMDU0MTk4OTYsImsiOlt7InQiOiJ0cyIsInYiOjE3MjAwMDAwMDAxMjM0NTZ9\ + \LHsidCI6ImkiLCJ2Ijo0Mn0seyJ0IjoicyIsInYiOiJhYmMifSx7InQiOiJ1IiwidiI6IjBkYzRj\ + \YTJmLTZmNmEtNGYyOC05ZjdmLTNmMmExYjJjM2Q0ZSJ9LHsidCI6ImIiLCJ2Ijp0cnVlfSx7InQi\ + \OiJuIn1dfQ" + +-- * Cursor http-api-data instances (EP-2 M1) + +httpApiDataTests :: TestTree +httpApiDataTests = + testGroup + "Cursor http-api-data" + [ testCase "toUrlPiece is the wire text verbatim" $ + toUrlPiece (Cursor "-_8A") @?= "-_8A", + testCase "round-trips URL-safe alphabet bytes" $ + -- "-_8A" is base64url of [0xfb, 0xff, 0x00]; plain base64 would be "+/8A" + parseUrlPiece (toUrlPiece (Cursor "-_8A")) @?= Right (Cursor "-_8A"), + testProperty "round-trips any minted cursor" $ + forAll arbitraryPayload \p -> + let c = encodeCursor p + in parseUrlPiece (toUrlPiece c) === Right c, + testCase "rejects non-base64url input" $ + case parseUrlPiece @Cursor "%%%not-base64url!" of + Left _ -> pure () + Right c -> assertFailure ("expected Left, got " <> show c), + testCase "rejects padded base64" $ + case parseUrlPiece @Cursor "YWI=" of + Left _ -> pure () + Right c -> assertFailure ("expected Left, got " <> show c) + ] + +-- * mkPageRequest validation matrix (M5) + +pageRequestTests :: TestTree +pageRequestTests = + testGroup + "mkPageRequest" + [ ok "no arguments: forward, default size" Nothing Nothing Nothing Nothing (PageRequest 25 Forward Nothing), + ok "first" (Just 10) Nothing Nothing Nothing (PageRequest 10 Forward Nothing), + ok "first+after" (Just 10) (Just c) Nothing Nothing (PageRequest 10 Forward (Just c)), + ok "after alone: forward, default size" Nothing (Just c) Nothing Nothing (PageRequest 25 Forward (Just c)), + ok "last" Nothing Nothing (Just 10) Nothing (PageRequest 10 Backward Nothing), + ok "last+before" Nothing Nothing (Just 10) (Just c) (PageRequest 10 Backward (Just c)), + ok "before alone: backward, default size" Nothing Nothing Nothing (Just c) (PageRequest 25 Backward (Just c)), + ok "zero size is allowed" (Just 0) Nothing Nothing Nothing (PageRequest 0 Forward Nothing), + ok "size equal to max is allowed" (Just 100) Nothing Nothing Nothing (PageRequest 100 Forward Nothing), + bad "first+last" (Just 1) Nothing (Just 1) Nothing FirstAndLastBothGiven, + bad "everything at once: first+last wins" (Just 1) (Just c) (Just 1) (Just c) FirstAndLastBothGiven, + bad "after+before" Nothing (Just c) Nothing (Just c) AfterAndBeforeBothGiven, + bad "first+before" (Just 1) Nothing Nothing (Just c) FirstWithBefore, + bad "last+after" Nothing (Just c) (Just 1) Nothing LastWithAfter, + bad "negative first" (Just (-1)) Nothing Nothing Nothing (NegativePageSize (-1)), + bad "negative last" Nothing Nothing (Just (-5)) (Just c) (NegativePageSize (-5)), + bad "first over max" (Just 101) Nothing Nothing Nothing PageSizeTooLarge {requested = 101, allowedMax = 100}, + bad "last over max" Nothing Nothing (Just 1000) Nothing PageSizeTooLarge {requested = 1000, allowedMax = 100} + ] + where + cfg = PageConfig {defaultPageSize = 25, maxPageSize = 100} + c = encodeCursor (CursorPayload 1 1 [KvInt 7]) + ok name f a l b expected = + testCase name (mkPageRequest cfg f a l b @?= Right expected) + bad name f a l b expected = + testCase name (mkPageRequest cfg f a l b @?= Left expected) + +-- * Generators + +exampleUuid :: UUID.UUID +exampleUuid = fromJust (UUID.fromString "0dc4ca2f-6f6a-4f28-9f7f-3f2a1b2c3d4e") + +arbitraryKeyValue :: Gen KeyValue +arbitraryKeyValue = + oneof + [ KvInt <$> arbitrary, + KvText <$> arbitrary, + KvUuid <$> arbitrary, + KvTimestampMicros <$> arbitrary, + KvBool <$> arbitrary, + pure KvNull + ] + +arbitraryPayload :: Gen CursorPayload +arbitraryPayload = CursorPayload 1 <$> arbitrary <*> listOf arbitraryKeyValue