├── .ghci ├── .gitignore ├── .stylish-haskell.yaml ├── .travis.yml ├── .weeder.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── Color.hs ├── Complex.hs └── Simple.hs ├── servant-pagination.cabal ├── src └── Servant │ └── Pagination.hs ├── stack.yaml └── test ├── Servant └── PaginationSpec.hs └── Spec.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set prompt $> 2 | :set -XOverloadedStrings 3 | :set -XTupleSections 4 | :set -XGADTs 5 | :set -XDeriveGeneric 6 | :set -XDeriveDataTypeable 7 | :set -XRecordWildCards 8 | :set -XTypeFamilies 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Created by https://www.gitignore.io/api/haskell 2 | 3 | ### Haskell ### 4 | dist 5 | dist-* 6 | cabal-dev 7 | *.o 8 | *.hi 9 | *.chi 10 | *.chs.h 11 | *.dyn_o 12 | *.dyn_hi 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | *.eventlog 21 | .stack-work/ 22 | cabal.project.local 23 | .HTF/ 24 | stack.yaml.lock 25 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | columns: 100 3 | language_extensions: 4 | - BangPatterns 5 | - ConstraintKinds 6 | - DataKinds 7 | - DefaultSignatures 8 | - DeriveDataTypeable 9 | - DeriveFunctor 10 | - DeriveGeneric 11 | - ExistentialQuantification 12 | - FlexibleContexts 13 | - FlexibleInstances 14 | - GADTs 15 | - KindSignatures 16 | - MultiParamTypeClasses 17 | - OverloadedStrings 18 | - ParallelListComp 19 | - RecordWildCards 20 | - ScopedTypeVariables 21 | - TupleSections 22 | - TypeApplications 23 | - TypeFamilies 24 | - TypeOperators 25 | steps: 26 | - simple_align: 27 | cases: true 28 | top_level_patterns: true 29 | records: true 30 | 31 | - imports: 32 | align: global 33 | list_align: after_alias 34 | pad_module_names: true 35 | long_list_align: inline 36 | empty_list_align: inherit 37 | list_padding: 4 38 | separate_lists: true 39 | space_surround: false 40 | 41 | - language_pragmas: 42 | style: vertical 43 | align: true 44 | remove_redundant: true 45 | 46 | - trailing_whitespace: {} 47 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | language: generic 4 | 5 | cache: 6 | timeout: 1337 7 | directories: 8 | - $HOME/.stack 9 | - $HOME/.local 10 | - $HOME/.ghc 11 | 12 | branches: 13 | only: 14 | - master 15 | 16 | env: 17 | global: 18 | - PATH=$HOME/.local/bin:$PATH 19 | 20 | stages: 21 | - action 22 | 23 | before_install: 24 | - mkdir -p $HOME/.local/bin 25 | - travis_retry curl -L -k https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 26 | 27 | install: 28 | - travis_wait 42 stack --no-terminal --install-ghc build --fast --only-dependencies 29 | 30 | jobs: 31 | include: 32 | - stage: action 33 | env: ACTION=hlint 34 | scripts: 35 | - travis_wait 42 stack --no-terminal install hlint 36 | - travis_wait 42 stack --no-terminal exec hlint -- . --cpp-define=__GLASGOW_HASKELL__=800 --cpp-define=x86_64_HOST_ARCH=1 --cpp-define=mingw32_HOST_OS=1 37 | 38 | - stage: action 39 | env: ACTION=weeder 40 | script: 41 | - travis_wait 42 stack --no-terminal test --no-run-tests --fast --flag servant-pagination:examples 42 | - curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/travis.sh | sh -s . 43 | 44 | - stage: action 45 | env: ACTION=tests 46 | script: 47 | - travis_wait 42 stack --no-terminal test --fast --coverage 48 | -------------------------------------------------------------------------------- /.weeder.yaml: -------------------------------------------------------------------------------- 1 | - package: 2 | - name: '' 3 | - section: 4 | - name: exe:servant-pagination-complex exe:servant-pagination-simple 5 | - message: 6 | - name: Module reused between components 7 | - module: Color 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | ## Unreleased 4 | 5 | - Move header logic to a pure addPageHeaders function #21 6 | 7 | ## v2.5.1 (2023-12-13) 8 | 9 | - Bump `servant`, `servant-server`, `text` versions (see [#24](https://github.com/chordify/haskell-servant-pagination/pull/24)). 10 | 11 | ## v2.5.0 (2022-03-09) 12 | - Allow text-2.0 and servant-0.19 #20 13 | - Expose PutRange so we can use this in integrations #18 14 | 15 | ## v2.4.2 (2021-12-10) 16 | - Don't return Next-Range upon partial response 17 | 18 | ## v2.4.1 (2021-10-11) 19 | - Fix Travis CI 20 | 21 | ## v2.4.0 (2021-10-11) 22 | - Update servant package bounds 23 | - Forbid negative values for limit 24 | 25 | ## v2.3.0 (2020-03-05) 26 | 27 | - Allow server-0.17 in executables 28 | - Bump stack LTS to 14.25 29 | 30 | ## v2.2.2 (2019-02-28) 31 | 32 | - (oversight) Allow server-0.16 in executables 33 | 34 | 35 | ## v2.2.1 (2019-02-28) 36 | 37 | - Allow server-0.16 38 | 39 | 40 | ## v2.2.0 (2019-01-28) 41 | 42 | - Use URL encoding for range values to properly support strings. 43 | 44 | 45 | ## v2.1.3 (2018-11-14) 46 | 47 | - Fix Haddock generation 48 | 49 | 50 | ## v2.1.2 (2018-11-13) 51 | 52 | - Allow servant-0.15 53 | 54 | 55 | ## v2.1.1 (2018-07-10) 56 | 57 | - Allow servant-0.14 58 | 59 | 60 | ## v2.1.0 (2018-04-16) 61 | 62 | - Add some tests (QuickCheck round-up & control some Ranges parsing) 63 | - Add `Show` and `Eq` instances for Ranges 64 | - Expose `putRange` function 65 | - Review `getDefaultRange` signature (remove Maybe argument) 66 | 67 | 68 | ## v2.0.0 (2018-04-06) 69 | 70 | - Review internal implementation and public API (ditch Range combinator to favor type-level 71 | list and more discrete footprint). 72 | 73 | - Remove 'Total-Count' header, can still be added on top of the range headers but isn't a Range 74 | header so to speak. 75 | 76 | - Extend haddock documentation to be more user-friendly 77 | 78 | 79 | ## v1.0.0 (2018-02-06) 80 | 81 | - Initial release 82 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-pagination [![](https://img.shields.io/hackage/v/servant-pagination.svg)](https://hackage.haskell.org/package/servant-pagination) [![Build Status](https://travis-ci.com/chordify/haskell-servant-pagination.svg?branch=master)](https://app.travis-ci.com/github/chordify/haskell-servant-pagination) 2 | 3 | ## Overview 4 | 5 | This module offers opinionated helpers to declare a type-safe and a flexible pagination 6 | mechanism for Servant APIs. This design, inspired by [Heroku's API](https://devcenter.heroku.com/articles/platform-api-reference#ranges), 7 | provides a small framework to communicate about a possible pagination feature of an endpoint, 8 | enabling a client to consume the API in different fashions (pagination with offset / limit, 9 | endless scroll using last referenced resources, ascending and descending ordering, etc.) 10 | 11 | Therefore, client can provide a `Range` header with their request with the following format: 12 | 13 | - `Range: [][; offset ][; limit ][; order ]` 14 | 15 | For example: `Range: createdAt 2017-01-15T23%3A14%3A67.000Z; offset 5; order desc` indicates that 16 | the client is willing to retrieve the next batch of document in descending order that were 17 | created after the fifteenth of January, skipping the first 5. 18 | 19 | As a response, the server may return the list of corresponding document, and augment the 20 | response with 3 headers: 21 | 22 | - `Accept-Ranges`: A comma-separated list of fields upon which a range can be defined 23 | - `Content-Range`: Actual range corresponding to the content being returned 24 | - `Next-Range`: Indicate what should be the next `Range` header in order to retrieve the next range 25 | 26 | For example: 27 | 28 | - `Accept-Ranges: createdAt, modifiedAt` 29 | - `Content-Range: createdAt 2017-01-15T23%3A14%3A51.000Z..2017-02-18T06%3A10%3A23.000Z` 30 | - `Next-Range: createdAt 2017-02-19T12%3A56%3A28.000Z; offset 0; limit 100; order desc` 31 | 32 | 33 | ## Getting Started 34 | 35 | Code-wise the integration is quite seamless and unobtrusive. `servant-pagination` provides a 36 | `Ranges (fields :: [Symbol]) (resource :: *) -> *` data-type for declaring available ranges 37 | on a group of _fields_ and a target _resource_. To each combination (resource + field) is 38 | associated a given type `RangeType (resource :: *) (field :: Symbol) -> *` as described by 39 | the type-family in the `HasPagination` type-class. 40 | 41 | So, let's start with some imports and extensions to get this out of the way: 42 | 43 | ```hs 44 | {-# LANGUAGE DataKinds #-} 45 | {-# LANGUAGE DeriveGeneric #-} 46 | {-# LANGUAGE FlexibleInstances #-} 47 | {-# LANGUAGE MultiParamTypeClasses #-} 48 | {-# LANGUAGE TypeApplications #-} 49 | {-# LANGUAGE TypeFamilies #-} 50 | {-# LANGUAGE TypeOperators #-} 51 | 52 | import Data.Aeson (ToJSON, genericToJSON) 53 | import Data.Maybe (fromMaybe) 54 | import Data.Proxy (Proxy (..)) 55 | import GHC.Generics (Generic) 56 | import Servant ((:>), GetPartialContent, Handler, Header, Headers, JSON, Server) 57 | import Servant.Pagination (HasPagination (..), PageHeaders, Range (..), Ranges, applyRange) 58 | 59 | import qualified Data.Aeson as Aeson 60 | import qualified Network.Wai.Handler.Warp as Warp 61 | import qualified Servant.Pagination as Pagination 62 | import qualified Servant 63 | ``` 64 | 65 | 66 | #### Declaring the Resource 67 | 68 | Servant APIs are rather resource-oriented, and so is `servant-pagination`. This 69 | guide shows a basic example working with `JSON` (as you could tell from the 70 | import list already). To make the world a better colored place, let's create an API to retrieve 72 | colors -- with pagination. 73 | 74 | ```hs 75 | data Color = Color 76 | { name :: String 77 | , rgb :: [Int] 78 | , hex :: String 79 | } deriving (Eq, Show, Generic) 80 | 81 | instance ToJSON Color where 82 | toJSON = 83 | genericToJSON Aeson.defaultOptions 84 | 85 | colors :: [Color] 86 | colors = 87 | [ Color "Black" [0, 0, 0] "#000000" 88 | , Color "Blue" [0, 0, 255] "#0000ff" 89 | , Color "Green" [0, 128, 0] "#008000" 90 | , Color "Grey" [128, 128, 128] "#808080" 91 | , Color "Purple" [128, 0, 128] "#800080" 92 | , Color "Red" [255, 0, 0] "#ff0000" 93 | , Color "Yellow" [255, 255, 0] "#ffff00" 94 | ] 95 | ``` 96 | 97 | #### Declaring the Ranges 98 | 99 | Now that we have defined our _resource_ (a.k.a `Color`), we are ready to declare a new `Range` 100 | that will operate on a "name" field (genuinely named after the `name` fields from the `Color` 101 | record). 102 | For that, we need to tell `servant-pagination` two things: 103 | 104 | - What is the type of the corresponding `Range` values 105 | - How do we get one of these values from our resource 106 | 107 | This is done via defining an instance of `HasPagination` as follows: 108 | 109 | ```hs 110 | instance HasPagination Color "name" where 111 | type RangeType Color "name" = String 112 | getFieldValue _ = name 113 | -- getRangeOptions :: Proxy "name" -> Proxy Color -> RangeOptions 114 | -- getDefaultRange :: Proxy Color -> Range "name" String 115 | 116 | defaultRange :: Range "name" String 117 | defaultRange = 118 | getDefaultRange (Proxy @Color) 119 | ``` 120 | 121 | Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definintion 122 | of the class. Yet, you can define `getRangeOptions` to provide different parsing options (see 123 | the last section of this guide). In the meantime, we've also defined a `defaultRange` as it will 124 | come in handy when defining our handler. 125 | 126 | #### API 127 | 128 | Good, we have a resource, we have a `Range` working on that resource, we can now declare our 129 | API using other Servant combinators we already know: 130 | 131 | ```hs 132 | type API = 133 | "colors" 134 | :> Header "Range" (Ranges '["name"] Color) 135 | :> GetPartialContent '[JSON] (Headers MyHeaders [Color]) 136 | 137 | type MyHeaders = 138 | Header "Total-Count" Int ': PageHeaders '["name"] Color 139 | ``` 140 | 141 | `PageHeaders` is a type alias provided by the library to declare the necessary response headers 142 | we mentionned in introduction. Expanding the alias boils down to the following: 143 | 144 | ```hs 145 | -- type MyHeaders 146 | -- = Header "Total-Count" Int 147 | -- :> Header "Accept-Ranges" (AcceptRanges '["name"]) 148 | -- :> Header "Content-Range" (ContentRange '["name"] Color) 149 | -- :> Header "Next-Range" (Ranges '["name"] Color) 150 | ``` 151 | 152 | As a result, we will need to provide all those headers with the response in our handler. Worry 153 | not, _servant-pagination_ provides an easy way to lift a collection of resources into such handler. 154 | 155 | #### Server 156 | 157 | Time to connect the last bits by defining the server implementation of our colorful API. The `Ranges` 158 | type we've defined above (tight to the `Range` HTTP header) indicates the server to parse any `Range` 159 | header, looking for the format defined in introduction with fields and target types we have just declared. 160 | If no such header is provided, we will end up receiving `Nothing`. Otherwise, it will be possible 161 | to _extract_ a `Range` from our `Ranges`. 162 | 163 | ```hs 164 | server :: Server API 165 | server = handler 166 | where 167 | handler :: Maybe (Ranges '["name"] Color) -> Handler (Headers MyHeaders [Color]) 168 | handler mrange = do 169 | let range = 170 | fromMaybe defaultRange (mrange >>= extractRange) 171 | 172 | addHeader (length colors) <$> returnRange range (applyRange range colors) 173 | 174 | main :: IO () 175 | main = 176 | Warp.run 1442 $ Servant.serve (Proxy @API) server 177 | ``` 178 | 179 | Let's try it out using different ranges to observe the server's behavior. As a reminder, here's 180 | the format we defined, where `` here can only be `name` and `` must parse to a `String`: 181 | 182 | - `Range: [][; offset ][; limit ][; order ]` 183 | 184 | Beside the target field, everything is pretty much optional in the `Range` HTTP header. Missing parts 185 | are deducted from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all 186 | following examples are valid requests to send to our server: 187 | 188 | - 1 - `curl http://localhost:1442/colors -vH 'Range: name'` 189 | - 2 - `curl http://localhost:1442/colors -vH 'Range: name; limit 2'` 190 | - 3 - `curl http://localhost:1442/colors -vH 'Range: name Green; order asc; offset 1'` 191 | 192 | Considering the following default options: 193 | 194 | - `defaultRangeLimit: 100` 195 | - `defaultRangeOffset: 0` 196 | - `defaultRangeOrder: RangeDesc` 197 | 198 | The previous ranges reads as follows: 199 | 200 | - 1 - The first 100 colors, ordered by descending names 201 | - 2 - The first 2 colors, ordered by descending names 202 | - 3 - The 100 colors after `Green` (not included), ordered by ascending names. 203 | 204 | > See `examples/Simple.hs` for a running version of this guide. 205 | 206 | ## Going Forward 207 | 208 | #### Multiple Ranges 209 | 210 | Note that in the simple above scenario, there's no ambiguity with `extractRange` and `returnRange` 211 | because there's only one possible `Range` defined on our resource. Yet, as you've most probably 212 | noticed, the `Ranges` combinator accepts a list of fields, each of which must declare a `HasPagination` 213 | instance. Doing so will make the other helper functions more ambiguous and type annotation are 214 | highly likely to be needed. 215 | 216 | 217 | ```hs 218 | instance HasPagination Color "hex" where 219 | type RangeType Color "hex" = String 220 | getFieldValue _ = hex 221 | 222 | -- to then define: Ranges '["name", "hex"] Color 223 | ``` 224 | 225 | > See `examples/Complex.hs` for more complex examples. 226 | 227 | 228 | #### Parsing Options 229 | 230 | By default, `servant-pagination` provides an implementation of `getRangeOptions` for each 231 | `HasPagination` type-class. However, this can be overwritten when defining a instance of that 232 | class to provide your own options. This options come into play when a `Range` header is 233 | received and isn't fully specified (`limit`, `offset`, `order` are all optional) to provide 234 | default fallback values for those. 235 | 236 | For instance, let's say we wanted to change the default limit to `5` in a new range on 237 | `"rgb"`, we could tweak the corresponding `HasPagination` instance as follows: 238 | 239 | ```hs 240 | instance HasPagination Color "rgb" where 241 | type RangeType Color "rgb" = String 242 | getFieldValue _ = sum . rgb 243 | getRangeOptions _ _ = defaultOptions { defaultRangeLimit = 5 } 244 | ``` 245 | 246 | ## Changelog 247 | 248 | [CHANGELOG.md](CHANGELOG.md) 249 | 250 | 251 | ## License 252 | 253 | [LGPL-3 © 2018 Chordify](LICENSE) 254 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | 4 | main = 5 | defaultMain 6 | -------------------------------------------------------------------------------- /examples/Color.hs: -------------------------------------------------------------------------------- 1 | module Color where 2 | 3 | import Data.Aeson (ToJSON) 4 | import GHC.Generics (Generic) 5 | 6 | import qualified Data.Aeson as Aeson 7 | 8 | 9 | data Color = Color 10 | { name :: String 11 | , rgb :: [Int] 12 | , hex :: String 13 | } deriving (Eq, Show, Generic) 14 | 15 | 16 | instance ToJSON Color where 17 | toJSON = 18 | Aeson.genericToJSON Aeson.defaultOptions 19 | 20 | 21 | colors :: [Color] 22 | colors = 23 | [ Color "Aqua" [0, 255, 255] "#00ffff" 24 | , Color "Black" [0, 0, 0] "#000000" 25 | , Color "Blue" [0, 0, 255] "#0000ff" 26 | , Color "BlueViolet" [95, 0, 255] "#5f00ff" 27 | , Color "CadetBlue" [95, 175, 135] "#5faf87" 28 | , Color "CadetBlue" [95, 175, 175] "#5fafaf" 29 | , Color "CornflowerBlue" [95, 135, 255] "#5f87ff" 30 | , Color "DarkBlue" [0, 0, 135] "#000087" 31 | , Color "DarkCyan" [0, 175, 135] "#00af87" 32 | , Color "DarkGoldenrod" [175, 135, 0] "#af8700" 33 | , Color "DarkGreen" [0, 95, 0] "#005f00" 34 | , Color "DarkKhaki" [175, 175, 95] "#afaf5f" 35 | , Color "DarkMagenta" [135, 0, 135] "#870087" 36 | , Color "DarkMagenta" [135, 0, 175] "#8700af" 37 | , Color "DarkOrange" [255, 135, 0] "#ff8700" 38 | , Color "DarkRed" [135, 0, 0] "#870000" 39 | , Color "DarkRed" [95, 0, 0] "#5f0000" 40 | , Color "DarkSeaGreen" [135, 175, 135] "#87af87" 41 | , Color "DarkTurquoise" [0, 215, 215] "#00d7d7" 42 | , Color "DarkViolet" [135, 0, 215] "#8700d7" 43 | , Color "DarkViolet" [175, 0, 215] "#af00d7" 44 | , Color "Fuchsia" [255, 0, 255] "#ff00ff" 45 | , Color "Green" [0, 128, 0] "#008000" 46 | , Color "GreenYellow" [175, 255, 0] "#afff00" 47 | , Color "Grey" [128, 128, 128] "#808080" 48 | , Color "HotPink" [255, 95, 175] "#ff5faf" 49 | , Color "HotPink" [255, 95, 215] "#ff5fd7" 50 | , Color "IndianRed" [175, 95, 95] "#af5f5f" 51 | , Color "IndianRed" [215, 95, 95] "#d75f5f" 52 | , Color "LightCoral" [255, 135, 135] "#ff8787" 53 | , Color "LightGreen" [135, 255, 135] "#87ff87" 54 | , Color "LightGreen" [135, 255, 95] "#87ff5f" 55 | , Color "LightSeaGreen" [0, 175, 175] "#00afaf" 56 | , Color "LightSlateBlue" [135, 135, 255] "#8787ff" 57 | , Color "LightSlateGrey" [135, 135, 175] "#8787af" 58 | , Color "LightSteelBlue" [175, 175, 255] "#afafff" 59 | , Color "Lime" [0, 255, 0] "#00ff00" 60 | , Color "Maroon" [128, 0, 0] "#800000" 61 | , Color "MediumOrchid" [175, 95, 215] "#af5fd7" 62 | , Color "MediumPurple" [135, 135, 215] "#8787d7" 63 | , Color "MediumSpringGreen" [0, 255, 175] "#00ffaf" 64 | , Color "MediumTurquoise" [95, 215, 215] "#5fd7d7" 65 | , Color "MediumVioletRed" [175, 0, 135] "#af0087" 66 | , Color "Navy" [0, 0, 128] "#000080" 67 | , Color "NavyBlue" [0, 0, 95] "#00005f" 68 | , Color "Olive" [128, 128, 0] "#808000" 69 | , Color "Orchid" [215, 95, 215] "#d75fd7" 70 | , Color "Purple" [128, 0, 128] "#800080" 71 | , Color "Purple" [135, 0, 255] "#8700ff" 72 | , Color "Purple" [175, 0, 255] "#af00ff" 73 | , Color "Red" [255, 0, 0] "#ff0000" 74 | , Color "RosyBrown" [175, 135, 135] "#af8787" 75 | , Color "SandyBrown" [255, 175, 95] "#ffaf5f" 76 | , Color "Silver" [192, 192, 192] "#c0c0c0" 77 | , Color "Tan" [215, 175, 135] "#d7af87" 78 | , Color "Teal" [0, 128, 128] "#008080" 79 | , Color "Violet" [215, 135, 255] "#d787ff" 80 | , Color "White" [255, 255, 255] "#ffffff" 81 | , Color "Yellow" [255, 255, 0] "#ffff00" 82 | ] 83 | -------------------------------------------------------------------------------- /examples/Complex.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Main where 6 | 7 | import Control.Applicative ((<|>)) 8 | import Data.Maybe (fromMaybe) 9 | import Data.Proxy (Proxy (..)) 10 | import Servant 11 | import Servant.Pagination 12 | 13 | import qualified Data.Char as Char 14 | import qualified Network.Wai.Handler.Warp as Warp 15 | 16 | import Color 17 | 18 | 19 | -- Ranges definitions 20 | 21 | -- By default, a Range relies on `defaultOptions` but any instance can define its own options 22 | instance HasPagination Color "name" where 23 | type RangeType Color "name" = String 24 | getFieldValue _ = name 25 | getRangeOptions _ _ = defaultOptions 26 | { defaultRangeLimit = 5 27 | , defaultRangeOrder = RangeAsc 28 | } 29 | 30 | -- We can declare more than one range on a given type if they use different symbol field 31 | instance HasPagination Color "hex" where 32 | type RangeType Color "hex" = String 33 | getFieldValue _ = map Char.toUpper . hex 34 | 35 | instance HasPagination Color "rgb" where 36 | type RangeType Color "rgb" = Int 37 | getFieldValue _ = sum . rgb 38 | 39 | 40 | -- API 41 | 42 | type API = 43 | "colors" 44 | :> Header "Range" (Ranges '["name", "rgb", "hex"] Color) 45 | :> GetPartialContent '[JSON] (Headers MyHeaders [Color]) 46 | 47 | -- PageHeaders fields resource ~ '[Header h typ], thus we can add extra headers 48 | -- as we desire. 49 | type MyHeaders = 50 | Header "Total-Count" Int ': PageHeaders '["name", "rgb", "hex"] Color 51 | 52 | 53 | -- Application 54 | 55 | defaultRange :: Range "name" String 56 | defaultRange = 57 | getDefaultRange (Proxy @Color) 58 | 59 | server :: Server API 60 | server mrange = 61 | addHeader (length colors) <$> handler mrange 62 | where 63 | -- 'extractRange' tries to extract a range if it has the right type, and yields 'Nothing' 64 | -- otherwise. We can use the '<|>' alternative combinator to try handlers one after 65 | -- the other 66 | handler r = 67 | fromMaybe (returnNameRange defaultRange) $ 68 | fmap returnNameRange (r >>= extractRange) 69 | <|> fmap returnRGBRange (r >>= extractRange) 70 | <|> fmap returnHexRange (r >>= extractRange) 71 | 72 | -- Handlers below are very simple, in practice, they're likely to trigger different functions 73 | -- or database calls. 74 | returnNameRange (range :: Range "name" String) = 75 | returnRange range (applyRange range colors) 76 | 77 | returnRGBRange (range :: Range "rgb" Int) = 78 | returnRange range (applyRange range colors) 79 | 80 | returnHexRange (range :: Range "hex" String) = 81 | returnRange range (applyRange range colors) 82 | 83 | 84 | main :: IO () 85 | main = 86 | Warp.run 1337 (serve (Proxy @API) server) 87 | 88 | 89 | -- Examples 90 | 91 | -- $ curl -v http://localhost:1337/colors 92 | -- 93 | -- > GET /colors HTTP/1.1 94 | -- 95 | -- < HTTP/1.1 206 Partial Content 96 | -- < Content-Type: application/json;charset=utf-8 97 | -- < Accept-Ranges: name,rgb 98 | -- < Content-Range: name Aqua..CadetBlue 99 | -- < Next-Range: name CadetBlue;limit 5;offset 1;order asc 100 | -- < Total-Count: 59 101 | 102 | 103 | -- $ curl -v http://localhost:1337/colors --header 'Range: rgb' 104 | -- 105 | -- > GET /colors HTTP/1.1 106 | -- > Range: rgb 107 | -- 108 | -- < HTTP/1.1 206 Partial Content 109 | -- < Content-Type: application/json;charset=utf-8 110 | -- < Accept-Ranges: name,rgb 111 | -- < Content-Range: rgb 765..0 112 | -- < Next-Range: rgb 0;limit 100;offset 1;order desc 113 | -- < Total-Count: 59 114 | 115 | 116 | -- $ curl -v http://localhost:1337/colors --header 'Range: name Green; limit 10; order desc' 117 | -- 118 | -- > Get /colors HTTP/1.1 119 | -- > Range: name; limit 10; order desc 120 | -- > 121 | -- < HTTP/1.1 206 Partial Content 122 | -- < Content-Type: application/json;charset=utf-8 123 | -- < Accept-Ranges: name,rgb 124 | -- < Content-Range: name Green..DarkMagenta 125 | -- < Next-Range: name DarkMagenta;limit 10;offset 1;order desc 126 | -- < Total-Count: 59 127 | -------------------------------------------------------------------------------- /examples/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Main where 6 | 7 | import Data.Maybe (fromMaybe) 8 | import Data.Proxy (Proxy (..)) 9 | import Servant 10 | import Servant.Pagination 11 | 12 | import qualified Network.Wai.Handler.Warp as Warp 13 | 14 | import Color 15 | 16 | 17 | -- Ranges definitions 18 | 19 | instance HasPagination Color "name" where 20 | type RangeType Color "name" = String 21 | getFieldValue _ = name 22 | 23 | -- API 24 | 25 | type API = 26 | "colors" 27 | :> Header "Range" (Ranges '["name"] Color) 28 | :> GetPartialContent '[JSON] (Headers (PageHeaders '["name"] Color) [Color]) 29 | 30 | 31 | -- Application 32 | 33 | defaultRange :: Range "name" String 34 | defaultRange = 35 | getDefaultRange (Proxy @Color) 36 | 37 | server :: Server API 38 | server mrange = do 39 | let range = 40 | fromMaybe defaultRange (mrange >>= extractRange) 41 | 42 | returnRange range (applyRange range colors) 43 | 44 | main :: IO () 45 | main = 46 | Warp.run 1337 (serve (Proxy :: Proxy API) server) 47 | 48 | 49 | -- Examples 50 | 51 | -- $ curl -v http://localhost:1337/colors 52 | -- 53 | -- > GET /colors HTTP/1.1 54 | -- > Host: localhost:1337 55 | -- > User-Agent: curl/7.47.0 56 | -- > Accept: */* 57 | -- > 58 | -- < HTTP/1.1 206 Partial Content 59 | -- < Transfer-Encoding: chunked 60 | -- < Date: Tue, 30 Jan 2018 12:45:17 GMT 61 | -- < Server: Warp/3.2.13 62 | -- < Content-Type: application/json;charset=utf-8 63 | -- < Accept-Ranges: name 64 | -- < Content-Range: name Yellow..Aqua 65 | -- < Next-Range: name Aqua;limit 100;offset 1;order desc 66 | 67 | 68 | -- $ curl -v http://localhost:1337/colors --header 'Range: name; offset 59' 69 | -- 70 | -- > GET /colors HTTP/1.1 71 | -- > Range: name; offset 59 72 | -- > 73 | -- < HTTP/1.1 206 Partial Content 74 | -- < Content-Type: application/json;charset=utf-8 75 | -- < Accept-Ranges: name 76 | -------------------------------------------------------------------------------- /servant-pagination.cabal: -------------------------------------------------------------------------------- 1 | name: 2 | servant-pagination 3 | synopsis: 4 | Type-safe pagination for Servant APIs 5 | description: 6 | This module offers opinionated helpers to declare a type-safe and a 7 | flexible pagination mecanism for Servant APIs. This design, inspired by 8 | Heroku's API, provides a small framework to communicate about a possible 9 | pagination feature of an endpoint, enabling a client to consume the API in 10 | different fashions (pagination with offset / limit, endless scroll using 11 | last referenced resources, ascending and descending ordering, etc.) 12 | version: 13 | 2.5.1 14 | homepage: 15 | https://github.com/chordify/haskell-servant-pagination 16 | bug-reports: 17 | https://github.com/chordify/haskell-servant-pagination/issues 18 | license: 19 | LGPL-3 20 | license-file: 21 | LICENSE 22 | author: 23 | Chordify 24 | maintainer: 25 | Chordify 26 | Matthias Benkort 27 | copyright: 28 | (c) 2018-2020 Chordify 29 | category: 30 | Web 31 | build-type: 32 | Simple 33 | cabal-version: 34 | 1.20 35 | extra-source-files: 36 | README.md 37 | CHANGELOG.md 38 | stack.yaml 39 | Setup.hs 40 | .stylish-haskell.yaml 41 | 42 | source-repository head 43 | type: 44 | git 45 | location: 46 | git://github.com/chordify/haskell-servant-pagination.git 47 | 48 | flag examples 49 | description: 50 | build examples executables 51 | default: 52 | False 53 | manual: 54 | True 55 | 56 | 57 | library 58 | default-language: 59 | Haskell2010 60 | ghc-options: 61 | -Wall 62 | default-extensions: 63 | BangPatterns 64 | , ConstraintKinds 65 | , DataKinds 66 | , DefaultSignatures 67 | , DeriveDataTypeable 68 | , DeriveFunctor 69 | , DeriveGeneric 70 | , ExistentialQuantification 71 | , FlexibleContexts 72 | , FlexibleInstances 73 | , GADTs 74 | , KindSignatures 75 | , MultiParamTypeClasses 76 | , OverloadedStrings 77 | , ParallelListComp 78 | , ScopedTypeVariables 79 | , TupleSections 80 | , TypeFamilies 81 | , TypeOperators 82 | , UndecidableInstances 83 | 84 | build-depends: 85 | base >= 4 && < 5 86 | , text >= 1.2 && < 2.2 87 | , servant >= 0.11 && < 0.21 88 | , servant-server >= 0.11 && < 0.21 89 | , safe >= 0.3 && < 1 90 | , uri-encode >= 1.5 && < 1.6 91 | 92 | hs-source-dirs: 93 | src 94 | exposed-modules: 95 | Servant.Pagination 96 | 97 | 98 | executable servant-pagination-simple 99 | if !flag(examples) 100 | buildable: False 101 | 102 | default-language: 103 | Haskell2010 104 | ghc-options: 105 | -Wall 106 | -threaded 107 | -rtsopts 108 | -with-rtsopts=-N 109 | default-extensions: 110 | BangPatterns 111 | , ConstraintKinds 112 | , DataKinds 113 | , DefaultSignatures 114 | , DeriveDataTypeable 115 | , DeriveFunctor 116 | , DeriveGeneric 117 | , ExistentialQuantification 118 | , FlexibleContexts 119 | , FlexibleInstances 120 | , GADTs 121 | , KindSignatures 122 | , MultiParamTypeClasses 123 | , OverloadedStrings 124 | , ParallelListComp 125 | , ScopedTypeVariables 126 | , TupleSections 127 | , TypeFamilies 128 | , TypeOperators 129 | 130 | build-depends: 131 | base >= 4 && < 5 132 | , aeson >= 1.2 && < 2 133 | , servant >= 0.11 && < 0.19 134 | , servant-pagination 135 | , servant-server >= 0.11 && < 0.19 136 | , warp >= 3.2 && < 4 137 | 138 | hs-source-dirs: 139 | examples 140 | main-is: 141 | Simple.hs 142 | other-modules: 143 | Color 144 | 145 | 146 | executable servant-pagination-complex 147 | if !flag(examples) 148 | buildable: False 149 | 150 | default-language: 151 | Haskell2010 152 | ghc-options: 153 | -Wall 154 | -threaded 155 | -rtsopts 156 | -with-rtsopts=-N 157 | default-extensions: 158 | BangPatterns 159 | , ConstraintKinds 160 | , DataKinds 161 | , DefaultSignatures 162 | , DeriveDataTypeable 163 | , DeriveFunctor 164 | , DeriveGeneric 165 | , ExistentialQuantification 166 | , FlexibleContexts 167 | , FlexibleInstances 168 | , GADTs 169 | , KindSignatures 170 | , MultiParamTypeClasses 171 | , OverloadedStrings 172 | , ParallelListComp 173 | , ScopedTypeVariables 174 | , TupleSections 175 | , TypeFamilies 176 | , TypeOperators 177 | 178 | build-depends: 179 | base >= 4 && < 5 180 | , aeson >= 1.2 && < 2 181 | , servant >= 0.11 && < 0.19 182 | , servant-pagination 183 | , servant-server >= 0.11 && < 0.19 184 | , warp >= 3.2 && < 4 185 | 186 | hs-source-dirs: 187 | examples 188 | main-is: 189 | Complex.hs 190 | other-modules: 191 | Color 192 | 193 | 194 | test-suite servant-pagination-test 195 | type: 196 | exitcode-stdio-1.0 197 | default-language: 198 | Haskell2010 199 | ghc-options: 200 | -Wall 201 | default-extensions: 202 | BangPatterns 203 | , ConstraintKinds 204 | , DataKinds 205 | , DefaultSignatures 206 | , DeriveDataTypeable 207 | , DeriveFunctor 208 | , DeriveGeneric 209 | , ExistentialQuantification 210 | , FlexibleContexts 211 | , FlexibleInstances 212 | , GADTs 213 | , KindSignatures 214 | , MultiParamTypeClasses 215 | , OverloadedStrings 216 | , ParallelListComp 217 | , ScopedTypeVariables 218 | , TupleSections 219 | , TypeFamilies 220 | , TypeOperators 221 | 222 | build-depends: 223 | base 224 | , hspec 225 | , QuickCheck 226 | , servant-pagination 227 | , servant-server 228 | , text 229 | 230 | hs-source-dirs: 231 | test 232 | main-is: 233 | Spec.hs 234 | other-modules: 235 | Servant.PaginationSpec 236 | -------------------------------------------------------------------------------- /src/Servant/Pagination.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- | Opinionated Pagination Helpers for Servant APIs 5 | -- 6 | -- 7 | -- Client can provide a `Range` header with their request with the following format 8 | -- 9 | -- > Range: [][; offset ][; limit ][; order ] 10 | -- 11 | -- Available ranges are declared using type-level list of accepted fields, bound to a given 12 | -- resource and type using the 'HasPagination' type-class. The library provides unobtrusive 13 | -- types and abstract away all the plumbing to hook that on an existing Servant API. 14 | -- 15 | -- The 'IsRangeType' constraints summarize all constraints that must apply to a possible field 16 | -- and heavily rely on the 'Web.Internal.FromHttpApiData' and 'Web.Internal.ToHttpApiData'. 17 | -- 18 | -- > $ curl -v http://localhost:1337/colors -H 'Range: name; limit 10' 19 | -- > 20 | -- > > GET /colors HTTP/1.1 21 | -- > > Host: localhost:1337 22 | -- > > User-Agent: curl/7.47.0 23 | -- > > Accept: */* 24 | -- > > 25 | -- > < HTTP/1.1 206 Partial Content 26 | -- > < Transfer-Encoding: chunked 27 | -- > < Date: Tue, 30 Jan 2018 12:45:17 GMT 28 | -- > < Server: Warp/3.2.13 29 | -- > < Content-Type: application/json;charset=utf-8 30 | -- > < Accept-Ranges: name 31 | -- > < Content-Range: name Yellow..Purple 32 | -- > < Next-Range: name Purple;limit 10;offset 1;order desc 33 | -- 34 | -- The 'Range' header is totally optional, but when provided, it indicates to the server what 35 | -- parts of the collection is requested. As a reponse and in addition to the data, the server may 36 | -- provide 3 headers to the client: 37 | -- 38 | -- - @Accept-Ranges@: A comma-separated list of field upon which a range can be defined 39 | -- - @Content-Range@: Actual range corresponding to the content being returned 40 | -- - @Next-Range@: Indicate what should be the next `Range` header in order to retrieve the next range 41 | -- 42 | -- This allows the client to work in a very _dumb_ mode where it simply consumes data from the server 43 | -- using the value of the 'Next-Range' header to fetch each new batch of data. The 'Accept-Ranges' 44 | -- comes in handy to self-document the API telling the client about the available filtering and sorting options 45 | -- of a resource. 46 | -- 47 | -- Here's a minimal example used to obtained the previous behavior; Most of the magic happens in the 48 | -- 'returnRange' function which lift a collection of resources into a Servant handler, computing the 49 | -- corresponding ranges from the range used to retrieve the resources. 50 | -- 51 | -- @ 52 | -- -- Resource Type 53 | -- 54 | -- data Color = Color 55 | -- { name :: 'String' 56 | -- , rgb :: ['Int'] 57 | -- , hex :: 'String' 58 | -- } deriving ('Eq', 'Show', 'GHC.Generics.Generic') 59 | -- 60 | -- colors :: [Color] 61 | -- colors = [ {- ... -} ] 62 | -- 63 | -- -- Ranges definitions 64 | -- 65 | -- instance 'HasPagination' Color "name" where 66 | -- type 'RangeType' Color "name" = 'String' 67 | -- 'getFieldValue' _ = name 68 | -- 69 | -- 70 | -- -- API 71 | -- 72 | -- type API = 73 | -- "colors" 74 | -- :> 'Servant.Header' \"Range\" ('Ranges' '["name"] Color) 75 | -- :> 'Servant.GetPartialContent' '['Servant.JSON'] ('Servant.Headers' ('PageHeaders' '["name"] Color) [Color]) 76 | -- 77 | -- 78 | -- -- Application 79 | -- 80 | -- defaultRange :: 'Range' "name" 'String' 81 | -- defaultRange = 82 | -- 'getDefaultRange' ('Data.Proxy.Proxy' \@Color) 83 | -- 84 | -- server :: 'Servant.Server.Server' API 85 | -- server mrange = do 86 | -- let range = 87 | -- 'Data.Maybe.fromMaybe' defaultRange (mrange >>= 'extractRange') 88 | -- 89 | -- 'returnRange' range ('applyRange' range colors) 90 | -- 91 | -- main :: 'IO' () 92 | -- main = 93 | -- 'Network.Wai.Handler.Warp.run' 1337 ('Servant.Server.serve' ('Data.Proxy.Proxy' \@API) server) 94 | -- @ 95 | module Servant.Pagination 96 | ( 97 | -- * Types 98 | Ranges 99 | , Range(..) 100 | , RangeOrder(..) 101 | , AcceptRanges (..) 102 | , ContentRange (..) 103 | , PageHeaders 104 | , IsRangeType 105 | , PutRange 106 | , ExtractRange 107 | 108 | -- * Declare Ranges 109 | , HasPagination(..) 110 | , RangeOptions(..) 111 | , defaultOptions 112 | 113 | -- * Use Ranges 114 | , extractRange 115 | , putRange 116 | , addPageHeaders 117 | , returnRange 118 | , applyRange 119 | ) where 120 | 121 | import Data.List (filter, find, intercalate) 122 | import Data.Maybe (listToMaybe) 123 | import Data.Proxy (Proxy (..)) 124 | import Data.Semigroup ((<>)) 125 | import Data.Text (Text) 126 | import GHC.Generics (Generic) 127 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 128 | import Network.URI.Encode (decodeText, encodeText) 129 | import Servant 130 | 131 | import qualified Data.List as List 132 | import qualified Data.Text as Text 133 | import qualified Safe 134 | 135 | 136 | -- 137 | -- TYPES 138 | -- 139 | 140 | -- | Set of constraints that must apply to every type target of a 'Range' 141 | type IsRangeType a = 142 | ( Show a 143 | , Ord a 144 | , Eq a 145 | , FromHttpApiData a 146 | , ToHttpApiData a 147 | ) 148 | 149 | -- | A type to specify accepted Ranges via the @Range@ HTTP Header. For example: 150 | -- 151 | -- @ 152 | -- type API = "resources" 153 | -- :> 'Servant.Header' \"Range\" ('Ranges' '["created_at"] Resource) 154 | -- :> 'Servant.Get' '['Servant.JSON'] [Resource] 155 | -- @ 156 | data Ranges :: [Symbol] -> * -> * where 157 | Lift :: Ranges fields resource -> Ranges (y ': fields) resource 158 | Ranges 159 | :: HasPagination resource field 160 | => Range field (RangeType resource field) 161 | -> Ranges (field ': fields) resource 162 | 163 | instance (Show (Ranges '[] res)) where 164 | showsPrec _ _ = flip mappend "Ranges" 165 | 166 | instance (Show (Ranges fields res)) => Show (Ranges (field ': fields) res) where 167 | showsPrec prec (Lift r) s = showsPrec prec r s 168 | showsPrec prec (Ranges r) s = 169 | let 170 | inner = "Ranges@" ++ showsPrec 11 r s 171 | in 172 | if prec > 10 then "(" ++ inner ++ ")" else inner 173 | 174 | 175 | -- | An actual 'Range' instance obtained from parsing / to generate a @Range@ HTTP Header. 176 | data Range (field :: Symbol) (a :: *) = 177 | (KnownSymbol field, IsRangeType a) => Range 178 | { rangeValue :: Maybe a -- ^ The value of that field, beginning of the range 179 | , rangeLimit :: Int -- ^ Maximum number of resources to return 180 | , rangeOffset :: Int -- ^ Offset, number of resources to skip after the starting value 181 | , rangeOrder :: RangeOrder -- ^ The order of sorting (ascending or descending) 182 | , rangeField :: Proxy field -- ^ Actual field this Range actually refers to 183 | } 184 | 185 | instance Eq (Range field a) where 186 | (Range val0 lim0 off0 ord0 _) == (Range val1 lim1 off1 ord1 _) = 187 | val0 == val1 188 | && lim0 == lim1 189 | && off0 == off1 190 | && ord0 == ord1 191 | 192 | instance Show (Range field a) where 193 | showsPrec prec Range{..} = 194 | let 195 | inner = "Range {" ++ args ++ "}" 196 | args = intercalate ", " 197 | [ "rangeValue = " ++ show rangeValue 198 | , "rangeLimit = " ++ show rangeLimit 199 | , "rangeOffset = " ++ show rangeOffset 200 | , "rangeOrder = " ++ show rangeOrder 201 | , "rangeField = " ++ "\"" ++ symbolVal rangeField ++ "\"" 202 | ] 203 | in 204 | flip mappend $ if prec > 10 then 205 | "(" ++ inner ++ ")" 206 | else 207 | inner 208 | 209 | 210 | -- | Extract a 'Range' from a 'Ranges' 211 | class ExtractRange (fields :: [Symbol]) (field :: Symbol) where 212 | -- | Extract a 'Range' from a 'Ranges'. Works like a safe 'read', trying to coerce a 'Range' instance to 213 | -- an expected type. Type annotation are most likely necessary to remove ambiguity. Note that a 'Range' 214 | -- can only be extracted to a type bound by the allowed 'fields' on a given 'resource'. 215 | -- 216 | -- @ 217 | -- extractDateRange :: 'Ranges' '["created_at", "name"] Resource -> 'Range' "created_at" 'Data.Time.Clock.UTCTime' 218 | -- extractDateRange = 219 | -- 'extractRange' 220 | -- @ 221 | extractRange 222 | :: HasPagination resource field 223 | => Ranges fields resource -- ^ A list of accepted Ranges for the API 224 | -> Maybe (Range field (RangeType resource field)) -- ^ A Range instance of the expected type, if it matches 225 | 226 | instance ExtractRange (field ': fields) field where 227 | extractRange (Ranges r) = Just r 228 | extractRange (Lift _) = Nothing 229 | {-# INLINE extractRange #-} 230 | 231 | instance {-# OVERLAPPABLE #-} ExtractRange fields field => ExtractRange (y ': fields) field where 232 | extractRange (Ranges _) = Nothing 233 | extractRange (Lift r) = extractRange r 234 | {-# INLINE extractRange #-} 235 | 236 | 237 | -- | Put a 'Range' in a 'Ranges' 238 | class PutRange (fields :: [Symbol]) (field :: Symbol) where 239 | putRange 240 | :: HasPagination resource field 241 | => Range field (RangeType resource field) 242 | -> Ranges fields resource 243 | 244 | instance PutRange (field ': fields) field where 245 | putRange = Ranges 246 | {-# INLINE putRange #-} 247 | 248 | instance {-# OVERLAPPABLE #-} (PutRange fields field) => PutRange (y ': fields) field where 249 | putRange = Lift . putRange 250 | {-# INLINE putRange #-} 251 | 252 | 253 | instance ToHttpApiData (Ranges fields resource) where 254 | toUrlPiece (Lift range) = 255 | toUrlPiece range 256 | 257 | toUrlPiece (Ranges Range{..}) = 258 | Text.pack (symbolVal rangeField) 259 | <> maybe "" (\v -> " " <> (encodeText . toUrlPiece) v) rangeValue 260 | <> ";limit " <> toUrlPiece rangeLimit 261 | <> ";offset " <> toUrlPiece rangeOffset 262 | <> ";order " <> toUrlPiece rangeOrder 263 | 264 | 265 | instance FromHttpApiData (Ranges '[] resource) where 266 | parseUrlPiece _ = 267 | Left "Invalid Range" 268 | 269 | instance 270 | ( FromHttpApiData (Ranges fields resource) 271 | , HasPagination resource field 272 | , KnownSymbol field 273 | , IsRangeType (RangeType resource field) 274 | ) => FromHttpApiData (Ranges (field ': fields) resource) where 275 | parseUrlPiece txt = 276 | let 277 | RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource) 278 | 279 | toTuples = 280 | filter (/= "") . Text.splitOn (Text.singleton ' ') 281 | 282 | args = 283 | map toTuples $ Text.splitOn (Text.singleton ';') txt 284 | 285 | field = 286 | Text.pack $ symbolVal (Proxy @field) 287 | in 288 | case args of 289 | (field' : value) : rest | field == field' -> do 290 | opts <- 291 | traverse parseOpt rest 292 | 293 | range <- Range 294 | <$> mapM (parseUrlPiece . decodeText) (listToMaybe value) 295 | <*> (ifOpt "limit" defaultRangeLimit opts >>= checkLimit) 296 | <*> ifOpt "offset" defaultRangeOffset opts 297 | <*> ifOpt "order" defaultRangeOrder opts 298 | <*> pure (Proxy @field) 299 | 300 | pure $ Ranges range 301 | 302 | _ -> 303 | Lift <$> (parseUrlPiece txt :: Either Text (Ranges fields resource)) 304 | where 305 | parseOpt :: [Text] -> Either Text (Text, Text) 306 | parseOpt piece = 307 | case piece of 308 | [opt, arg] -> 309 | pure (opt, arg) 310 | 311 | _ -> 312 | Left "Invalid Range Options" 313 | 314 | ifOpt :: FromHttpApiData o => Text -> o -> [(Text, Text)] -> Either Text o 315 | ifOpt opt def = 316 | maybe (pure def) (parseQueryParam . snd) . find ((== opt) . fst) 317 | 318 | checkLimit :: Int -> Either Text Int 319 | checkLimit n 320 | | n < 0 = Left "Limit must be non-negative" 321 | | otherwise = return n 322 | 323 | -- | Define the sorting order of the paginated resources (ascending or descending) 324 | data RangeOrder 325 | = RangeAsc 326 | | RangeDesc 327 | deriving (Eq, Show, Ord, Generic) 328 | 329 | instance ToHttpApiData RangeOrder where 330 | toUrlPiece order = 331 | case order of 332 | RangeAsc -> "asc" 333 | RangeDesc -> "desc" 334 | 335 | instance FromHttpApiData RangeOrder where 336 | parseUrlPiece txt = 337 | case txt of 338 | "asc" -> pure RangeAsc 339 | "desc" -> pure RangeDesc 340 | _ -> Left "Invalid Range Order" 341 | 342 | 343 | -- | Type alias to declare response headers related to pagination 344 | -- 345 | -- @ 346 | -- type MyHeaders = 347 | -- 'PageHeaders' '["created_at"] Resource 348 | -- 349 | -- type API = "resources" 350 | -- :> 'Servant.Header' \"Range\" ('Ranges' '["created_at"] Resource) 351 | -- :> 'Servant.Get' '['Servant.JSON'] ('Servant.Headers' MyHeaders [Resource]) 352 | -- @ 353 | type PageHeaders (fields :: [Symbol]) (resource :: *) = 354 | '[ Header "Accept-Ranges" (AcceptRanges fields) 355 | , Header "Content-Range" (ContentRange fields resource) 356 | , Header "Next-Range" (Ranges fields resource) 357 | ] 358 | 359 | -- | Accepted Ranges in the `Accept-Ranges` response's header 360 | data AcceptRanges (fields :: [Symbol]) = AcceptRanges 361 | 362 | instance (KnownSymbol field) => ToHttpApiData (AcceptRanges '[field]) where 363 | toUrlPiece AcceptRanges = 364 | Text.pack (symbolVal (Proxy @field)) 365 | 366 | instance (ToHttpApiData (AcceptRanges (f ': fs)), KnownSymbol field) => ToHttpApiData (AcceptRanges (field ': f ': fs)) where 367 | toUrlPiece AcceptRanges = 368 | Text.pack (symbolVal (Proxy @field)) <> "," <> toUrlPiece (AcceptRanges @(f ': fs)) 369 | 370 | 371 | -- | Actual range returned, in the `Content-Range` response's header 372 | data ContentRange (fields :: [Symbol]) resource = 373 | forall field. (KnownSymbol field, ToHttpApiData (RangeType resource field)) => ContentRange 374 | { contentRangeStart :: RangeType resource field 375 | , contentRangeEnd :: RangeType resource field 376 | , contentRangeField :: Proxy field 377 | } 378 | 379 | instance ToHttpApiData (ContentRange fields res) where 380 | toUrlPiece (ContentRange start end field) = 381 | Text.pack (symbolVal field) <> " " <> (encodeText . toUrlPiece) start <> ".." <> (encodeText . toUrlPiece) end 382 | 383 | 384 | -- 385 | -- USE RANGES 386 | -- 387 | 388 | -- | Available 'Range' on a given @resource@ must implements the 'HasPagination' type-class. 389 | -- This class defines how the library can interact with a given @resource@ to access the value 390 | -- to which a @field@ refers. 391 | class KnownSymbol field => HasPagination resource field where 392 | type RangeType resource field :: * 393 | 394 | -- | Get the corressponding value of a Resource 395 | getFieldValue :: Proxy field -> resource -> RangeType resource field 396 | 397 | -- | Get parsing options for the 'Range' defined on this 'field' 398 | getRangeOptions :: Proxy field -> Proxy resource -> RangeOptions 399 | getRangeOptions _ _ = defaultOptions 400 | 401 | -- | Create a default 'Range' from a value and default 'RangeOptions'. Typical use-case 402 | -- is for when no or an invalid 'Range' header was provided. 403 | getDefaultRange 404 | :: IsRangeType (RangeType resource field) 405 | => Proxy resource 406 | -> Range field (RangeType resource field) 407 | getDefaultRange _ = 408 | let 409 | RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource) 410 | in Range 411 | { rangeValue = Nothing @(RangeType resource field) 412 | , rangeLimit = defaultRangeLimit 413 | , rangeOffset = defaultRangeOffset 414 | , rangeOrder = defaultRangeOrder 415 | , rangeField = Proxy @field 416 | } 417 | 418 | -- | Add headers representing a 'Range' to a list of resources. 419 | -- 420 | -- 'Ranges' headers can be quite cumbersome to declare and can be deduced from a 421 | -- collection of resources together with the 'Range' used to retrieve it, so this function 422 | -- is a shortcut for that. 423 | -- 424 | -- @ 425 | -- myHandler 426 | -- :: 'Maybe' ('Ranges' '["created_at"] Resource) 427 | -- -> 'Servant.Server.Handler' ('Servant.Headers' ('PageHeaders' '["created_at"] Resource) [Resource]) 428 | -- myHandler mrange = 429 | -- let range = 430 | -- 'Data.Maybe.fromMaybe' ('getDefaultRange' ('Data.Proxy.Proxy' \@Resource)) (mrange >>= 'extractRange') 431 | -- 432 | -- 'return' ('addPageHeaders' range ('applyRange' range resources)) 433 | -- @ 434 | addPageHeaders 435 | :: ( ToHttpApiData (AcceptRanges fields) 436 | , KnownSymbol field 437 | , HasPagination resource field 438 | , IsRangeType (RangeType resource field) 439 | , PutRange fields field 440 | ) 441 | => Range field (RangeType resource field) -- ^ Actual 'Range' used to retrieve the results 442 | -> [resource] -- ^ Resources to return, fetched from a db or a local store 443 | -> Headers (PageHeaders fields resource) [resource] -- ^ The same resources, but with pagination headers 444 | addPageHeaders Range{..} rs = 445 | let boundaries = (,) 446 | <$> fmap (getFieldValue rangeField) (Safe.headMay rs) 447 | <*> fmap (getFieldValue rangeField) (Safe.lastMay rs) 448 | in case boundaries of 449 | Nothing -> 450 | addHeader AcceptRanges $ noHeader $ noHeader rs 451 | 452 | Just (start, end) -> do 453 | let nextOffset | rangeValue == Just end = rangeOffset + length rs 454 | | otherwise = length $ takeWhile ((==) end . getFieldValue rangeField) (reverse rs) 455 | 456 | let nextRange = putRange Range 457 | { rangeValue = Just end 458 | , rangeLimit = rangeLimit 459 | , rangeOffset = nextOffset 460 | , rangeOrder = rangeOrder 461 | , rangeField = rangeField 462 | } 463 | 464 | let contentRange = ContentRange 465 | { contentRangeStart = start 466 | , contentRangeEnd = end 467 | , contentRangeField = rangeField 468 | } 469 | 470 | let addNextRange | length rs < rangeLimit = noHeader 471 | | otherwise = addHeader nextRange 472 | 473 | addHeader AcceptRanges $ addHeader contentRange $ addNextRange rs 474 | 475 | -- | @'returnRange' range rs = 'return' ('addPageHeaders' range rs)@ 476 | returnRange 477 | :: ( Monad m 478 | , ToHttpApiData (AcceptRanges fields) 479 | , KnownSymbol field 480 | , HasPagination resource field 481 | , IsRangeType (RangeType resource field) 482 | , PutRange fields field 483 | ) 484 | => Range field (RangeType resource field) -- ^ Actual 'Range' used to retrieve the results 485 | -> [resource] -- ^ Resources to return, fetched from a db or a local store 486 | -> m (Headers (PageHeaders fields resource) [resource]) -- ^ Resources embedded in a given 'Monad' (typically a 'Servant.Server.Handler', with pagination headers) 487 | returnRange range rs = return (addPageHeaders range rs) 488 | 489 | -- | Default values to apply when parsing a 'Range' 490 | data RangeOptions = RangeOptions 491 | { defaultRangeLimit :: Int -- ^ Default limit if not provided, default to @100@ 492 | , defaultRangeOffset :: Int -- ^ Default offset if not provided, default to @0@ 493 | , defaultRangeOrder :: RangeOrder -- ^ Default order if not provided, default to 'RangeDesc' 494 | } deriving (Eq, Show) 495 | 496 | 497 | -- | Some default options of default values for a Range (limit 100; offset 0; order desc) 498 | defaultOptions :: RangeOptions 499 | defaultOptions = 500 | RangeOptions 100 0 RangeDesc 501 | 502 | 503 | -- | Helper to apply a 'Range' to a list of values. Most likely useless in practice 504 | -- as results may come more realistically from a database, but useful for debugging or 505 | -- testing. 506 | applyRange 507 | :: HasPagination resource field 508 | => Range field (RangeType resource field) -- ^ A 'Range' instance on a given @resource@ 509 | -> [resource] -- ^ A full-list of @resource@ 510 | -> [resource] -- ^ The sublist obtained by applying the 'Range' 511 | applyRange Range{..} = 512 | let 513 | sortRel = 514 | case rangeOrder of 515 | RangeDesc -> 516 | \a b -> compare (getFieldValue rangeField b) (getFieldValue rangeField a) 517 | 518 | RangeAsc -> 519 | \a b -> compare (getFieldValue rangeField a) (getFieldValue rangeField b) 520 | 521 | dropRel = 522 | case (rangeValue, rangeOrder) of 523 | (Nothing, _) -> 524 | const False 525 | 526 | (Just a, RangeDesc) -> 527 | (> a) . getFieldValue rangeField 528 | 529 | (Just a, RangeAsc) -> 530 | (< a) . getFieldValue rangeField 531 | in 532 | List.take rangeLimit 533 | . List.drop rangeOffset 534 | . List.dropWhile dropRel 535 | . List.sortBy sortRel 536 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.25 2 | 3 | # Generate files required by Weeder. 4 | # See https://github.com/ndmitchell/weeder/issues/53 5 | ghc-options: {"$locals": -ddump-to-file -ddump-hi} 6 | -------------------------------------------------------------------------------- /test/Servant/PaginationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Servant.PaginationSpec 6 | ( spec 7 | ) where 8 | 9 | 10 | import Data.Either (isLeft) 11 | import Data.Proxy (Proxy (..)) 12 | import Data.Text (Text) 13 | import Servant (FromHttpApiData (..), ToHttpApiData (..)) 14 | import Test.Hspec (Spec, describe, it, shouldBe) 15 | import Test.QuickCheck (Arbitrary (..), property, withMaxSuccess) 16 | import Test.QuickCheck.Gen (Gen, choose, oneof, scale, sized, vectorOf) 17 | import Test.QuickCheck.Modifiers (Positive (..)) 18 | 19 | import Servant.Pagination 20 | 21 | 22 | spec :: Spec 23 | spec = do 24 | describe "round-up properties" $ do 25 | it "parseUrlPiece . toUrlPiece = pure" $ withMaxSuccess 10000 $ property $ 26 | \x -> (fmap extractA . parseUrlPiece . toUrlPiece) x == (pure . extractA) x 27 | 28 | it "parseUrlPiece . toUrlPiece = pure" $ withMaxSuccess 10000 $ property $ 29 | \x -> (fmap extractB . parseUrlPiece . toUrlPiece) x == (pure . extractB) x 30 | 31 | describe "try-out ranges" $ do 32 | let r0 = getDefaultRange (Proxy @Resource) :: Range "fieldA" Int 33 | 34 | it "Range: fieldA" $ 35 | let 36 | Right r = parseUrlPiece "fieldA" 37 | r' = r0 38 | in 39 | extractA r `shouldBe` pure r' 40 | 41 | it "Range: fieldA 14; limit 42" $ 42 | let 43 | Right r = parseUrlPiece "fieldA 14; limit 42" 44 | r' = r0 { rangeValue = Just 14, rangeLimit = 42 } 45 | in 46 | extractA r `shouldBe` pure r' 47 | 48 | it "Range: fieldA; order asc; offset 2" $ 49 | let 50 | Right r = parseUrlPiece "fieldA; order asc; offset 42" 51 | r' = r0 { rangeOffset = 42, rangeOrder = RangeAsc } 52 | in 53 | extractA r `shouldBe` pure r' 54 | 55 | it "Range: fieldA xxx" $ 56 | isLeft (parseUrlPiece "fieldA xxx" :: Either Text (Ranges '["fieldA", "fieldB"] Resource)) 57 | 58 | it "Range: fieldC" $ 59 | isLeft (parseUrlPiece "fieldC" :: Either Text (Ranges '["fieldA", "fieldB"] Resource)) 60 | 61 | it "Range: fieldB" $ 62 | isLeft (parseUrlPiece "fieldB" :: Either Text (Ranges '["fieldA"] Resource)) 63 | where 64 | extractA :: Ranges '["fieldA", "fieldB"] Resource -> Maybe (Range "fieldA" Int) 65 | extractA = extractRange 66 | 67 | extractB :: Ranges '["fieldA", "fieldB"] Resource -> Maybe (Range "fieldB" SimpleString) 68 | extractB = extractRange 69 | 70 | 71 | data Resource = Resource 72 | { fieldA :: Int 73 | , fieldB :: SimpleString 74 | } deriving (Show, Eq) 75 | 76 | newtype SimpleString = SimpleString 77 | { getSimpleString :: String 78 | } deriving (Show, Eq, Ord) 79 | 80 | instance Arbitrary SimpleString where 81 | arbitrary = 82 | SimpleString <$> scale (+1) (sized $ flip vectorOf $ choose ('a', 'z')) 83 | 84 | instance FromHttpApiData SimpleString where 85 | parseUrlPiece = 86 | fmap SimpleString . parseUrlPiece 87 | 88 | instance ToHttpApiData SimpleString where 89 | toUrlPiece = 90 | toUrlPiece . getSimpleString 91 | 92 | instance HasPagination Resource "fieldA" where 93 | type RangeType Resource "fieldA" = Int 94 | getFieldValue _ = fieldA 95 | 96 | instance HasPagination Resource "fieldB" where 97 | type RangeType Resource "fieldB" = SimpleString 98 | getFieldValue _ = fieldB 99 | 100 | instance Arbitrary (Ranges '["fieldA", "fieldB"] Resource) where 101 | arbitrary = oneof 102 | [ putRange <$> (arbitrary :: Gen (Range "fieldA" Int)) 103 | , putRange <$> (arbitrary :: Gen (Range "fieldB" SimpleString)) 104 | ] 105 | 106 | instance (IsRangeType a, Arbitrary a) => Arbitrary (Range "fieldA" a) where 107 | arbitrary = Range 108 | <$> arbitrary 109 | <*> fmap getPositive arbitrary 110 | <*> fmap getPositive arbitrary 111 | <*> oneof [pure RangeAsc, pure RangeDesc] 112 | <*> pure Proxy 113 | 114 | instance (IsRangeType a, Arbitrary a) => Arbitrary (Range "fieldB" a) where 115 | arbitrary = Range 116 | <$> arbitrary 117 | <*> fmap getPositive arbitrary 118 | <*> fmap getPositive arbitrary 119 | <*> oneof [pure RangeAsc, pure RangeDesc] 120 | <*> pure Proxy 121 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------