diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,41 @@ +--- +columns: 100 +language_extensions: + - BangPatterns + - DefaultSignatures + - DataKinds + - DeriveDataTypeable + - DeriveFunctor + - DeriveGeneric + - ExistentialQuantification + - FlexibleContexts + - GADTs + - GeneralizedNewtypeDeriving + - MultiParamTypeClasses + - OverloadedStrings + - RecordWildCards + - ScopedTypeVariables + - TupleSections + - TypeOperators +steps: + - simple_align: + cases: true + top_level_patterns: true + records: true + + - imports: + align: global + list_align: after_alias + pad_module_names: true + long_list_align: inline + empty_list_align: inherit + list_padding: 4 + separate_lists: true + space_surround: false + + - language_pragmas: + style: vertical + align: true + remove_redundant: true + + - trailing_whitespace: {} diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,16 @@ +# Changelog + +## v2.0.0 (2018-04-06) + +- Review internal implementation and public API (ditch Range combinator to favor type-level + list and more discrete footprint). + +- Remove 'Total-Count' header, can still be added on top of the range headers but isn't a Range + header so to speak. + +- Extend haddock documentation to be more user-friendly + + +## v1.0.0 (2018-02-06) + +- Initial release diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,131 @@ +# servant-pagination [![](https://img.shields.io/hackage/v/servant-pagination.svg)](https://hackage.haskell.org/package/servant-pagination) + +## Overview + +This module offers opinionated helpers to declare a type-safe and a flexible pagination +mechanism for Servant APIs. This design, inspired by [Heroku's API](https://devcenter.heroku.com/articles/platform-api-reference#ranges), +provides a small framework to communicate about a possible pagination feature of an endpoint, +enabling a client to consume the API in different fashions (pagination with offset / limit, +endless scroll using last referenced resources, ascending and descending ordering, etc.) + +Therefore, client may provide a `Range` header with their request with the following format: + +- `Range: [][; offset ][; limit ][; order ]` + +For example: `Range: createdAt 2017-01-15T23:14:67.000Z; offset 5; order desc` indicates that +the client is willing to retrieve the next batch of document in descending order that were +created after the fifteenth of January, skipping the first 5. + +As a response, the server may return the list of corresponding document, and augment the +response with 3 or 4 headers: + +- `Accept-Ranges`: A comma-separated list of field upon which a range can be defined +- `Content-Range`: Actual range corresponding to the content being returned +- `Next-Range`: Indicate what should be the next `Range` header in order to retrieve the next range + +For example: + +- `Accept-Ranges: createdAt, modifiedAt` +- `Content-Range: createdAt 2017-01-15T23:14:51.000Z..2017-02-18T06:10:23.000Z` +- `Next-Range: createdAt 2017-02-19T12:56:28.000Z; offset 0; limit 100; order desc` + + +## Getting Starting + +Code-wise, the integration is rather seamless and requires to declare a `Range` type on +on a given field and to provide an instance of `HasPagination` and `FromHttpApiData`. +The `getRangeField` method from `HasPagination` is merely a getter to retrieve +a range's field value from a resource. + +```hs +data Color = Color + { name :: String + , rgb :: [Int] + , hex :: String + } deriving (Eq, Show, Generic) + +instance ToJSON Color where + toJSON = genericToJSON defaultOptions + +instance HasPagination Color "name" where + type RangeType Color "name" = String + getFieldValue _ = name +``` + +That's it, the range is ready to use and to be declared in the Servant API. Additionally, +this library provides a small type alias helper `PageHeaders` to derive response headers from +a range. For example: + +```hs +type API = + "colors" + :> Header "Range" (Ranges '["name"] Color) + :> GetPartialContent '[JSON] (Headers (PageHeaders '["name"] Color) [Color]) +``` + +The range is then provided to the corresponding handler as a `Maybe NameRange` (for Servant +<0.13) type and can be used by the backend service to actually apply the given range and +fetch the resources demanded by the client. To send the response, one can leverage the +`returnPage` to lift a collection of resources into a Servant Handler: + +```hs +defaultRange :: Range "name" String +defaultRange = + getDefaultRange (Proxy @Color) Nothing + +server :: Maybe (Ranges '["name"] Color) -> Handler (Headers (PageHeaders '["name"] Color) [Color]) +server mrange = do + let range = + fromMaybe defaultRange (mrange >>= extractRange) + + returnRange range (applyRange range colors) +``` + +> See `examples/Simple.hs` for a running version of this guide. + + +## Multiple Ranges + +As you've probably noticed, the 'Ranges' type takes a list of 'Symbol' of accepted fields. For +each of those 'Symbol', there must be a instance of `HasPagination` tighting the 'Symbol' to a +'Resource' and a given type. This enables you to define as many ranges as you want on a given +resource type. For instance, one could go for: + +```hs +instance HasPagination Color "hex" where + type RangeType Color "hex" = String + getFieldValue _ = hex + +-- to then define: Ranges '["name", "hex"] Color +``` + +> See `examples/Complex.hs` for more complex examples. + + +## Parsing Options + +By default, `servant-pagination` provides an implementation of `getRangeOptions` for each +`HasPagination` type-class. However, this can be overwritten when defining a instance of that +class to provide your own options. This options come into play when a `Range` header is +received and isn't fully specified (`limit`, `offset`, `order` are all optional) to provide +default fallback values for those. + +For instance, let's say we wanted to change the default limit to `5` in for our range on +`"name"`, we could tweak the corresponding `HasPagination` instance as follows: + +```hs +instance HasPagination Color "name" where + type RangeType Color "name" = String + getFieldValue _ = name + getRangeOptions _ _ = defaultOptions { defaultRangeLimit = 5 } +``` + + +## Changelog + +[CHANGELOG.md](CHANGELOG.md) + + +## License + +[LGPL-3 © 2018 Chordify](LICENSE) diff --git a/examples/Color.hs b/examples/Color.hs --- a/examples/Color.hs +++ b/examples/Color.hs @@ -1,10 +1,9 @@ module Color where -import Data.Aeson (ToJSON) -import GHC.Generics (Generic) -import Numeric.Natural (Natural) +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) -import qualified Data.Aeson as Aeson +import qualified Data.Aeson as Aeson data Color = Color @@ -17,11 +16,6 @@ instance ToJSON Color where toJSON = Aeson.genericToJSON Aeson.defaultOptions - - -nColors :: Natural -nColors = - fromIntegral $ length colors colors :: [Color] diff --git a/examples/Complex.hs b/examples/Complex.hs --- a/examples/Complex.hs +++ b/examples/Complex.hs @@ -1,12 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Main where +import Control.Applicative ((<|>)) +import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import Servant import Servant.Pagination +import qualified Data.Char as Char import qualified Network.Wai.Handler.Warp as Warp import Color @@ -14,71 +18,72 @@ -- Ranges definitions --- | Custom options for ranges -myOpts :: FromRangeOptions -myOpts = - defaultOptions { defaultRangeLimit = 5, defaultRangeOrder = RangeAsc } - --- | A range on the colors' name -type NameRange = - Range "name" String - -instance FromHttpApiData NameRange where - parseUrlPiece = - parseRange myOpts - +-- By default, a Range relies on `defaultOptions` but any instance can define its own options instance HasPagination Color "name" where type RangeType Color "name" = String - getRangeField _ = - name - --- | A range on the sum of the rgb components of a color -type RGBRange = - Range "rgb" Int + getFieldValue _ = name + getRangeOptions _ _ = defaultOptions + { defaultRangeLimit = 5 + , defaultRangeOrder = RangeAsc + } -instance FromHttpApiData RGBRange where - parseUrlPiece = - parseRange myOpts +-- We can declare more than one range on a given type if they use different symbol field +instance HasPagination Color "hex" where + type RangeType Color "hex" = String + getFieldValue _ = map Char.toUpper . hex instance HasPagination Color "rgb" where type RangeType Color "rgb" = Int - - getRangeField _ = - sum . rgb + getFieldValue _ = sum . rgb -- API type API = "colors" - :> Header "Range" (NameRange :|: RGBRange) + :> Header "Range" (Ranges '["name", "rgb", "hex"] Color) :> GetPartialContent '[JSON] (Headers MyHeaders [Color]) +-- PageHeaders fields resource ~ '[Header h typ], thus we can add extra headers +-- as we desire. type MyHeaders = - PageHeaders (NameRange :|: RGBRange) + Header "Total-Count" Int ': PageHeaders '["name", "rgb", "hex"] Color -- Application +defaultRange :: Range "name" String +defaultRange = + getDefaultRange (Proxy @Color) Nothing + server :: Server API -server mrange = do - let range = - defaultRange Nothing myOpts :: NameRange +server mrange = + addHeader (length colors) <$> handler mrange + where + -- 'extractRange' tries to extract a range if it has the right type, and yields 'Nothing' + -- otherwise. We can use the '<|>' alternative combinator to try handlers one after + -- the other + handler r = + fromMaybe (returnNameRange defaultRange) $ + fmap returnNameRange (r >>= extractRange) + <|> fmap returnRGBRange (r >>= extractRange) + <|> fmap returnHexRange (r >>= extractRange) - case mrange of - Nothing -> - returnPage (Just nColors) range (applyRange range colors) + -- Handlers below are very simple, in practice, they're likely to trigger different functions + -- or database calls. + returnNameRange (range :: Range "name" String) = + returnRange range (applyRange range colors) - Just (InL nameRange) -> - returnPage (Just nColors) nameRange (applyRange nameRange colors) + returnRGBRange (range :: Range "rgb" Int) = + returnRange range (applyRange range colors) - Just (InR rgbRange) -> - returnPage (Just nColors) rgbRange (applyRange rgbRange colors) + returnHexRange (range :: Range "hex" String) = + returnRange range (applyRange range colors) main :: IO () main = - Warp.run 1337 (serve (Proxy :: Proxy API) server) + Warp.run 1337 (serve (Proxy @API) server) -- Examples @@ -91,7 +96,7 @@ -- < Content-Type: application/json;charset=utf-8 -- < Accept-Ranges: name,rgb -- < Content-Range: name Aqua..CadetBlue --- < Next-Range: name CadetBlue;limit 5;offset 0;order asc +-- < Next-Range: name CadetBlue;limit 5;offset 1;order asc -- < Total-Count: 59 @@ -103,8 +108,8 @@ -- < HTTP/1.1 206 Partial Content -- < Content-Type: application/json;charset=utf-8 -- < Accept-Ranges: name,rgb --- < Content-Range: rgb 0..128 --- < Next-Range: rgb 128;limit 5;offset 0;order asc +-- < Content-Range: rgb 765..0 +-- < Next-Range: rgb 0;limit 100;offset 1;order desc -- < Total-Count: 59 @@ -116,6 +121,6 @@ -- < HTTP/1.1 206 Partial Content -- < Content-Type: application/json;charset=utf-8 -- < Accept-Ranges: name,rgb --- < Content-Range: name Fuchsia..DarkMagenta --- < Next-Range: name DarkMagenta;limit 10;offset 0;order desc +-- < Content-Range: name Green..DarkMagenta +-- < Next-Range: name DarkMagenta;limit 10;offset 1;order desc -- < Total-Count: 59 diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Main where @@ -15,32 +16,30 @@ -- Ranges definitions --- | A range on the colors' name -type NameRange = - Range "name" String - instance HasPagination Color "name" where type RangeType Color "name" = String - - getRangeField _ = - name + getFieldValue _ = name -- API type API = "colors" - :> Header "Range" NameRange - :> GetPartialContent '[JSON] (Headers (PageHeaders NameRange) [Color]) + :> Header "Range" (Ranges '["name"] Color) + :> GetPartialContent '[JSON] (Headers (PageHeaders '["name"] Color) [Color]) -- Application +defaultRange :: Range "name" String +defaultRange = + getDefaultRange (Proxy @Color) Nothing + server :: Server API server mrange = do let range = - fromMaybe (defaultRange Nothing defaultOptions) mrange + fromMaybe defaultRange (mrange >>= extractRange) - returnPage (Just nColors) range (applyRange range colors) + returnRange range (applyRange range colors) main :: IO () main = @@ -63,8 +62,7 @@ -- < Content-Type: application/json;charset=utf-8 -- < Accept-Ranges: name -- < Content-Range: name Yellow..Aqua --- < Next-Range: name Aqua;limit 100;offset 0;order desc --- < Total-Count: 59 +-- < Next-Range: name Aqua;limit 100;offset 1;order desc -- $ curl -v http://localhost:1337/colors --header 'Range: name; offset 59' @@ -75,4 +73,3 @@ -- < HTTP/1.1 206 Partial Content -- < Content-Type: application/json;charset=utf-8 -- < Accept-Ranges: name --- < Total-Count: 59 diff --git a/servant-pagination.cabal b/servant-pagination.cabal --- a/servant-pagination.cabal +++ b/servant-pagination.cabal @@ -5,7 +5,7 @@ to communicate about a possible pagination feature of an endpoint, enabling a client to consume the API in different fashions (pagination with offset / limit, endless scroll using last referenced resources, ascending and descending ordering, etc.) -version: 1.0.0 +version: 2.0.0 homepage: https://github.com/chordify/haskell-servant-pagination bug-reports: https://github.com/chordify/haskell-servant-pagination/issues license: LGPL-3 @@ -17,6 +17,12 @@ build-type: Simple cabal-version: >=1.20 +extra-source-files: README.md + CHANGELOG.md + stack.yaml + Setup.hs + .stylish-haskell.yaml + source-repository head type: git location: git://github.com/chordify/haskell-servant-pagination.git @@ -51,12 +57,11 @@ build-depends: base >= 4 && < 5 , text >= 1.2 && < 2 - , servant >= 0.11 && < 1 - , servant-server >= 0.11 && < 1 + , servant >= 0.11 && <= 0.13 + , servant-server >= 0.11 && <= 0.13 , safe >= 0.3 && < 1 exposed-modules: Servant.Pagination - , Servant.Pagination.Internal executable servant-pagination-simple if !flag(examples) @@ -87,9 +92,9 @@ build-depends: base >= 4 && < 5 , aeson >= 1.2 && < 2 - , servant >= 0.11 && < 1 - , servant-pagination >= 1 && < 2 - , servant-server >= 0.11 && < 1 + , servant >= 0.11 && <= 0.13 + , servant-pagination + , servant-server >= 0.11 && <= 0.13 , warp >= 3.2 && < 4 other-modules: Color @@ -123,9 +128,9 @@ build-depends: base >= 4 && < 5 , aeson >= 1.2 && < 2 - , servant >= 0.11 && < 1 - , servant-pagination >= 1 && < 2 - , servant-server >= 0.11 && < 1 + , servant >= 0.11 && <= 0.13 + , servant-pagination + , servant-server >= 0.11 && <= 0.13 , warp >= 3.2 && < 4 other-modules: Color diff --git a/src/Servant/Pagination.hs b/src/Servant/Pagination.hs --- a/src/Servant/Pagination.hs +++ b/src/Servant/Pagination.hs @@ -1,196 +1,240 @@ -{-# LANGUAGE TypeFamilies #-} +-- | Opinionated Pagination Helpers for Servant APIs +-- +-- +-- Client can provide a `Range` header with their request with the following format +-- +-- > Range: [][; offset ][; limit ][; order ] +-- +-- Available ranges are declared using type-level list of accepted fields, bound to a given +-- resource and type using the 'HasPagination' type-class. The library provides unobtrusive +-- types and abstract away all the plumbing to hook that on an existing Servant API. +-- +-- The 'IsRangeType' constraints summarize all constraints that must apply to a possible field +-- and heavily rely on the 'Web.Internal.FromHttpApiData' and 'Web.Internal.ToHttpApiData'. +-- +-- > $ curl -v http://localhost:1337/colors -H 'Range: name; limit 10' +-- > +-- > > GET /colors HTTP/1.1 +-- > > Host: localhost:1337 +-- > > User-Agent: curl/7.47.0 +-- > > Accept: */* +-- > > +-- > < HTTP/1.1 206 Partial Content +-- > < Transfer-Encoding: chunked +-- > < Date: Tue, 30 Jan 2018 12:45:17 GMT +-- > < Server: Warp/3.2.13 +-- > < Content-Type: application/json;charset=utf-8 +-- > < Accept-Ranges: name +-- > < Content-Range: name Yellow..Purple +-- > < Next-Range: name Purple;limit 10;offset 1;order desc +-- +-- The 'Range' header is totally optional, but when provided, it indicates to the server what +-- parts of the collection is requested. As a reponse and in addition to the data, the server may +-- provide 3 headers to the client: +-- +-- - @Accept-Ranges@: A comma-separated list of field upon which a range can be defined +-- - @Content-Range@: Actual range corresponding to the content being returned +-- - @Next-Range@: Indicate what should be the next `Range` header in order to retrieve the next range +-- +-- This allows the client to work in a very _dumb_ mode where it simply consumes data from the server +-- using the value of the 'Next-Range' header to fetch each new batch of data. The 'Accept-Ranges' +-- comes in handy to self-document the API telling the client about the available filtering and sorting options +-- of a resource. +-- +-- Here's a minimal example used to obtained the previous behavior; Most of the magic happens in the +-- 'returnRange' function which lift a collection of resources into a Servant handler, computing the +-- corresponding ranges from the range used to retrieve the resources. +-- +-- @ +-- -- Resource Type +-- +-- data Color = Color +-- { name :: 'String' +-- , rgb :: ['Int'] +-- , hex :: 'String' +-- } deriving ('Eq', 'Show', 'GHC.Generics.Generic') +-- +-- colors :: [Color] +-- colors = [ {- ... -} ] +-- +-- -- Ranges definitions +-- +-- instance 'HasPagination' Color "name" where +-- type 'RangeType' Color "name" = 'String' +-- 'getFieldValue' _ = name +-- +-- +-- -- API +-- +-- type API = +-- "colors" +-- :> 'Servant.Header' \"Range\" ('Ranges' '["name"] Color) +-- :> 'Servant.GetPartialContent' '['Servant.JSON'] ('Servant.Headers' ('PageHeaders' '["name"] Color) [Color]) +-- +-- +-- -- Application +-- +-- defaultRange :: 'Range' "name" 'String' +-- defaultRange = +-- 'getDefaultRange' ('Data.Proxy.Proxy' @Color) 'Data.Maybe.Nothing' +-- +-- server :: 'Servant.Server.Server' API +-- server mrange = do +-- let range = +-- 'Data.Maybe.fromMaybe' defaultRange (mrange >>= 'extractRange') +-- +-- 'returnRange' range ('applyRange' range colors) +-- +-- main :: 'IO' () +-- main = +-- 'Network.Wai.Handler.Warp.run' 1337 ('Servant.Server.serve' ('Data.Proxy.Proxy' @API) server) +-- @ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + module Servant.Pagination ( -- * Types - Range(..) + Ranges + , Range(..) , RangeOrder(..) , AcceptRanges (..) , ContentRange (..) - , NextRange (..) , PageHeaders - , TotalCount + , IsRangeType -- * Declare Ranges - , FromRange(..) - , FromHttpApiData(..) - , FromRangeOptions(..) + , HasPagination(..) + , RangeOptions(..) , defaultOptions - , defaultRange -- * Use Ranges - , HasPagination(..) + , extractRange + , returnRange , applyRange - - -- * Combine Ranges - , (:|:)(..) ) where -import Data.List (filter, find) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Proxy (Proxy (..)) -import Data.Semigroup ((<>)) -import Data.Text (Text) -import GHC.Generics (Generic) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Numeric.Natural (Natural) +import Data.List (filter, find) +import Data.Maybe (listToMaybe) +import Data.Proxy (Proxy (..)) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Servant -import qualified Data.List as List -import qualified Data.Text as Text +import qualified Data.List as List +import qualified Data.Text as Text import qualified Safe -import Servant.Pagination.Internal - -- -- TYPES -- --- An actual Range parsed from a `Range` header. A Range -data Range (field :: Symbol) typ = Range - { rangeValue :: Maybe typ -- ^ The value of that field, beginning of the range +-- | Set of constraints that must apply to every type target of a Range +type IsRangeType a = + ( Show a + , Ord a + , Eq a + , FromHttpApiData a + , ToHttpApiData a + ) + +-- | A type to specify accepted Ranges via the @Range@ HTTP Header. For example: +-- +-- @ +-- type API = "resources" +-- :> 'Servant.Header' \"Range\" ('Ranges' '["created_at"] Resource) +-- :> 'Servant.Get' '['Servant.JSON'] [Resource] +-- @ +data Ranges :: [Symbol] -> * -> * where + Lift :: Ranges fields resource -> Ranges (y ': fields) resource + Ranges + :: HasPagination resource field + => Range field (RangeType resource field) + -> Ranges (field ': fields) resource + +-- | An actual 'Range' instance obtained from parsing / to generate a @Range@ HTTP Header. +data Range (field :: Symbol) (a :: *) = + (KnownSymbol field, IsRangeType a) => Range + { rangeValue :: Maybe a -- ^ The value of that field, beginning of the range , rangeLimit :: Int -- ^ Maximum number of resources to return , rangeOffset :: Int -- ^ Offset, number of resources to skip after the starting value , rangeOrder :: RangeOrder -- ^ The order of sorting (ascending or descending) - } deriving (Eq, Show, Generic) - -instance Functor (Range field) where - fmap f r = - r { rangeValue = f <$> rangeValue r } - -instance (ToHttpApiData typ, KnownSymbol field) => ToHttpApiData (Range field typ) where - toUrlPiece Range{..} = - Text.pack (symbolVal (Proxy :: Proxy field)) - <> maybe "" (\v -> " " <> toUrlPiece v) rangeValue - <> ";limit " <> toUrlPiece rangeLimit - <> ";offset " <> toUrlPiece rangeOffset - <> ";order " <> toUrlPiece rangeOrder - -instance (KnownSymbol field) => ToAcceptRanges (Range field typ) where - toAcceptRanges _ = - Text.pack (symbolVal (Proxy :: Proxy field)) - - --- | Define the sorting order of the paginated resources (ascending or descending) -data RangeOrder - = RangeAsc - | RangeDesc - deriving (Eq, Show, Ord, Generic) - -instance ToHttpApiData RangeOrder where - toUrlPiece order = - case order of - RangeAsc -> "asc" - RangeDesc -> "desc" - -instance FromHttpApiData RangeOrder where - parseUrlPiece txt = - case txt of - "asc" -> pure RangeAsc - "desc" -> pure RangeDesc - _ -> Left "Invalid Range Order" - - --- | Accepted Ranges in the `Accept-Ranges` response's header -data AcceptRanges range = AcceptRanges - -instance (ToAcceptRanges a) => ToHttpApiData (AcceptRanges a) where - toUrlPiece _ = - toAcceptRanges (Proxy :: Proxy a) - - --- | Actual range returned, in the `Content-Range` response's header -data ContentRange range = ContentRange - { contentRangeStart :: range - , contentRangeEnd :: range + , rangeField :: Proxy field -- ^ Actual field this Range actually refers to } -instance (ToHttpApiData typ, KnownSymbol field) => ToHttpApiData (ContentRange (Range field typ)) where - toUrlPiece (ContentRange start end) = - Text.pack (symbolVal (Proxy :: Proxy field)) - <> " " <> (fromMaybe "" (toUrlPiece <$> rangeValue start)) - <> ".." <> (fromMaybe "" (toUrlPiece <$> rangeValue end)) -instance (ToHttpApiData (ContentRange a), ToHttpApiData (ContentRange b)) => ToHttpApiData (ContentRange (a :|: b)) where - toUrlPiece (ContentRange (InL sa) (InL ea)) = - toUrlPiece (ContentRange sa ea) - - toUrlPiece (ContentRange (InR sb) (InR eb)) = - toUrlPiece (ContentRange sb eb) - - toUrlPiece _ = - error "impossible" - - --- | Range to provide to retrieve the next batch of resource, in the `Next-Range` response's header -data NextRange range = NextRange range - -instance (ToHttpApiData typ, KnownSymbol field) => ToHttpApiData (NextRange (Range field typ)) where - toUrlPiece (NextRange r) = - toUrlPiece r +-- | Extract a 'Range' from a 'Ranges' +class ExtractRange (fields :: [Symbol]) (field :: Symbol) where + -- | Extract a 'Range' from a 'Ranges'. Works like a safe 'read', trying to coerce a 'Range' instance to + -- an expected type. Type annotation are most likely necessary to remove ambiguity. Note that a 'Range' + -- can only be extrated to a type bound by the allowed 'fields' on a given 'resource'. + -- + -- @ + -- extractDateRange :: 'Ranges' '["created_at", "name"] Resource -> 'Range' "created_at" 'Data.Time.Clock.UTCTime' + -- extractDateRange = + -- 'extractRange' + -- @ + extractRange + :: HasPagination resource field + => Ranges fields resource -- ^ A list of accepted Ranges for the API + -> Maybe (Range field (RangeType resource field)) -- ^ A Range instance of the expected type, if it matches -instance (ToHttpApiData (NextRange a), ToHttpApiData (NextRange b)) => ToHttpApiData (NextRange (a :|: b)) where - toUrlPiece (NextRange (InL a)) = - toUrlPiece (NextRange a) +instance ExtractRange (field ': fields) field where + extractRange (Ranges r) = Just r + extractRange (Lift _) = Nothing - toUrlPiece (NextRange (InR b)) = - toUrlPiece (NextRange b) +instance {-# OVERLAPPABLE #-} ExtractRange fields field => ExtractRange (y ': fields) field where + extractRange (Ranges _) = Nothing + extractRange (Lift r) = extractRange r --- | Type alias to declare response headers related to pagination -type PageHeaders range = - '[ Header "Accept-Ranges" (AcceptRanges range) - , Header "Content-Range" (ContentRange range) - , Header "Next-Range" (NextRange range) - , Header "Total-Count" Natural - ] - +-- | Put a 'Range' in a 'Ranges' +class PutRange (fields :: [Symbol]) (field :: Symbol) where + putRange + :: HasPagination resource field + => Range field (RangeType resource field) + -> Ranges fields resource --- --- DECLARE RANGES --- +instance PutRange (field ': fields) field where + putRange = Ranges --- | Default values to apply when parsing a Range -data FromRangeOptions = FromRangeOptions - { defaultRangeLimit :: Int - , defaultRangeOffset :: Int - , defaultRangeOrder :: RangeOrder - } deriving (Eq, Show) +instance {-# OVERLAPPABLE #-} (PutRange fields field) => PutRange (y ': fields) field where + putRange = Lift . putRange --- | Some default options of default values for a Range (limit 100; offset 0; order desc) -defaultOptions :: FromRangeOptions -defaultOptions = - FromRangeOptions 100 0 RangeDesc - +instance ToHttpApiData (Ranges fields resource) where + toUrlPiece (Lift range) = + toUrlPiece range --- | Some default range based on the default options -defaultRange :: Maybe a -> FromRangeOptions -> Range field a -defaultRange val opts = - let - (FromRangeOptions lim off ord) = - opts - in - Range val lim off ord + toUrlPiece (Ranges Range{..}) = + Text.pack (symbolVal rangeField) + <> maybe "" (\v -> " " <> toUrlPiece v) rangeValue + <> ";limit " <> toUrlPiece rangeLimit + <> ";offset " <> toUrlPiece rangeOffset + <> ";order " <> toUrlPiece rangeOrder --- | Parse a Range object from a `Range` request's header. Any `Range field typ` and combinations --- of any `Range field typ` provide instance of this class. It is a signature similar to --- `parseUrlPiece` from the `FromHttpApiData` class and can be used as a drop-in replacement to --- define instance of this class. --- --- > type MyRange = Range "created_at" UTCTime --- > --- > instance FromHttpApiData UTCTime => FromHttpApiData MyRange where --- > parseUrlPiece = --- > fromRange defaultOptions -class FromRange a where - parseRange :: FromRangeOptions -> Text -> Either Text a +instance FromHttpApiData (Ranges '[] resource) where + parseUrlPiece _ = + Left "Invalid Range" -instance (FromHttpApiData typ, KnownSymbol field) => FromRange (Range field typ) where - parseRange FromRangeOptions{..} txt = +instance + ( FromHttpApiData (Ranges fields resource) + , HasPagination resource field + , KnownSymbol field + , IsRangeType (RangeType resource field) + ) => FromHttpApiData (Ranges (field ': fields) resource) where + parseUrlPiece txt = let + RangeOptions{..} = getRangeOptions (Proxy @resource) (Proxy @field) + toTuples = filter (/= "") . Text.splitOn (Text.singleton ' ') @@ -198,21 +242,24 @@ map toTuples $ Text.splitOn (Text.singleton ';') txt field = - Text.pack $ symbolVal (Proxy :: Proxy field) + Text.pack $ symbolVal (Proxy @field) in case args of (field' : value) : rest | field == field' -> do opts <- traverse parseOpt rest - Range + range <- Range <$> sequence (fmap parseQueryParam (listToMaybe value)) - <*> ifOpt "limit" defaultRangeLimit opts - <*> ifOpt "offset" defaultRangeOffset opts - <*> ifOpt "order" defaultRangeOrder opts + <*> ifOpt "limit" defaultRangeLimit opts + <*> ifOpt "offset" defaultRangeOffset opts + <*> ifOpt "order" defaultRangeOrder opts + <*> pure (Proxy @field) + pure $ Ranges range + _ -> - Left "Invalid Range" + Lift <$> (parseUrlPiece txt :: Either Text (Ranges fields resource)) where parseOpt :: [Text] -> Either Text (Text, Text) parseOpt piece = @@ -227,107 +274,188 @@ ifOpt opt def = maybe (pure def) (parseQueryParam . snd) . find ((== opt) . fst) -instance {-# Overlappable #-} (FromHttpApiData typ, KnownSymbol field) => FromHttpApiData (Range field typ) where - parseUrlPiece = - parseRange defaultOptions +-- | Define the sorting order of the paginated resources (ascending or descending) +data RangeOrder + = RangeAsc + | RangeDesc + deriving (Eq, Show, Ord, Generic) -type TotalCount = - Maybe Natural +instance ToHttpApiData RangeOrder where + toUrlPiece order = + case order of + RangeAsc -> "asc" + RangeDesc -> "desc" +instance FromHttpApiData RangeOrder where + parseUrlPiece txt = + case txt of + "asc" -> pure RangeAsc + "desc" -> pure RangeDesc + _ -> Left "Invalid Range Order" + + +-- | Type alias to declare response headers related to pagination -- +-- @ +-- type MyHeaders = +-- 'PageHeaders' '["created_at"] Resource +-- +-- type API = "resources" +-- :> 'Servant.Header' \"Range\" ('Ranges' '["created_at"] Resource) +-- :> 'Servant.Get' '['Servant.JSON'] ('Servant.Headers' MyHeaders [Resource]) +-- @ +type PageHeaders (fields :: [Symbol]) (resource :: *) = + '[ Header "Accept-Ranges" (AcceptRanges fields) + , Header "Content-Range" (ContentRange fields resource) + , Header "Next-Range" (Ranges fields resource) + ] + +-- | Accepted Ranges in the `Accept-Ranges` response's header +data AcceptRanges (fields :: [Symbol]) = AcceptRanges + +instance (KnownSymbol field) => ToHttpApiData (AcceptRanges '[field]) where + toUrlPiece AcceptRanges = + Text.pack (symbolVal (Proxy @field)) + +instance (ToHttpApiData (AcceptRanges (f ': fs)), KnownSymbol field) => ToHttpApiData (AcceptRanges (field ': f ': fs)) where + toUrlPiece AcceptRanges = + Text.pack (symbolVal (Proxy @field)) <> "," <> toUrlPiece (AcceptRanges @(f ': fs)) + + +-- | Actual range returned, in the `Content-Range` response's header +data ContentRange (fields :: [Symbol]) resource = + forall field. (KnownSymbol field, ToHttpApiData (RangeType resource field)) => ContentRange + { contentRangeStart :: RangeType resource field + , contentRangeEnd :: RangeType resource field + , contentRangeField :: Proxy field + } + +instance ToHttpApiData (ContentRange fields res) where + toUrlPiece (ContentRange start end field) = + Text.pack (symbolVal field) <> " " <> toUrlPiece start <> ".." <> toUrlPiece end + + +-- -- USE RANGES -- --- | In addition to the `FromHttpApiData` instance, one can provide an instance for this --- type-class to easily lift a list of response to a Servant handler. --- By providing a getter to retrieve the value of an actual range from a resource, the --- `HasPagination` class provides `returnPage` to handle the plumbering of declaring --- response headers related to pagination. +-- | Available 'Range' on a given @resource@ must implements the 'HasPagination' type-class. +-- This class defines how the library can interact with a given @resource@ to access the value +-- to which a @field@ refers. class KnownSymbol field => HasPagination resource field where type RangeType resource field :: * - getRangeField :: Proxy field -> resource -> RangeType resource field + -- | Get the corressponding value of a Resource + getFieldValue :: Proxy field -> resource -> RangeType resource field - returnPage_ :: forall m ranges. - ( Monad m - , (Range field (RangeType resource field)) :<: ranges - , ToAcceptRanges ranges - , ToHttpApiData (ContentRange ranges) - , ToHttpApiData (NextRange ranges) - , Ord (RangeType resource field) - ) => (Range field (RangeType resource field)) -> [resource] -> m (Headers (PageHeaders ranges) [resource]) - returnPage_ = - returnPage Nothing - {-# INLINE returnPage_ #-} + -- | Get parsing options for the 'Range' defined on this 'field' + getRangeOptions :: Proxy resource -> Proxy field -> RangeOptions + getRangeOptions _ _ = defaultOptions - returnPage :: forall m ranges. - ( Monad m - , (Range field (RangeType resource field)) :<: ranges - , ToAcceptRanges ranges - , ToHttpApiData (ContentRange ranges) - , ToHttpApiData (NextRange ranges) - , Ord (RangeType resource field) - ) => TotalCount -> (Range field (RangeType resource field)) -> [resource] -> m (Headers (PageHeaders ranges) [resource]) - returnPage count range rs = do - let field = - Proxy :: Proxy field + -- | Create a default 'Range' from a value and default 'RangeOptions'. Typical use-case + -- is for when no or an invalid 'Range' header was provided. + getDefaultRange + :: IsRangeType (RangeType resource field) + => Proxy resource + -> Maybe (RangeType resource field) + -> Range field (RangeType resource field) + getDefaultRange _ val = + let + RangeOptions{..} = getRangeOptions (Proxy @resource) (Proxy @field) + in Range + { rangeValue = val + , rangeLimit = defaultRangeLimit + , rangeOffset = defaultRangeOffset + , rangeOrder = defaultRangeOrder + , rangeField = Proxy @field + } - let boundaries = (,) - <$> fmap (getRangeField field) (Safe.headMay rs) - <*> fmap (getRangeField field) (Safe.lastMay rs) +-- | Lift an API response in a 'Monad', typically a 'Servant.Server.Handler'. 'Ranges' headers can be quite cumbersome to +-- declare and can be deduced from the resources returned and the previous 'Range'. This is exactly what this function +-- does. +-- +-- @ +-- myHandler +-- :: 'Maybe' ('Ranges' '["created_at"] Resource) +-- -> 'Servant.Server.Handler' ('Servant.Headers' ('PageHeaders' '["created_at"] Resource) [Resource]) +-- myHandler mrange = +-- let range = +-- 'Data.Maybe.fromMaybe' ('getDefaultRange' ('Data.Proxy.Proxy' @Resource)) (mrange >>= 'extractRange') +-- +-- 'returnRange' range ('applyRange' range resources) +-- @ +returnRange + :: ( Monad m + , ToHttpApiData (AcceptRanges fields) + , KnownSymbol field + , HasPagination resource field + , IsRangeType (RangeType resource field) + , PutRange fields field + ) + => Range field (RangeType resource field) -- ^ Actual 'Range' used to retrieve the results + -> [resource] -- ^ Resources to returned, fetched from a db or a local store + -> m (Headers (PageHeaders fields resource) [resource]) -- ^ Resources embedded in a given 'Monad' (typically a 'Servant.Server.Handler', with pagination headers) +returnRange Range{..} rs = do + let boundaries = (,) + <$> fmap (getFieldValue rangeField) (Safe.headMay rs) + <*> fmap (getFieldValue rangeField) (Safe.lastMay rs) - let acceptRanges = - addHeader (AcceptRanges :: AcceptRanges ranges) + case boundaries of + Nothing -> + return $ addHeader AcceptRanges $ noHeader $ noHeader rs - let totalCount = - maybe noHeader addHeader count + Just (start, end) -> do + let nextOffset | rangeValue == Just end = rangeOffset + length rs + | otherwise = length $ takeWhile ((==) end . getFieldValue rangeField) (reverse rs) - case boundaries of - Nothing -> - return $ - acceptRanges $ noHeader $ noHeader $ totalCount rs + let nextRange = putRange Range + { rangeValue = Just end + , rangeLimit = rangeLimit + , rangeOffset = nextOffset + , rangeOrder = rangeOrder + , rangeField = rangeField + } - Just (start, end) -> do - let rangeStart = - liftRange $ (range { rangeValue = Just start } :: Range field (RangeType resource field)) + let contentRange = ContentRange + { contentRangeStart = start + , contentRangeEnd = end + , contentRangeField = rangeField + } - let rangeEnd = - liftRange $ (range { rangeValue = Just end } :: Range field (RangeType resource field)) + return $ addHeader AcceptRanges $ addHeader contentRange $ addHeader nextRange rs - let nextOffset | rangeValue range `compare` Just end == EQ = rangeOffset range + length rs - | otherwise = length $ takeWhile (\r -> getRangeField field r `compare` end == EQ) $ reverse rs - - let rangeNext = - liftRange $ (range { rangeValue = Just end, rangeOffset = nextOffset } :: Range field (RangeType resource field)) +-- | Default values to apply when parsing a 'Range' +data RangeOptions = RangeOptions + { defaultRangeLimit :: Int -- ^ Default limit if not provided, default to @100@ + , defaultRangeOffset :: Int -- ^ Default offset if not provided, default to @0@ + , defaultRangeOrder :: RangeOrder -- ^ Default order if not provided, default to 'RangeDesc' + } deriving (Eq, Show) - let contentRange = - addHeader $ ContentRange - { contentRangeStart = rangeStart - , contentRangeEnd = rangeEnd - } - let nextRange = - addHeader $ NextRange $ rangeNext - - return - $ acceptRanges $ contentRange $ nextRange $ totalCount rs +-- | Some default options of default values for a Range (limit 100; offset 0; order desc) +defaultOptions :: RangeOptions +defaultOptions = + RangeOptions 100 0 RangeDesc --- | Apply a range to a list of element -applyRange :: forall b field. (HasPagination b field, Ord (RangeType b field)) => Range field (RangeType b field) -> [b] -> [b] +-- | Helper to apply a 'Range' to a list of values. Most likely useless in practice +-- as results may come more realistically from a database, but useful for debugging or +-- testing. +applyRange + :: HasPagination resource field + => Range field (RangeType resource field) -- ^ A 'Range' instance on a given @resource@ + -> [resource] -- ^ A full-list of @resource@ + -> [resource] -- ^ The sublist obtained by applying the 'Range' applyRange Range{..} = let - field = - Proxy :: Proxy (field :: Symbol) - sortRel = case rangeOrder of RangeDesc -> - \a b -> compare (getRangeField field b) (getRangeField field a) + \a b -> compare (getFieldValue rangeField b) (getFieldValue rangeField a) RangeAsc -> - \a b -> compare (getRangeField field a) (getRangeField field b) + \a b -> compare (getFieldValue rangeField a) (getFieldValue rangeField b) dropRel = case (rangeValue, rangeOrder) of @@ -335,10 +463,10 @@ const False (Just a, RangeDesc) -> - (> a) . (getRangeField field) + (> a) . getFieldValue rangeField (Just a, RangeAsc) -> - (< a) . (getRangeField field) + (< a) . getFieldValue rangeField in List.take rangeLimit . List.drop rangeOffset diff --git a/src/Servant/Pagination/Internal.hs b/src/Servant/Pagination/Internal.hs deleted file mode 100644 --- a/src/Servant/Pagination/Internal.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Servant.Pagination.Internal where - -import Data.Kind (Constraint) -import Data.Proxy (Proxy (..)) -import Data.Semigroup ((<>)) -import Data.Text (Text) -import Servant (FromHttpApiData (..), ToHttpApiData (..)) - - --- | Helper to execute two `Either a b` successively -orElse :: Either a b -> Either a b -> Either a b -orElse a b = - either (const b) (const a) a -{-# INLINE orElse #-} - - --- | Representation of AcceptRanges as a list of comma-separated text fields from the type --- of a Range only (value isn't needed here since only the 'field' matters) -class ToAcceptRanges r where - toAcceptRanges :: Proxy r -> Text - - --- | Combine two ranges in a new range, parsing is done left-first -data a :|: b = InL a | InR b -infixl 7 :|: - -instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (a :|: b) where - toUrlPiece (InL a) = - toUrlPiece a - - toUrlPiece (InR b) = - toUrlPiece b - -instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (a :|: b) where - parseUrlPiece txt = - (liftRange <$> (parseUrlPiece txt :: Either Text a)) - `orElse` (liftRange <$> (parseUrlPiece txt :: Either Text b)) - -instance (ToAcceptRanges a, ToAcceptRanges b) => ToAcceptRanges (a :|: b) where - toAcceptRanges _ = - toAcceptRanges (Proxy :: Proxy a) <> "," <> toAcceptRanges (Proxy :: Proxy b) - - --- | Type family helper to define a constraint about ranges -type family InRanges r rs :: Constraint where - InRanges r r = () - InRanges r (rs :|: r) = () - InRanges r (rs :|: r') = InRanges r rs - - --- | Relation for lifting range into a combination of ranges -class range :<: ranges where - liftRange :: range -> ranges - -instance r :<: r where - liftRange = id - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2) where - liftRange = InL - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r) where - liftRange = InR - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r :|: r3) where - liftRange = InL . InR - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2 :|: r3) where - liftRange = InL . InL - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r :|: r3 :|: r4) where - liftRange = InL . InL . InR - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2 :|: r3 :|: r4) where - liftRange = InL . InL . InL - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r :|: r3 :|: r4 :|: r5) where - liftRange = InL . InL . InL . InR - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2 :|: r3 :|: r4 :|: r5) where - liftRange = InL . InL . InL . InL - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r :|: r3 :|: r4 :|: r5 :|: r6) where - liftRange = InL . InL . InL . InL . InR - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2 :|: r3 :|: r4 :|: r5 :|: r6) where - liftRange = InL . InL . InL . InL . InL - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r :|: r3 :|: r4 :|: r5 :|: r6 :|: r7) where - liftRange = InL . InL . InL . InL . InL . InR - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2 :|: r3 :|: r4 :|: r5 :|: r6 :|: r7) where - liftRange = InL . InL . InL . InL . InL . InL - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r :|: r3 :|: r4 :|: r5 :|: r6 :|: r7 :|: r8) where - liftRange = InL . InL . InL . InL . InL . InL . InR - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2 :|: r3 :|: r4 :|: r5 :|: r6 :|: r7 :|: r8) where - liftRange = InL . InL . InL . InL . InL . InL . InL - {-# INLINE liftRange #-} - -instance r :<: (r1 :|: r :|: r3 :|: r4 :|: r5 :|: r6 :|: r7 :|: r8 :|: r9) where - liftRange = InL . InL . InL . InL . InL . InL . InL . InR - {-# INLINE liftRange #-} - -instance r :<: (r :|: r2 :|: r3 :|: r4 :|: r5 :|: r6 :|: r7 :|: r8 :|: r9) where - liftRange = InL . InL . InL . InL . InL . InL . InL . InL - {-# INLINE liftRange #-} diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +resolver: lts-10.3 +packages: +- . +extra-deps: [] +extra-package-dbs: []