servant-pagination 1.0.0 → 2.0.0

raw patch · 10 files changed

+628/−429 lines, 10 filesdep ~servantdep ~servant-paginationdep ~servant-serverPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: servant, servant-pagination, servant-server

API changes (from Hackage documentation)

Files

• .stylish-haskell.yaml +41/−0
• CHANGELOG.md +16/−0
• README.md +131/−0
• examples/Color.hs +3/−9
• examples/Complex.hs +49/−44
• examples/Simple.hs +12/−15
• servant-pagination.cabal +15/−10
• src/Servant/Pagination.hs +356/−228
• src/Servant/Pagination/Internal.hs +0/−123
• stack.yaml +5/−0

@@ -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: {}

@@ -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

@@ -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: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]`++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)

@@ -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]

@@ -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

@@ -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

@@ -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

@@ -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: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]+--+-- 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

@@ -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 #-}

@@ -0,0 +1,5 @@+resolver: lts-10.3+packages:+- .+extra-deps: []+extra-package-dbs: []