diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +import Distribution.Simple + + +main = + defaultMain diff --git a/examples/Color.hs b/examples/Color.hs new file mode 100644 --- /dev/null +++ b/examples/Color.hs @@ -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" + ] diff --git a/examples/Complex.hs b/examples/Complex.hs new file mode 100644 --- /dev/null +++ b/examples/Complex.hs @@ -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 diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Simple.hs @@ -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 diff --git a/servant-pagination.cabal b/servant-pagination.cabal new file mode 100644 --- /dev/null +++ b/servant-pagination.cabal @@ -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 , Matthias Benkort +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 diff --git a/src/Servant/Pagination.hs b/src/Servant/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Pagination.hs @@ -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 diff --git a/src/Servant/Pagination/Internal.hs b/src/Servant/Pagination/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Pagination/Internal.hs @@ -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 #-}