relay-pagination-servant (empty) → 0.1.0.0
raw patch · 10 files changed
+991/−0 lines, 10 filesdep +aesondep +aeson-prettydep +base
Dependencies added: aeson, aeson-pretty, base, bytestring, http-api-data, http-client, http-types, insert-ordered-containers, lens, openapi-hs, relay-pagination, relay-pagination-servant, servant, servant-client, servant-client-core, servant-openapi-hs, servant-server, sop-core, tasty, tasty-hunit, text, wai, warp
Files
- CHANGELOG.md +18/−0
- LICENSE +30/−0
- demo/Main.hs +14/−0
- demo/OpenApiMain.hs +18/−0
- demo/ToyApi.hs +111/−0
- demo/ToyOpenApi.hs +27/−0
- relay-pagination-servant.cabal +141/−0
- src/Relay/Pagination/Servant.hs +242/−0
- src/Relay/Pagination/Servant/OpenApi.hs +124/−0
- test/Main.hs +266/−0
+ CHANGELOG.md view
@@ -0,0 +1,18 @@+# Changelog for relay-pagination-servant++Versioning follows the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## 0.1.0.0 — 2026-07-16++Initial contents:++- The `RelayPage defSize maxSize` combinator: declares the four Relay query+ parameters on a route and hands the handler one validated `PageRequest`,+ answering HTTP 400 with a stable-coded JSON `RelayPageError` body before+ the handler runs.+- `HasServer`, `HasClient` (via the `ClientPage` argument record with+ `noPageArgs`/`forwardPage`/`backwardPage`), and `HasLink` instances.+- OpenAPI 3.1 documentation (`Relay.Pagination.Servant.OpenApi`, via+ `openapi-hs`/`servant-openapi-hs`): the four parameters with bounds and+ defaults, plus the canonical `ToSchema`/`ToParamSchema` orphans for the+ core pagination types.
+ 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.
+ demo/Main.hs view
@@ -0,0 +1,14 @@+-- | Toy demo server for the curl transcript in EP-2's Validation section.+-- Serves the same shared 'ToyApi.toyApp' the tests and the OpenAPI generator+-- use, on port 8080:+--+-- > cabal run relay-pagination-servant:relay-demo+module Main (main) where++import Network.Wai.Handler.Warp (run)+import ToyApi (toyApp)++main :: IO ()+main = do+ putStrLn "relay-demo: serving the toy paginated API on http://localhost:8080/items"+ run 8080 toyApp
+ demo/OpenApiMain.hs view
@@ -0,0 +1,18 @@+-- | Writes the checked OpenAPI 3.1 artifact. This executable is the __only__+-- thing allowed to write @relay-pagination-servant/test/golden/toy-openapi.json@;+-- the test suite compares the checked bytes read-only (no @--accept@ mode).+--+-- Run from the repository root:+--+-- > cabal run relay-pagination-servant:relay-demo-openapi+module Main (main) where++import Data.ByteString.Lazy qualified as LBS+import ToyOpenApi (renderToyOpenApi)++main :: IO ()+main = do+ LBS.writeFile artifactPath renderToyOpenApi+ putStrLn ("wrote " <> artifactPath)+ where+ artifactPath = "relay-pagination-servant/test/golden/toy-openapi.json"
+ demo/ToyApi.hs view
@@ -0,0 +1,111 @@+-- | The one shared toy API used by the test suite, the @relay-demo@ server,+-- and the @relay-demo-openapi@ generator. There is exactly one 'toyApi'+-- proxy; serving, client generation, links, and OpenAPI derivation all use+-- it, so what is tested, served, and documented cannot drift apart.+--+-- The handler echoes the validated 'PageRequest' back into the response —+-- the page size becomes 'itemId' and the direction becomes 'itemName' — so+-- tests can observe exactly what the 'RelayPage' combinator produced.+module ToyApi+ ( Item (..),+ ToyPageResponses,+ ToyPageResult (..),+ ToyEndpoint,+ ToyItemsEndpoint,+ ToyRoutes (..),+ toyApi,+ toyServer,+ toyApp,+ toyCursor,+ )+where++import Data.Aeson (FromJSON, ToJSON)+import Data.OpenApi (ToSchema)+import Data.Proxy (Proxy (..))+import Data.SOP (I (..), NS (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.Wai (Application)+import Relay.Pagination+import Relay.Pagination.Servant+import Servant (Handler, serve)+import Servant.API (JSON, NamedRoutes, StdMethod (GET), (:-), (:>))+import Servant.API.MultiVerb (AsUnion (..), MultiVerb, Respond)+import Servant.Server.Generic (AsServerT)++data Item = Item+ { itemId :: !Int,+ itemName :: !Text+ }+ deriving stock (Eq, Show, Generic)+ -- ToSchema lives here, next to the definition, where it is not an orphan.+ deriving anyclass (ToJSON, FromJSON, ToSchema)++type ToyPageResponses =+ '[ Respond 200 "Page of items" (Connection Item),+ Respond 400 "Invalid pagination" RelayPageError+ ]++data ToyPageResult+ = ToyPageOk !(Connection Item)+ | ToyPageBadRequest !RelayPageError+ deriving stock (Eq, Show)++-- | Hand-written on purpose: the mapping between a result constructor and+-- its HTTP status is load-bearing, so adding or reordering a response+-- alternative must stop compiling rather than silently renumber.+instance AsUnion ToyPageResponses ToyPageResult where+ toUnion = \case+ ToyPageOk value -> Z (I value)+ ToyPageBadRequest err -> S (Z (I err))+ fromUnion = \case+ Z (I value) -> ToyPageOk value+ S (Z (I err)) -> ToyPageBadRequest err+ S (S impossible) -> case impossible of {}++type ToyEndpoint =+ RelayPage 10 100+ :> MultiVerb 'GET '[JSON] ToyPageResponses ToyPageResult++type ToyItemsEndpoint = "items" :> ToyEndpoint++data ToyRoutes mode = ToyRoutes+ { items :: mode :- ToyItemsEndpoint+ }+ deriving stock (Generic)++-- | The single proxy shared by @serve@, @genericClient@, @safeLink@, and+-- @toOpenApi@.+toyApi :: Proxy (NamedRoutes ToyRoutes)+toyApi = Proxy++-- | A fixed, well-formed cursor for the toy edges: base64url of @edge-1@.+toyCursor :: Cursor+toyCursor = Cursor "ZWRnZS0x"++toyServer :: ToyRoutes (AsServerT Handler)+toyServer = ToyRoutes {items = serveItems}+ where+ serveItems pr =+ pure . ToyPageOk $+ Connection+ { edges =+ [ Edge+ { node = Item {itemId = pageSize pr, itemName = directionText (direction pr)},+ cursor = toyCursor+ }+ ],+ pageInfo =+ PageInfo+ { hasNextPage = False,+ hasPreviousPage = False,+ startCursor = Just toyCursor,+ endCursor = Just toyCursor+ }+ }+ directionText Forward = "forward" :: Text+ directionText Backward = "backward"++toyApp :: Application+toyApp = serve toyApi toyServer
+ demo/ToyOpenApi.hs view
@@ -0,0 +1,27 @@+-- | Deterministic rendering of the toy API's OpenAPI 3.1 document, shared by+-- the @relay-demo-openapi@ generator (which writes the checked artifact) and+-- the test suite (which compares the checked bytes against this exact+-- rendering, read-only).+module ToyOpenApi+ ( toyOpenApi,+ renderToyOpenApi,+ )+where++import Control.Lens ((&), (?~))+import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty')+import Data.ByteString.Lazy (ByteString)+import Data.OpenApi (OpenApi, allOperations, operationId)+import Relay.Pagination.Servant.OpenApi ()+import Servant.OpenApi (toOpenApi)+import ToyApi (toyApi)++-- | Derived from the exact proxy passed to @serve@, then enriched with the+-- one thing the route types cannot carry: a stable operation id.+toyOpenApi :: OpenApi+toyOpenApi = toOpenApi toyApi & allOperations . operationId ?~ "getItems"++-- | Byte-stable output for the checked artifact and the drift test: sorted+-- keys, one trailing newline.+renderToyOpenApi :: ByteString+renderToyOpenApi = encodePretty' defConfig {confCompare = compare} toyOpenApi <> "\n"
+ relay-pagination-servant.cabal view
@@ -0,0 +1,141 @@+cabal-version: 3.0+name: relay-pagination-servant+version: 0.1.0.0+synopsis:+ RelayPage servant combinator for Relay-style cursor pagination++description:+ The RelayPage servant combinator: declares the four Relay pagination query+ parameters (first, after, last, before) on a route, validates them before+ the handler runs, and hands the handler one already-validated PageRequest.+ Ships HasServer, HasClient, and HasLink instances plus OpenAPI 3.1+ documentation support via openapi-hs and servant-openapi-hs.++license: BSD-3-Clause+license-file: LICENSE+author: Nadeem Bitar+maintainer: Nadeem Bitar+category: Web, Servant+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.Servant+ Relay.Pagination.Servant.OpenApi++ build-depends:+ , aeson >=2.2 && <2.3+ , base >=4.21 && <5+ , http-api-data >=0.6 && <0.7+ , http-types >=0.12 && <0.13+ , lens >=5.2 && <5.4+ , openapi-hs >=4.1 && <4.2+ , relay-pagination ^>=0.1.0.0+ , servant >=0.20.3 && <0.21+ , servant-client-core >=0.20.3 && <0.21+ , servant-openapi-hs >=4.1 && <4.2+ , servant-server >=0.20.3 && <0.21+ , text >=2.0 && <2.2+ , wai >=3.2 && <3.3++test-suite relay-pagination-servant-test+ import: lang+ type: exitcode-stdio-1.0+ hs-source-dirs: test demo+ main-is: Main.hs+ other-modules:+ ToyApi+ ToyOpenApi++ -- warp requires the threaded RTS (its TimerManager will not start without it)+ ghc-options: -threaded+ build-depends:+ , aeson+ , aeson-pretty >=0.8 && <0.9+ , base+ , bytestring >=0.11 && <0.13+ , http-api-data+ , http-client >=0.7 && <0.8+ , http-types+ , insert-ordered-containers >=0.2 && <0.3+ , lens+ , openapi-hs+ , relay-pagination ^>=0.1.0.0+ , relay-pagination-servant+ , servant+ , servant-client >=0.20.3 && <0.21+ , servant-client-core+ , servant-openapi-hs+ , servant-server+ , sop-core >=0.5 && <0.6+ , tasty >=1.4 && <1.6+ , tasty-hunit >=0.10 && <0.11+ , text+ , wai+ , warp >=3.3 && <3.5++executable relay-demo+ import: lang+ hs-source-dirs: demo+ main-is: Main.hs+ other-modules: ToyApi++ -- warp requires the threaded RTS (its TimerManager will not start without it)+ ghc-options: -threaded+ build-depends:+ , aeson+ , base+ , openapi-hs+ , relay-pagination ^>=0.1.0.0+ , relay-pagination-servant+ , servant+ , servant-server+ , sop-core >=0.5 && <0.6+ , text+ , wai+ , warp >=3.3 && <3.5++executable relay-demo-openapi+ import: lang+ hs-source-dirs: demo+ main-is: OpenApiMain.hs+ other-modules:+ ToyApi+ ToyOpenApi++ build-depends:+ , aeson+ , aeson-pretty >=0.8 && <0.9+ , base+ , bytestring >=0.11 && <0.13+ , lens+ , openapi-hs+ , relay-pagination ^>=0.1.0.0+ , relay-pagination-servant+ , servant+ , servant-openapi-hs+ , servant-server+ , sop-core >=0.5 && <0.6+ , text+ , wai
+ src/Relay/Pagination/Servant.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | The 'RelayPage' servant combinator: Relay-style cursor pagination for+-- plain REST endpoints.+--+-- Writing @'RelayPage' 10 100 :> ...@ in a route declares the four Relay+-- pagination query parameters — @first@, @after@, @last@, @before@ — with a+-- default page size of 10 and a maximum of 100. The handler receives a single+-- already-validated 'PageRequest'; every invalid request is answered before+-- the handler runs with HTTP 400 and a 'RelayPageError' JSON body.+--+-- == The 400 error-body contract+--+-- The status is always 400 and the body is the JSON representation of+-- 'RelayPageError', with exactly the keys @code@, @message@, @retryable@, and+-- @parameter@. Clients must branch on @code@, never on @message@ (which is+-- explanatory prose and may change). @retryable@ is always @false@ for+-- request validation. @parameter@ names one offending query parameter+-- (@"first"@, @"after"@, @"last"@, or @"before"@) or is JSON @null@ when no+-- single parameter is responsible. The stable codes:+--+-- * @invalid_integer@ — @first@ or @last@ is not a decimal integer.+-- * @invalid_cursor@ — @after@ or @before@ is not unpadded base64url.+-- * @mixed_pagination_directions@ — parameters from both the forward family+-- (@first@, @after@) and the backward family (@last@, @before@) were+-- supplied.+-- * @negative_page_size@ — @first@ or @last@ is negative.+-- * @page_size_too_large@ — @first@ or @last@ exceeds the route's maximum.+--+-- Routes should declare the same 'RelayPageError' type in a 400 'MultiVerb'+-- alternative so generated clients and OpenAPI documents can represent the+-- response the combinator actually produces at runtime.+--+-- The servant layer validates only that a cursor is well-formed unpadded+-- base64url; payload validation (version, fingerprint, key types) belongs to+-- the layer that knows the endpoint's sort specification (the hasql engine).+module Relay.Pagination.Servant+ ( RelayPage,+ RelayPageError (..),+ ClientPage (..),+ noPageArgs,+ forwardPage,+ backwardPage,+ )+where++import Control.Monad (join)+import Data.Aeson qualified as Aeson+import Data.Maybe (isJust)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics (Generic)+import GHC.TypeLits (KnownNat, Nat, natVal)+import Network.HTTP.Types (queryToQueryText)+import Network.Wai (Request, queryString)+import Relay.Pagination+import Servant.API ((:>))+import Servant.Client.Core qualified as Client+import Servant.Links (HasLink (..), Link, Param (SingleParam), addQueryParam)+import Servant.Server.Internal+import Web.HttpApiData (ToHttpApiData, parseQueryParam, toQueryParam)++-- | Declares the four Relay pagination query parameters on a route.+--+-- @defSize@ is the page size used when neither @first@ nor @last@ is given;+-- @maxSize@ is the hard upper bound (requests above it get HTTP 400). Both+-- are type-level so that the server (validation), the generated OpenAPI+-- document, and readers of the route type all see the same numbers.+--+-- This type is uninhabited; only its position in the route type matters.+data RelayPage (defSize :: Nat) (maxSize :: Nat)++-- | Stable 400 response body emitted by pagination validation. See the+-- module haddock for the full contract; in short: branch on 'code', treat+-- 'message' as prose, expect 'retryable' to be false, and read 'parameter'+-- as the offending query parameter when one can be named.+data RelayPageError = RelayPageError+ { code :: !Text,+ message :: !Text,+ retryable :: !Bool,+ parameter :: !(Maybe Text)+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (Aeson.FromJSON, Aeson.ToJSON)++-- | Parses and validates @first@\/@after@\/@last@\/@before@ ahead of the+-- handler, which receives one 'PageRequest'. Validation failures abort+-- routing fatally (a sibling route cannot match afterwards) with the 400+-- described in the module haddock, mirroring what servant's own 'QueryParam'+-- does on a parse failure.+instance+ (KnownNat defSize, KnownNat maxSize, HasServer api context) =>+ HasServer (RelayPage defSize maxSize :> api) context+ where+ type ServerT (RelayPage defSize maxSize :> api) m = PageRequest -> ServerT api m++ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s++ route _ context subserver =+ route (Proxy @api) context (addParameterCheck subserver (withRequest parsePage))+ where+ pageConfig =+ PageConfig+ { defaultPageSize = fromInteger (natVal (Proxy @defSize)),+ maxPageSize = fromInteger (natVal (Proxy @maxSize))+ }++ parsePage :: Request -> DelayedIO PageRequest+ parsePage req = do+ let qs = queryToQueryText (queryString req)+ look n = join (lookup n qs) -- valueless "?first" counts as absent+ mFirst <- traverse (parseSize "first") (look "first")+ mLast <- traverse (parseSize "last") (look "last")+ mAfter <- traverse (parseCursor "after") (look "after")+ mBefore <- traverse (parseCursor "before") (look "before")+ case mkPageRequest pageConfig mFirst mAfter mLast mBefore of+ Right pr -> pure pr+ Left err -> delayedFailFatal (pageRequestError400 mFirst err)++ parseSize :: Text -> Text -> DelayedIO Int+ parseSize param raw = case parseQueryParam raw of+ Right n -> pure n+ Left e ->+ delayedFailFatal+ (relayError400 "invalid_integer" ("invalid integer: " <> e) (Just param))++ parseCursor :: Text -> Text -> DelayedIO Cursor+ parseCursor param raw = case cursorFromText raw of+ Right c -> pure c+ Left e ->+ delayedFailFatal+ (relayError400 "invalid_cursor" ("invalid cursor: " <> e) (Just param))++-- | The client- and link-side argument for a 'RelayPage' route: the four+-- Relay parameters as one named record instead of four positional @Maybe@s+-- (two adjacent @Maybe Int@ and two adjacent @Maybe Cursor@ positional+-- arguments would be a swap-bug factory).+--+-- Prefer the smart constructors 'noPageArgs', 'forwardPage', and+-- 'backwardPage' for the valid combinations. The raw constructor stays+-- exported deliberately so tests can send invalid combinations and exercise+-- the server's 400 path. Consume it with an explicit record pattern (a pun+-- on the @last@ field would shadow 'Prelude.last').+data ClientPage = ClientPage+ { first :: !(Maybe Int),+ after :: !(Maybe Cursor),+ last :: !(Maybe Int),+ before :: !(Maybe Cursor)+ }+ deriving stock (Eq, Show)++-- | No pagination parameters: the server pages forward with its default size.+noPageArgs :: ClientPage+noPageArgs =+ ClientPage {first = Nothing, after = Nothing, last = Nothing, before = Nothing}++-- | Page forward: @first@ plus an optional @after@ cursor.+forwardPage :: Int -> Maybe Cursor -> ClientPage+forwardPage size mAfter =+ ClientPage {first = Just size, after = mAfter, last = Nothing, before = Nothing}++-- | Page backward: @last@ plus an optional @before@ cursor.+backwardPage :: Int -> Maybe Cursor -> ClientPage+backwardPage size mBefore =+ ClientPage {first = Nothing, after = Nothing, last = Just size, before = mBefore}++-- | Client functions take one 'ClientPage' and append whichever of the four+-- parameters are present to the outgoing query string.+instance (Client.HasClient m api) => Client.HasClient m (RelayPage d mx :> api) where+ type Client m (RelayPage d mx :> api) = ClientPage -> Client.Client m api++ clientWithRoute pm _ req page =+ Client.clientWithRoute pm (Proxy @api) (addPageParams page req)++ hoistClientMonad pm _ f cl = Client.hoistClientMonad pm (Proxy @api) f . cl++addPageParams :: ClientPage -> Client.Request -> Client.Request+addPageParams ClientPage {first = mFirst, after = mAfter, last = mLast, before = mBefore} =+ add "before" mBefore . add "last" mLast . add "after" mAfter . add "first" mFirst+ where+ add :: (ToHttpApiData v) => Text -> Maybe v -> Client.Request -> Client.Request+ add name =+ maybe id (\v -> Client.appendToQueryString name (Just (Client.encodeQueryParamValue v)))++-- | Links take the same 'ClientPage'; 'Servant.Links.safeLink' renders the+-- present parameters in @first@, @after@, @last@, @before@ order.+instance (HasLink sub) => HasLink (RelayPage d mx :> sub) where+ type MkLink (RelayPage d mx :> sub) a = ClientPage -> MkLink sub a++ toLink toA _ l page = toLink toA (Proxy @sub) (addPageLinkParams page l)++addPageLinkParams :: ClientPage -> Link -> Link+addPageLinkParams ClientPage {first = mFirst, after = mAfter, last = mLast, before = mBefore} =+ add "before" mBefore . add "last" mLast . add "after" mAfter . add "first" mFirst+ where+ add :: (ToHttpApiData v) => String -> Maybe v -> Link -> Link+ add name = maybe id (\v -> addQueryParam (SingleParam name (toQueryParam v)))++-- | A 400 whose body is the JSON 'RelayPageError' assembled from the pieces.+relayError400 :: Text -> Text -> Maybe Text -> ServerError+relayError400 errorCode errorMessage offender =+ err400+ { errBody =+ Aeson.encode+ RelayPageError+ { code = errorCode,+ message = errorMessage,+ retryable = False,+ parameter = offender+ },+ errHeaders = [("Content-Type", "application/json")]+ }++-- | Map core's 'PageRequestError' to the wire contract. The @first@ argument+-- disambiguates which size parameter a size error should blame.+pageRequestError400 :: Maybe Int -> PageRequestError -> ServerError+pageRequestError400 mFirst = \case+ FirstAndLastBothGiven -> mixed "last"+ AfterAndBeforeBothGiven -> mixed "before"+ FirstWithBefore -> mixed "before"+ LastWithAfter -> mixed "after"+ NegativePageSize n ->+ relayError400+ "negative_page_size"+ ("page size must be non-negative, got " <> tshow n)+ (Just sizeParam)+ PageSizeTooLarge {requested, allowedMax} ->+ relayError400+ "page_size_too_large"+ ("page size " <> tshow requested <> " exceeds maximum " <> tshow allowedMax)+ (Just sizeParam)+ where+ sizeParam = if isJust mFirst then "first" else "last"+ mixed offender =+ relayError400+ "mixed_pagination_directions"+ "cannot combine forward (first/after) and backward (last/before) arguments"+ (Just offender)+ tshow :: (Show a) => a -> Text+ tshow = Text.pack . show
+ src/Relay/Pagination/Servant/OpenApi.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | OpenAPI 3.1 documentation for the 'RelayPage' combinator, plus the+-- schema instances for the core pagination types.+--+-- This module is the __canonical (sole permitted) home__ of the OpenAPI+-- orphan instances for the core @relay-pagination@ types ('Cursor',+-- 'PageInfo', 'Edge', 'Connection') and for 'RelayPageError'. The core+-- package must not depend on @openapi-hs@, and @openapi-hs@ cannot know+-- about this library, so orphans are the standard escape hatch — the danger+-- of orphans is duplicate definitions elsewhere, therefore no other package+-- in this repository or downstream may define these instances.+--+-- The 'HasOpenApi' instance documents the four Relay query parameters,+-- including the type-level default and maximum page sizes. It deliberately+-- does not add a synthetic 400 response: the terminal 'MultiVerb' declares+-- @Respond 400 ... RelayPageError@ and @servant-openapi-hs@ derives the+-- response from that type, which makes a plain @Get@ terminal visibly+-- incomplete rather than letting documentation pretend its client can decode+-- an error the route type omitted.+module Relay.Pagination.Servant.OpenApi () where++import Control.Lens ((&), (.~), (?~))+import Data.Aeson (toJSON)+import Data.OpenApi+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.TypeLits (KnownNat, natVal)+import Relay.Pagination+import Relay.Pagination.Servant+import Servant.API ((:>))+import Servant.OpenApi (HasOpenApi (..))+import Servant.OpenApi.Internal (addParam)++instance+ (KnownNat d, KnownNat mx, HasOpenApi sub) =>+ HasOpenApi (RelayPage d mx :> sub)+ where+ toOpenApi _ =+ -- addParam prepends to each operation's parameter list, so apply in+ -- reverse to document the parameters in first, after, last, before order.+ toOpenApi (Proxy @sub)+ & addParam beforeParam+ & addParam lastParam+ & addParam afterParam+ & addParam firstParam+ where+ defSize, maxSize :: Integer+ defSize = natVal (Proxy @d)+ maxSize = natVal (Proxy @mx)++ sizeSchema =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & minimum_ ?~ 0+ & maximum_ ?~ fromInteger maxSize++ cursorSchema = toParamSchema (Proxy @Cursor)++ queryParam paramName paramDescription paramSchema =+ mempty+ & name .~ paramName+ & in_ .~ ParamQuery+ & required ?~ False+ & description ?~ paramDescription+ & schema ?~ Inline paramSchema++ firstParam =+ queryParam+ "first"+ ( "Forward page size (0.."+ <> tshow maxSize+ <> "). Defaults to "+ <> tshow defSize+ <> " when neither 'first' nor 'last' is given. "+ <> "Cannot be combined with 'last' or 'before'."+ )+ (sizeSchema & default_ ?~ toJSON defSize)+ lastParam =+ queryParam+ "last"+ ( "Backward page size (0.."+ <> tshow maxSize+ <> "). Cannot be combined with 'first' or 'after'."+ )+ sizeSchema+ afterParam =+ queryParam+ "after"+ "Opaque cursor: return items after this position (forward pagination)."+ cursorSchema+ beforeParam =+ queryParam+ "before"+ "Opaque cursor: return items before this position (backward pagination)."+ cursorSchema++ tshow :: (Show a) => a -> Text+ tshow = Text.pack . show++instance ToParamSchema Cursor where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ "base64url"++instance ToSchema Cursor where+ declareNamedSchema _ =+ pure . NamedSchema (Just "Cursor") $+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ "base64url"+ & description ?~ "opaque pagination cursor"++instance ToSchema RelayPageError++instance ToSchema PageInfo++instance (ToSchema a) => ToSchema (Edge a) where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions++instance (ToSchema a) => ToSchema (Connection a) where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
+ test/Main.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE BlockArguments #-}++module Main (main) where++import Control.Lens ((^.), (^..))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Lazy qualified as LBS+import Data.HashMap.Strict.InsOrd qualified as InsOrd+import Data.List (sort)+import Data.OpenApi qualified as OpenApi+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as Text+import Network.HTTP.Client qualified as HttpClient+import Network.HTTP.Types (statusCode)+import Network.Wai.Handler.Warp (testWithApplication)+import Relay.Pagination+import Relay.Pagination.Servant+import Relay.Pagination.Servant.OpenApi ()+import Servant.Client (BaseUrl (..), ClientError, ClientM, Scheme (Http), mkClientEnv, runClientM)+import Servant.Client.Generic (AsClientT, genericClient)+import Servant.Links (safeLink)+import Test.Tasty+import Test.Tasty.HUnit+import ToyApi+import ToyOpenApi (renderToyOpenApi, toyOpenApi)+import Web.HttpApiData (toUrlPiece)++main :: IO ()+main =+ defaultMain $+ testGroup+ "relay-pagination-servant"+ [serverTests, clientTests, linkTests, openapiTests]++-- * The RelayPage HasServer instance, over real HTTP (M2)++serverTests :: TestTree+serverTests =+ testGroup+ "server"+ [ withToy "applies default page size" "/items" \(status, body) -> do+ status @?= 200+ conn <- decodeOk @(Connection Item) body+ firstItem conn @?= Item {itemId = 10, itemName = "forward"},+ withToy "honors first=5" "/items?first=5" \(status, body) -> do+ status @?= 200+ conn <- decodeOk @(Connection Item) body+ firstItem conn @?= Item {itemId = 5, itemName = "forward"},+ withToy+ "pages backward with last+before"+ ("/items?last=5&before=" <> validCursorText)+ \(status, body) -> do+ status @?= 200+ conn <- decodeOk @(Connection Item) body+ firstItem conn @?= Item {itemId = 5, itemName = "backward"},+ withToy "400 on malformed cursor" "/items?after=%25%25garbage" \(status, body) -> do+ status @?= 400+ err <- decodeOk @RelayPageError body+ assertRelayError err "invalid_cursor" (Just "after"),+ withToy "400 on first+last" "/items?first=5&last=5" \(status, body) -> do+ status @?= 400+ err <- decodeOk @RelayPageError body+ assertRelayError err "mixed_pagination_directions" (Just "last"),+ withToy "typed 400 on first over max" "/items?first=101" \(status, body) -> do+ status @?= 400+ err <- decodeOk @RelayPageError body+ assertRelayError err "page_size_too_large" (Just "first"),+ withToy "accepts first=0" "/items?first=0" \(status, body) -> do+ status @?= 200+ conn <- decodeOk @(Connection Item) body+ firstItem conn @?= Item {itemId = 0, itemName = "forward"},+ withToy "typed 400 on first=-1" "/items?first=-1" \(status, body) -> do+ status @?= 400+ err <- decodeOk @RelayPageError body+ assertRelayError err "negative_page_size" (Just "first")+ ]+ where+ -- The servant layer checks only base64url shape, so any well-formed+ -- cursor text passes it; payload validation belongs to the hasql layer.+ validCursorText = toUrlPiece (Cursor "anything")++-- * The generated client, typed 200/400 round trips (M3)++toyClient :: ToyRoutes (AsClientT ClientM)+toyClient = genericClient++clientTests :: TestTree+clientTests =+ testGroup+ "client"+ [ withToyClient "typed forward round trip" (forwardPage 7 Nothing) \result ->+ case result of+ Right (ToyPageOk conn) ->+ -- The whole Connection, exactly as the raw-HTTP tests saw it:+ -- this exercises core's FromJSON through servant-client.+ conn+ @?= Connection+ { edges = [Edge {node = Item {itemId = 7, itemName = "forward"}, cursor = toyCursor}],+ pageInfo =+ PageInfo+ { hasNextPage = False,+ hasPreviousPage = False,+ startCursor = Just toyCursor,+ endCursor = Just toyCursor+ }+ }+ other -> assertFailure ("expected ToyPageOk, got " <> show other),+ withToyClient "typed backward round trip" (backwardPage 3 (Just toyCursor)) \result ->+ case result of+ Right (ToyPageOk conn) ->+ firstItem conn @?= Item {itemId = 3, itemName = "backward"}+ other -> assertFailure ("expected ToyPageOk, got " <> show other),+ withToyClient+ "decodes mixed ClientPage as 400 sum"+ ClientPage {first = Just 5, after = Nothing, last = Just 5, before = Nothing}+ \result ->+ case result of+ Right (ToyPageBadRequest err) ->+ -- Right, not Left FailureResponse: the practical reason the+ -- route declares MultiVerb with a typed 400 alternative.+ assertRelayError err "mixed_pagination_directions" (Just "last")+ other -> assertFailure ("expected ToyPageBadRequest, got " <> show other)+ ]++withToyClient :: TestName -> ClientPage -> (Either ClientError ToyPageResult -> Assertion) -> TestTree+withToyClient name page check =+ testCase name $+ testWithApplication (pure toyApp) \port -> do+ manager <- HttpClient.newManager HttpClient.defaultManagerSettings+ let env = mkClientEnv manager (BaseUrl Http "127.0.0.1" port "")+ runClientM (items toyClient page) env >>= check++-- * Typed links (M3)++linkTests :: TestTree+linkTests =+ testGroup+ "links"+ [ testCase "renders first+after query string" $+ toUrlPiece (safeLink toyApi (Proxy @ToyItemsEndpoint) (forwardPage 5 (Just (Cursor "YWI"))))+ @?= "items?first=5&after=YWI",+ testCase "noPageArgs renders bare path" $+ toUrlPiece (safeLink toyApi (Proxy @ToyItemsEndpoint) noPageArgs)+ @?= "items"+ ]++-- * The derived OpenAPI 3.1 document (M4)++-- These tests are read-only: only the relay-demo-openapi executable may+-- write the checked artifact. The test binary runs with the package+-- directory as its working directory, hence the test-relative path.+openapiTests :: TestTree+openapiTests =+ testGroup+ "openapi"+ [ testCase "checked artifact matches generator" $ do+ checked <- LBS.readFile "test/golden/toy-openapi.json"+ checked @?= renderToyOpenApi,+ testCase "document version is OpenAPI 3.1" $+ case Aeson.toJSON toyOpenApi of+ Aeson.Object o -> KeyMap.lookup "openapi" o @?= Just (Aeson.String "3.1.0")+ other -> assertFailure ("document did not serialize to an object: " <> show other),+ testCase "path set is exactly /items with a getItems GET" $ do+ InsOrd.keys (toyOpenApi ^. OpenApi.paths) @?= ["/items"]+ theOperation ^. OpenApi.operationId @?= Just "getItems",+ testCase "operation declares exactly the 200 and 400 responses" $+ sort (InsOrd.keys (theOperation ^. OpenApi.responses . OpenApi.responses)) @?= [200, 400],+ testCase "four query parameters in Relay order" $+ map (^. OpenApi.name) inlineParams @?= ["first", "after", "last", "before"],+ testCase "size parameters carry bounds, first carries the default" $ do+ let sizeSchema p = do+ OpenApi.minimum_ `is` Just 0 $ p+ OpenApi.maximum_ `is` Just 100 $ p+ mapM_ (withParam sizeSchema) ["first", "last"]+ withParam (OpenApi.default_ `is` Just (Aeson.Number 10)) "first"+ withParam (OpenApi.default_ `is` Nothing) "last",+ testCase "cursor parameters are base64url strings" $+ mapM_+ ( withParam \s -> do+ OpenApi.type_ `is` Just (OpenApi.OpenApiTypeSingle OpenApi.OpenApiString) $ s+ OpenApi.format `is` Just "base64url" $ s+ )+ ["after", "before"],+ testCase "components hold every envelope schema" $+ sort (InsOrd.keys (toyOpenApi ^. OpenApi.components . OpenApi.schemas))+ @?= ["Connection_Item", "Cursor", "Edge_Item", "Item", "PageInfo", "RelayPageError"],+ testCase "representative Connection Item validates against its schema" $+ OpenApi.validateToJSON exampleConnection @?= [],+ testCase "representative RelayPageError validates against its schema" $+ OpenApi.validateToJSON exampleError @?= []+ ]+ where+ theOperation = case toyOpenApi ^.. OpenApi.allOperations of+ [op] -> op+ ops -> error ("expected exactly one operation, got " <> show (length ops))++ inlineParams =+ [p | OpenApi.Inline p <- theOperation ^. OpenApi.parameters]++ withParam check paramName =+ case [p | p <- inlineParams, p ^. OpenApi.name == paramName] of+ [p] -> case p ^. OpenApi.schema of+ Just (OpenApi.Inline s) -> check s+ other -> assertFailure ("parameter " <> show paramName <> " has no inline schema: " <> show other)+ ps -> assertFailure ("expected one parameter " <> show paramName <> ", got " <> show (length ps))++ is l expected s = s ^. l @?= expected++ exampleConnection :: Connection Item+ exampleConnection =+ Connection+ { edges = [Edge {node = Item {itemId = 1, itemName = "alpha"}, cursor = toyCursor}],+ pageInfo =+ PageInfo+ { hasNextPage = True,+ hasPreviousPage = False,+ startCursor = Just toyCursor,+ endCursor = Just toyCursor+ }+ }++ exampleError :: RelayPageError+ exampleError =+ RelayPageError+ { code = "mixed_pagination_directions",+ message = "cannot combine forward (first/after) and backward (last/before) arguments",+ retryable = False,+ parameter = Just "last"+ }++-- * Helpers++-- | Run the toy app on a free port and hit it with one raw HTTP request, so+-- malformed query strings reach the combinator verbatim.+withToy :: TestName -> Text -> ((Int, ByteString) -> Assertion) -> TestTree+withToy name pathAndQuery check =+ testCase name $+ testWithApplication (pure toyApp) \port -> do+ manager <- HttpClient.newManager HttpClient.defaultManagerSettings+ request <-+ HttpClient.parseRequest+ ("http://127.0.0.1:" <> show port <> Text.unpack pathAndQuery)+ response <- HttpClient.httpLbs request manager+ check+ ( statusCode (HttpClient.responseStatus response),+ HttpClient.responseBody response+ )++decodeOk :: forall a. (Aeson.FromJSON a) => ByteString -> IO a+decodeOk body = case Aeson.eitherDecode body of+ Right a -> pure a+ Left e -> assertFailure ("body did not decode: " <> e <> "\nbody: " <> show body)++firstItem :: Connection Item -> Item+firstItem conn = case edges conn of+ Edge {node} : _ -> node+ [] -> error "expected at least one edge"++assertRelayError :: RelayPageError -> Text -> Maybe Text -> Assertion+assertRelayError err expectedCode expectedParameter = do+ code err @?= expectedCode+ parameter err @?= expectedParameter+ retryable err @?= False