servant-pagination (empty) → 1.0.0
raw patch · 8 files changed
+1057/−0 lines, 8 filesdep +aesondep +basedep +safesetup-changed
Dependencies added: aeson, base, safe, servant, servant-pagination, servant-server, text, warp
Files
- LICENSE +165/−0
- Setup.hs +5/−0
- examples/Color.hs +88/−0
- examples/Complex.hs +121/−0
- examples/Simple.hs +78/−0
- servant-pagination.cabal +131/−0
- src/Servant/Pagination.hs +346/−0
- src/Servant/Pagination/Internal.hs +123/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,5 @@+import Distribution.Simple+++main =+ defaultMain
+ examples/Color.hs view
@@ -0,0 +1,88 @@+module Color where++import Data.Aeson (ToJSON)+import GHC.Generics (Generic)+import Numeric.Natural (Natural)++import qualified Data.Aeson as Aeson+++data Color = Color+ { name :: String+ , rgb :: [Int]+ , hex :: String+ } deriving (Eq, Show, Generic)+++instance ToJSON Color where+ toJSON =+ Aeson.genericToJSON Aeson.defaultOptions+++nColors :: Natural+nColors =+ fromIntegral $ length colors+++colors :: [Color]+colors =+ [ Color "Aqua" [0, 255, 255] "#00ffff"+ , Color "Black" [0, 0, 0] "#000000"+ , Color "Blue" [0, 0, 255] "#0000ff"+ , Color "BlueViolet" [95, 0, 255] "#5f00ff"+ , Color "CadetBlue" [95, 175, 135] "#5faf87"+ , Color "CadetBlue" [95, 175, 175] "#5fafaf"+ , Color "CornflowerBlue" [95, 135, 255] "#5f87ff"+ , Color "DarkBlue" [0, 0, 135] "#000087"+ , Color "DarkCyan" [0, 175, 135] "#00af87"+ , Color "DarkGoldenrod" [175, 135, 0] "#af8700"+ , Color "DarkGreen" [0, 95, 0] "#005f00"+ , Color "DarkKhaki" [175, 175, 95] "#afaf5f"+ , Color "DarkMagenta" [135, 0, 135] "#870087"+ , Color "DarkMagenta" [135, 0, 175] "#8700af"+ , Color "DarkOrange" [255, 135, 0] "#ff8700"+ , Color "DarkRed" [135, 0, 0] "#870000"+ , Color "DarkRed" [95, 0, 0] "#5f0000"+ , Color "DarkSeaGreen" [135, 175, 135] "#87af87"+ , Color "DarkTurquoise" [0, 215, 215] "#00d7d7"+ , Color "DarkViolet" [135, 0, 215] "#8700d7"+ , Color "DarkViolet" [175, 0, 215] "#af00d7"+ , Color "Fuchsia" [255, 0, 255] "#ff00ff"+ , Color "Green" [0, 128, 0] "#008000"+ , Color "GreenYellow" [175, 255, 0] "#afff00"+ , Color "Grey" [128, 128, 128] "#808080"+ , Color "HotPink" [255, 95, 175] "#ff5faf"+ , Color "HotPink" [255, 95, 215] "#ff5fd7"+ , Color "IndianRed" [175, 95, 95] "#af5f5f"+ , Color "IndianRed" [215, 95, 95] "#d75f5f"+ , Color "LightCoral" [255, 135, 135] "#ff8787"+ , Color "LightGreen" [135, 255, 135] "#87ff87"+ , Color "LightGreen" [135, 255, 95] "#87ff5f"+ , Color "LightSeaGreen" [0, 175, 175] "#00afaf"+ , Color "LightSlateBlue" [135, 135, 255] "#8787ff"+ , Color "LightSlateGrey" [135, 135, 175] "#8787af"+ , Color "LightSteelBlue" [175, 175, 255] "#afafff"+ , Color "Lime" [0, 255, 0] "#00ff00"+ , Color "Maroon" [128, 0, 0] "#800000"+ , Color "MediumOrchid" [175, 95, 215] "#af5fd7"+ , Color "MediumPurple" [135, 135, 215] "#8787d7"+ , Color "MediumSpringGreen" [0, 255, 175] "#00ffaf"+ , Color "MediumTurquoise" [95, 215, 215] "#5fd7d7"+ , Color "MediumVioletRed" [175, 0, 135] "#af0087"+ , Color "Navy" [0, 0, 128] "#000080"+ , Color "NavyBlue" [0, 0, 95] "#00005f"+ , Color "Olive" [128, 128, 0] "#808000"+ , Color "Orchid" [215, 95, 215] "#d75fd7"+ , Color "Purple" [128, 0, 128] "#800080"+ , Color "Purple" [135, 0, 255] "#8700ff"+ , Color "Purple" [175, 0, 255] "#af00ff"+ , Color "Red" [255, 0, 0] "#ff0000"+ , Color "RosyBrown" [175, 135, 135] "#af8787"+ , Color "SandyBrown" [255, 175, 95] "#ffaf5f"+ , Color "Silver" [192, 192, 192] "#c0c0c0"+ , Color "Tan" [215, 175, 135] "#d7af87"+ , Color "Teal" [0, 128, 128] "#008080"+ , Color "Violet" [215, 135, 255] "#d787ff"+ , Color "White" [255, 255, 255] "#ffffff"+ , Color "Yellow" [255, 255, 0] "#ffff00"+ ]
+ examples/Complex.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Data.Proxy (Proxy (..))+import Servant+import Servant.Pagination++import qualified Network.Wai.Handler.Warp as Warp++import Color+++-- 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++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++instance FromHttpApiData RGBRange where+ parseUrlPiece =+ parseRange myOpts++instance HasPagination Color "rgb" where+ type RangeType Color "rgb" = Int++ getRangeField _ =+ sum . rgb+++-- API++type API =+ "colors"+ :> Header "Range" (NameRange :|: RGBRange)+ :> GetPartialContent '[JSON] (Headers MyHeaders [Color])++type MyHeaders =+ PageHeaders (NameRange :|: RGBRange)+++-- Application++server :: Server API+server mrange = do+ let range =+ defaultRange Nothing myOpts :: NameRange++ case mrange of+ Nothing ->+ returnPage (Just nColors) range (applyRange range colors)++ Just (InL nameRange) ->+ returnPage (Just nColors) nameRange (applyRange nameRange colors)++ Just (InR rgbRange) ->+ returnPage (Just nColors) rgbRange (applyRange rgbRange colors)+++main :: IO ()+main =+ Warp.run 1337 (serve (Proxy :: Proxy API) server)+++-- Examples++-- $ curl -v http://localhost:1337/colors+--+-- > GET /colors HTTP/1.1+--+-- < HTTP/1.1 206 Partial Content+-- < 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+-- < Total-Count: 59+++-- $ curl -v http://localhost:1337/colors --header 'Range: rgb'+--+-- > GET /colors HTTP/1.1+-- > Range: rgb+--+-- < 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+-- < Total-Count: 59+++-- $ curl -v http://localhost:1337/colors --header 'Range: name Green; limit 10; order desc'+--+-- > Get /colors HTTP/1.1+-- > Range: name; limit 10; order desc+-- >+-- < 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+-- < Total-Count: 59
+ examples/Simple.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy (..))+import Servant+import Servant.Pagination++import qualified Network.Wai.Handler.Warp as Warp++import Color+++-- 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++-- API++type API =+ "colors"+ :> Header "Range" NameRange+ :> GetPartialContent '[JSON] (Headers (PageHeaders NameRange) [Color])+++-- Application++server :: Server API+server mrange = do+ let range =+ fromMaybe (defaultRange Nothing defaultOptions) mrange++ returnPage (Just nColors) range (applyRange range colors)++main :: IO ()+main =+ Warp.run 1337 (serve (Proxy :: Proxy API) server)+++-- Examples++-- $ curl -v http://localhost:1337/colors+--+-- > 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..Aqua+-- < Next-Range: name Aqua;limit 100;offset 0;order desc+-- < Total-Count: 59+++-- $ curl -v http://localhost:1337/colors --header 'Range: name; offset 59'+--+-- > GET /colors HTTP/1.1+-- > Range: name; offset 59+-- >+-- < HTTP/1.1 206 Partial Content+-- < Content-Type: application/json;charset=utf-8+-- < Accept-Ranges: name+-- < Total-Count: 59
+ servant-pagination.cabal view
@@ -0,0 +1,131 @@+name: servant-pagination+synopsis: Type-safe pagination for Servant APIs+description: This module offers opinionated helpers to declare a type-safe and a flexible pagination+ mecanism for Servant APIs. This design, inspired by Heroku's API, 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.)+version: 1.0.0+homepage: https://github.com/chordify/haskell-servant-pagination+bug-reports: https://github.com/chordify/haskell-servant-pagination/issues+license: LGPL-3+license-file: LICENSE+author: Chordify+maintainer: Chordify <haskelldevelopers@chordify.net>, Matthias Benkort <matthias.benkort@gmail.com>+copyright: (c) 2018 Chordify+category: Web+build-type: Simple+cabal-version: >=1.20++source-repository head+ type: git+ location: git://github.com/chordify/haskell-servant-pagination.git++flag examples+ description: build examples executables+ default: False+ manual: True++library+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -j4+ default-extensions: BangPatterns+ , DefaultSignatures+ , DataKinds+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveGeneric+ , ExistentialQuantification+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , KindSignatures+ , MultiParamTypeClasses+ , OverloadedStrings+ , ParallelListComp+ , RecordWildCards+ , TupleSections+ , ScopedTypeVariables+ , TypeOperators++ build-depends: base >= 4 && < 5+ , text >= 1.2 && < 2+ , servant >= 0.11 && < 1+ , servant-server >= 0.11 && < 1+ , safe >= 0.3 && < 1++ exposed-modules: Servant.Pagination+ , Servant.Pagination.Internal++executable servant-pagination-simple+ if !flag(examples)+ buildable: False+ hs-source-dirs: examples+ default-language: Haskell2010+ main-is: Simple.hs+ ghc-options: -Wall -j4 -threaded -rtsopts -with-rtsopts=-N++ default-extensions: BangPatterns+ , DefaultSignatures+ , DataKinds+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveGeneric+ , ExistentialQuantification+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , KindSignatures+ , MultiParamTypeClasses+ , OverloadedStrings+ , ParallelListComp+ , RecordWildCards+ , TupleSections+ , ScopedTypeVariables+ , TypeOperators++ build-depends: base >= 4 && < 5+ , aeson >= 1.2 && < 2+ , servant >= 0.11 && < 1+ , servant-pagination >= 1 && < 2+ , servant-server >= 0.11 && < 1+ , warp >= 3.2 && < 4++ other-modules: Color++executable servant-pagination-complex+ if !flag(examples)+ buildable: False+ hs-source-dirs: examples+ default-language: Haskell2010+ main-is: Complex.hs+ ghc-options: -Wall -j4 -threaded -rtsopts -with-rtsopts=-N++ default-extensions: BangPatterns+ , DefaultSignatures+ , DataKinds+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveGeneric+ , ExistentialQuantification+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , KindSignatures+ , MultiParamTypeClasses+ , OverloadedStrings+ , ParallelListComp+ , RecordWildCards+ , TupleSections+ , ScopedTypeVariables+ , TypeOperators++ build-depends: base >= 4 && < 5+ , aeson >= 1.2 && < 2+ , servant >= 0.11 && < 1+ , servant-pagination >= 1 && < 2+ , servant-server >= 0.11 && < 1+ , warp >= 3.2 && < 4++ other-modules: Color
+ src/Servant/Pagination.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE TypeFamilies #-}++module Servant.Pagination+ (+ -- * Types+ Range(..)+ , RangeOrder(..)+ , AcceptRanges (..)+ , ContentRange (..)+ , NextRange (..)+ , PageHeaders+ , TotalCount++ -- * Declare Ranges+ , FromRange(..)+ , FromHttpApiData(..)+ , FromRangeOptions(..)+ , defaultOptions+ , defaultRange++ -- * Use Ranges+ , HasPagination(..)+ , 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 Servant++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+ , 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+ }++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++instance (ToHttpApiData (NextRange a), ToHttpApiData (NextRange b)) => ToHttpApiData (NextRange (a :|: b)) where+ toUrlPiece (NextRange (InL a)) =+ toUrlPiece (NextRange a)++ toUrlPiece (NextRange (InR b)) =+ toUrlPiece (NextRange b)+++-- | 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+ ]+++--+-- DECLARE RANGES+--++-- | Default values to apply when parsing a Range+data FromRangeOptions = FromRangeOptions+ { defaultRangeLimit :: Int+ , defaultRangeOffset :: Int+ , defaultRangeOrder :: RangeOrder+ } deriving (Eq, Show)+++-- | Some default options of default values for a Range (limit 100; offset 0; order desc)+defaultOptions :: FromRangeOptions+defaultOptions =+ FromRangeOptions 100 0 RangeDesc+++-- | 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+++-- | 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 typ, KnownSymbol field) => FromRange (Range field typ) where+ parseRange FromRangeOptions{..} txt =+ let+ toTuples =+ filter (/= "") . Text.splitOn (Text.singleton ' ')++ args =+ map toTuples $ Text.splitOn (Text.singleton ';') txt++ field =+ Text.pack $ symbolVal (Proxy :: Proxy field)+ in+ case args of+ (field' : value) : rest | field == field' -> do+ opts <-+ traverse parseOpt rest++ Range+ <$> sequence (fmap parseQueryParam (listToMaybe value))+ <*> ifOpt "limit" defaultRangeLimit opts+ <*> ifOpt "offset" defaultRangeOffset opts+ <*> ifOpt "order" defaultRangeOrder opts++ _ ->+ Left "Invalid Range"+ where+ parseOpt :: [Text] -> Either Text (Text, Text)+ parseOpt piece =+ case piece of+ [opt, arg] ->+ pure (opt, arg)++ _ ->+ Left "Invalid Range Options"++ ifOpt :: FromHttpApiData o => Text -> o -> [(Text, Text)] -> Either Text o+ 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+++type TotalCount =+ Maybe Natural++--+-- 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.+class KnownSymbol field => HasPagination resource field where+ type RangeType resource field :: *++ getRangeField :: 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_ #-}++ 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++ let boundaries = (,)+ <$> fmap (getRangeField field) (Safe.headMay rs)+ <*> fmap (getRangeField field) (Safe.lastMay rs)++ let acceptRanges =+ addHeader (AcceptRanges :: AcceptRanges ranges)++ let totalCount =+ maybe noHeader addHeader count++ case boundaries of+ Nothing ->+ return $+ acceptRanges $ noHeader $ noHeader $ totalCount rs++ Just (start, end) -> do+ let rangeStart =+ liftRange $ (range { rangeValue = Just start } :: Range field (RangeType resource field))++ let rangeEnd =+ liftRange $ (range { rangeValue = Just end } :: Range field (RangeType resource field))++ 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))++ let contentRange =+ addHeader $ ContentRange+ { contentRangeStart = rangeStart+ , contentRangeEnd = rangeEnd+ }++ let nextRange =+ addHeader $ NextRange $ rangeNext++ return+ $ acceptRanges $ contentRange $ nextRange $ totalCount rs+++-- | 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]+applyRange Range{..} =+ let+ field =+ Proxy :: Proxy (field :: Symbol)++ sortRel =+ case rangeOrder of+ RangeDesc ->+ \a b -> compare (getRangeField field b) (getRangeField field a)++ RangeAsc ->+ \a b -> compare (getRangeField field a) (getRangeField field b)++ dropRel =+ case (rangeValue, rangeOrder) of+ (Nothing, _) ->+ const False++ (Just a, RangeDesc) ->+ (> a) . (getRangeField field)++ (Just a, RangeAsc) ->+ (< a) . (getRangeField field)+ in+ List.take rangeLimit+ . List.drop rangeOffset+ . List.dropWhile dropRel+ . List.sortBy sortRel
+ src/Servant/Pagination/Internal.hs view
@@ -0,0 +1,123 @@+{-# 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 #-}