{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeApplications #-}

-- | 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)
--
-- 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)
-- @
module Servant.Pagination
  (
  -- * Types
  Ranges
  , Range(..)
  , RangeOrder(..)
  , AcceptRanges (..)
  , ContentRange (..)
  , PageHeaders
  , IsRangeType

  -- * Declare Ranges
  , HasPagination(..)
  , RangeOptions(..)
  , defaultOptions

  -- * Use Ranges
  , extractRange
  , putRange
  , returnRange
  , applyRange
  ) where

import           Data.List          (filter, find, intercalate)
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           Network.URI.Encode (decodeText, encodeText)
import           Servant

import qualified Data.List          as List
import qualified Data.Text          as Text
import qualified Safe


--
-- TYPES
--

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

instance (Show (Ranges '[] res)) where
  showsPrec :: Int -> Ranges '[] res -> ShowS
showsPrec Int
_ Ranges '[] res
_ = (String -> ShowS) -> String -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ShowS
forall a. Monoid a => a -> a -> a
mappend String
"Ranges"

instance (Show (Ranges fields res)) => Show (Ranges (field ': fields) res) where
  showsPrec :: Int -> Ranges (field : fields) res -> ShowS
showsPrec Int
prec (Lift Ranges fields res
r)   String
s = Int -> Ranges fields res -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
prec Ranges fields res
r String
s
  showsPrec Int
prec (Ranges Range field (RangeType res field)
r) String
s =
    let
      inner :: String
inner = String
"Ranges@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Range field (RangeType res field) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Range field (RangeType res field)
Range field (RangeType res field)
r String
s
    in
      if Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10 then String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inner String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")" else String
inner


-- | An actual 'Range' instance obtained from parsing / to generate a @Range@ HTTP Header.
data Range (field :: Symbol) (a :: *) =
  (KnownSymbol field, IsRangeType a) => Range
  { Range field a -> Maybe a
rangeValue  :: Maybe a     -- ^ The value of that field, beginning of the range
  , Range field a -> Int
rangeLimit  :: Int         -- ^ Maximum number of resources to return
  , Range field a -> Int
rangeOffset :: Int         -- ^ Offset, number of resources to skip after the starting value
  , Range field a -> RangeOrder
rangeOrder  :: RangeOrder  -- ^ The order of sorting (ascending or descending)
  , Range field a -> Proxy field
rangeField  :: Proxy field -- ^ Actual field this Range actually refers to
  }

instance Eq (Range field a) where
  (Range Maybe a
val0 Int
lim0 Int
off0 RangeOrder
ord0 Proxy field
_) == :: Range field a -> Range field a -> Bool
== (Range Maybe a
val1 Int
lim1 Int
off1 RangeOrder
ord1 Proxy field
_) =
       Maybe a
val0 Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe a
val1
    Bool -> Bool -> Bool
&& Int
lim0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lim1
    Bool -> Bool -> Bool
&& Int
off0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
off1
    Bool -> Bool -> Bool
&& RangeOrder
ord0 RangeOrder -> RangeOrder -> Bool
forall a. Eq a => a -> a -> Bool
== RangeOrder
ord1

instance Show (Range field a) where
  showsPrec :: Int -> Range field a -> ShowS
showsPrec Int
prec Range{Int
Maybe a
Proxy field
RangeOrder
rangeField :: Proxy field
rangeOrder :: RangeOrder
rangeOffset :: Int
rangeLimit :: Int
rangeValue :: Maybe a
rangeField :: forall (field :: Symbol) a. Range field a -> Proxy field
rangeOrder :: forall (field :: Symbol) a. Range field a -> RangeOrder
rangeOffset :: forall (field :: Symbol) a. Range field a -> Int
rangeLimit :: forall (field :: Symbol) a. Range field a -> Int
rangeValue :: forall (field :: Symbol) a. Range field a -> Maybe a
..} =
    let
      inner :: String
inner = String
"Range {" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
args String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
      args :: String
args  = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
        [ String
"rangeValue = "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe a -> String
forall a. Show a => a -> String
show Maybe a
rangeValue
        , String
"rangeLimit = "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rangeLimit
        , String
"rangeOffset = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rangeOffset
        , String
"rangeOrder = "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ RangeOrder -> String
forall a. Show a => a -> String
show RangeOrder
rangeOrder
        , String
"rangeField = "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy field
rangeField String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
        ]
    in
      (String -> ShowS) -> String -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ShowS
forall a. Monoid a => a -> a -> a
mappend (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ if Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10 then
        String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inner String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
      else
        String
inner


-- | 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 extracted 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 ExtractRange (field ': fields) field where
  extractRange :: Ranges (field : fields) resource
-> Maybe (Range field (RangeType resource field))
extractRange (Ranges Range field (RangeType resource field)
r) = Range field (RangeType resource field)
-> Maybe (Range field (RangeType resource field))
forall a. a -> Maybe a
Just Range field (RangeType resource field)
Range field (RangeType resource field)
r
  extractRange (Lift Ranges fields resource
_)   = Maybe (Range field (RangeType resource field))
forall a. Maybe a
Nothing
  {-# INLINE extractRange #-}

instance {-# OVERLAPPABLE #-} ExtractRange fields field => ExtractRange (y ': fields) field where
  extractRange :: Ranges (y : fields) resource
-> Maybe (Range field (RangeType resource field))
extractRange (Ranges Range field (RangeType resource field)
_) = Maybe (Range field (RangeType resource field))
forall a. Maybe a
Nothing
  extractRange (Lift Ranges fields resource
r)   = Ranges fields resource
-> Maybe (Range field (RangeType resource field))
forall (fields :: [Symbol]) (field :: Symbol) resource.
(ExtractRange fields field, HasPagination resource field) =>
Ranges fields resource
-> Maybe (Range field (RangeType resource field))
extractRange Ranges fields resource
r
  {-# INLINE extractRange #-}


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

instance PutRange (field ': fields) field where
  putRange :: Range field (RangeType resource field)
-> Ranges (field : fields) resource
putRange = Range field (RangeType resource field)
-> Ranges (field : fields) resource
forall resource (field :: Symbol) (fields :: [Symbol]).
HasPagination resource field =>
Range field (RangeType resource field)
-> Ranges (field : fields) resource
Ranges
  {-# INLINE putRange #-}

instance {-# OVERLAPPABLE #-} (PutRange fields field) => PutRange (y ': fields) field where
  putRange :: Range field (RangeType resource field)
-> Ranges (y : fields) resource
putRange = Ranges fields resource -> Ranges (y : fields) resource
forall (fields :: [Symbol]) resource (y :: Symbol).
Ranges fields resource -> Ranges (y : fields) resource
Lift (Ranges fields resource -> Ranges (y : fields) resource)
-> (Range field (RangeType resource field)
    -> Ranges fields resource)
-> Range field (RangeType resource field)
-> Ranges (y : fields) resource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range field (RangeType resource field) -> Ranges fields resource
forall (fields :: [Symbol]) (field :: Symbol) resource.
(PutRange fields field, HasPagination resource field) =>
Range field (RangeType resource field) -> Ranges fields resource
putRange
  {-# INLINE putRange #-}


instance ToHttpApiData (Ranges fields resource) where
  toUrlPiece :: Ranges fields resource -> Text
toUrlPiece (Lift Ranges fields resource
range) =
    Ranges fields resource -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece Ranges fields resource
range

  toUrlPiece (Ranges Range{Int
Maybe (RangeType resource field)
Proxy field
RangeOrder
rangeField :: Proxy field
rangeOrder :: RangeOrder
rangeOffset :: Int
rangeLimit :: Int
rangeValue :: Maybe (RangeType resource field)
rangeField :: forall (field :: Symbol) a. Range field a -> Proxy field
rangeOrder :: forall (field :: Symbol) a. Range field a -> RangeOrder
rangeOffset :: forall (field :: Symbol) a. Range field a -> Int
rangeLimit :: forall (field :: Symbol) a. Range field a -> Int
rangeValue :: forall (field :: Symbol) a. Range field a -> Maybe a
..}) =
    String -> Text
Text.pack (Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy field
rangeField)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
-> (RangeType resource field -> Text)
-> Maybe (RangeType resource field)
-> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\RangeType resource field
v -> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
encodeText (Text -> Text)
-> (RangeType resource field -> Text)
-> RangeType resource field
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeType resource field -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece) RangeType resource field
v) Maybe (RangeType resource field)
rangeValue
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";limit "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece Int
rangeLimit
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";offset " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece Int
rangeOffset
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";order "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RangeOrder -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece RangeOrder
rangeOrder


instance FromHttpApiData (Ranges '[] resource) where
  parseUrlPiece :: Text -> Either Text (Ranges '[] resource)
parseUrlPiece Text
_ =
    Text -> Either Text (Ranges '[] resource)
forall a b. a -> Either a b
Left Text
"Invalid Range"

instance
  ( FromHttpApiData (Ranges fields resource)
  , HasPagination resource field
  , KnownSymbol field
  , IsRangeType (RangeType resource field)
  ) => FromHttpApiData (Ranges (field ': fields) resource) where
  parseUrlPiece :: Text -> Either Text (Ranges (field : fields) resource)
parseUrlPiece Text
txt =
    let
      RangeOptions{Int
RangeOrder
defaultRangeOrder :: RangeOptions -> RangeOrder
defaultRangeOffset :: RangeOptions -> Int
defaultRangeLimit :: RangeOptions -> Int
defaultRangeOrder :: RangeOrder
defaultRangeOffset :: Int
defaultRangeLimit :: Int
..} = Proxy field -> Proxy resource -> RangeOptions
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> Proxy resource -> RangeOptions
getRangeOptions (Proxy field
forall k (t :: k). Proxy t
Proxy @field) (Proxy resource
forall k (t :: k). Proxy t
Proxy @resource)

      toTuples :: Text -> [Text]
toTuples =
        (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
Text.splitOn (Char -> Text
Text.singleton Char
' ')

      args :: [[Text]]
args =
        (Text -> [Text]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Text]
toTuples ([Text] -> [[Text]]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Text.splitOn (Char -> Text
Text.singleton Char
';') Text
txt

      field :: Text
field =
        String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy field
forall k (t :: k). Proxy t
Proxy @field)
    in
      case [[Text]]
args of
        (Text
field' : [Text]
value) : [[Text]]
rest | Text
field Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
field' -> do
          [(Text, Text)]
opts <-
            ([Text] -> Either Text (Text, Text))
-> [[Text]] -> Either Text [(Text, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [Text] -> Either Text (Text, Text)
parseOpt [[Text]]
rest

          Range field (RangeType resource field)
range <- Maybe (RangeType resource field)
-> Int
-> Int
-> RangeOrder
-> Proxy field
-> Range field (RangeType resource field)
forall (field :: Symbol) a.
(KnownSymbol field, IsRangeType a) =>
Maybe a -> Int -> Int -> RangeOrder -> Proxy field -> Range field a
Range
            (Maybe (RangeType resource field)
 -> Int
 -> Int
 -> RangeOrder
 -> Proxy field
 -> Range field (RangeType resource field))
-> Either Text (Maybe (RangeType resource field))
-> Either
     Text
     (Int
      -> Int
      -> RangeOrder
      -> Proxy field
      -> Range field (RangeType resource field))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either Text (RangeType resource field))
-> Maybe Text -> Either Text (Maybe (RangeType resource field))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> Either Text (RangeType resource field)
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece (Text -> Either Text (RangeType resource field))
-> (Text -> Text) -> Text -> Either Text (RangeType resource field)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
decodeText) ([Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text]
value)
            Either
  Text
  (Int
   -> Int
   -> RangeOrder
   -> Proxy field
   -> Range field (RangeType resource field))
-> Either Text Int
-> Either
     Text
     (Int
      -> RangeOrder
      -> Proxy field
      -> Range field (RangeType resource field))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Int -> [(Text, Text)] -> Either Text Int
forall o.
FromHttpApiData o =>
Text -> o -> [(Text, Text)] -> Either Text o
ifOpt Text
"limit"  Int
defaultRangeLimit [(Text, Text)]
opts Either Text Int -> (Int -> Either Text Int) -> Either Text Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Either Text Int
checkLimit)
            Either
  Text
  (Int
   -> RangeOrder
   -> Proxy field
   -> Range field (RangeType resource field))
-> Either Text Int
-> Either
     Text
     (RangeOrder
      -> Proxy field -> Range field (RangeType resource field))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Int -> [(Text, Text)] -> Either Text Int
forall o.
FromHttpApiData o =>
Text -> o -> [(Text, Text)] -> Either Text o
ifOpt Text
"offset" Int
defaultRangeOffset [(Text, Text)]
opts
            Either
  Text
  (RangeOrder
   -> Proxy field -> Range field (RangeType resource field))
-> Either Text RangeOrder
-> Either
     Text (Proxy field -> Range field (RangeType resource field))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> RangeOrder -> [(Text, Text)] -> Either Text RangeOrder
forall o.
FromHttpApiData o =>
Text -> o -> [(Text, Text)] -> Either Text o
ifOpt Text
"order"  RangeOrder
defaultRangeOrder [(Text, Text)]
opts
            Either Text (Proxy field -> Range field (RangeType resource field))
-> Either Text (Proxy field)
-> Either Text (Range field (RangeType resource field))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy field -> Either Text (Proxy field)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Proxy field
forall k (t :: k). Proxy t
Proxy @field)

          Ranges (field : fields) resource
-> Either Text (Ranges (field : fields) resource)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ranges (field : fields) resource
 -> Either Text (Ranges (field : fields) resource))
-> Ranges (field : fields) resource
-> Either Text (Ranges (field : fields) resource)
forall a b. (a -> b) -> a -> b
$ Range field (RangeType resource field)
-> Ranges (field : fields) resource
forall resource (field :: Symbol) (fields :: [Symbol]).
HasPagination resource field =>
Range field (RangeType resource field)
-> Ranges (field : fields) resource
Ranges Range field (RangeType resource field)
range

        [[Text]]
_ ->
          Ranges fields resource -> Ranges (field : fields) resource
forall (fields :: [Symbol]) resource (y :: Symbol).
Ranges fields resource -> Ranges (y : fields) resource
Lift (Ranges fields resource -> Ranges (field : fields) resource)
-> Either Text (Ranges fields resource)
-> Either Text (Ranges (field : fields) resource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either Text (Ranges fields resource)
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
txt :: Either Text (Ranges fields resource))
    where
      parseOpt :: [Text] -> Either Text (Text, Text)
      parseOpt :: [Text] -> Either Text (Text, Text)
parseOpt [Text]
piece =
        case [Text]
piece of
          [Text
opt, Text
arg] ->
            (Text, Text) -> Either Text (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
opt, Text
arg)

          [Text]
_ ->
            Text -> Either Text (Text, Text)
forall a b. a -> Either a b
Left Text
"Invalid Range Options"

      ifOpt :: FromHttpApiData o => Text -> o -> [(Text, Text)] -> Either Text o
      ifOpt :: Text -> o -> [(Text, Text)] -> Either Text o
ifOpt Text
opt o
def =
        Either Text o
-> ((Text, Text) -> Either Text o)
-> Maybe (Text, Text)
-> Either Text o
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (o -> Either Text o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
def) (Text -> Either Text o
forall a. FromHttpApiData a => Text -> Either Text a
parseQueryParam (Text -> Either Text o)
-> ((Text, Text) -> Text) -> (Text, Text) -> Either Text o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd) (Maybe (Text, Text) -> Either Text o)
-> ([(Text, Text)] -> Maybe (Text, Text))
-> [(Text, Text)]
-> Either Text o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Bool) -> [(Text, Text)] -> Maybe (Text, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
opt) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst)

      checkLimit :: Int -> Either Text Int
      checkLimit :: Int -> Either Text Int
checkLimit Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = Text -> Either Text Int
forall a b. a -> Either a b
Left Text
"Limit must be non-negative"
        | Bool
otherwise = Int -> Either Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

-- | Define the sorting order of the paginated resources (ascending or descending)
data RangeOrder
  = RangeAsc
  | RangeDesc
  deriving (RangeOrder -> RangeOrder -> Bool
(RangeOrder -> RangeOrder -> Bool)
-> (RangeOrder -> RangeOrder -> Bool) -> Eq RangeOrder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RangeOrder -> RangeOrder -> Bool
$c/= :: RangeOrder -> RangeOrder -> Bool
== :: RangeOrder -> RangeOrder -> Bool
$c== :: RangeOrder -> RangeOrder -> Bool
Eq, Int -> RangeOrder -> ShowS
[RangeOrder] -> ShowS
RangeOrder -> String
(Int -> RangeOrder -> ShowS)
-> (RangeOrder -> String)
-> ([RangeOrder] -> ShowS)
-> Show RangeOrder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RangeOrder] -> ShowS
$cshowList :: [RangeOrder] -> ShowS
show :: RangeOrder -> String
$cshow :: RangeOrder -> String
showsPrec :: Int -> RangeOrder -> ShowS
$cshowsPrec :: Int -> RangeOrder -> ShowS
Show, Eq RangeOrder
Eq RangeOrder
-> (RangeOrder -> RangeOrder -> Ordering)
-> (RangeOrder -> RangeOrder -> Bool)
-> (RangeOrder -> RangeOrder -> Bool)
-> (RangeOrder -> RangeOrder -> Bool)
-> (RangeOrder -> RangeOrder -> Bool)
-> (RangeOrder -> RangeOrder -> RangeOrder)
-> (RangeOrder -> RangeOrder -> RangeOrder)
-> Ord RangeOrder
RangeOrder -> RangeOrder -> Bool
RangeOrder -> RangeOrder -> Ordering
RangeOrder -> RangeOrder -> RangeOrder
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RangeOrder -> RangeOrder -> RangeOrder
$cmin :: RangeOrder -> RangeOrder -> RangeOrder
max :: RangeOrder -> RangeOrder -> RangeOrder
$cmax :: RangeOrder -> RangeOrder -> RangeOrder
>= :: RangeOrder -> RangeOrder -> Bool
$c>= :: RangeOrder -> RangeOrder -> Bool
> :: RangeOrder -> RangeOrder -> Bool
$c> :: RangeOrder -> RangeOrder -> Bool
<= :: RangeOrder -> RangeOrder -> Bool
$c<= :: RangeOrder -> RangeOrder -> Bool
< :: RangeOrder -> RangeOrder -> Bool
$c< :: RangeOrder -> RangeOrder -> Bool
compare :: RangeOrder -> RangeOrder -> Ordering
$ccompare :: RangeOrder -> RangeOrder -> Ordering
$cp1Ord :: Eq RangeOrder
Ord, (forall x. RangeOrder -> Rep RangeOrder x)
-> (forall x. Rep RangeOrder x -> RangeOrder) -> Generic RangeOrder
forall x. Rep RangeOrder x -> RangeOrder
forall x. RangeOrder -> Rep RangeOrder x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RangeOrder x -> RangeOrder
$cfrom :: forall x. RangeOrder -> Rep RangeOrder x
Generic)

instance ToHttpApiData RangeOrder where
  toUrlPiece :: RangeOrder -> Text
toUrlPiece RangeOrder
order =
    case RangeOrder
order of
      RangeOrder
RangeAsc  -> Text
"asc"
      RangeOrder
RangeDesc -> Text
"desc"

instance FromHttpApiData RangeOrder where
  parseUrlPiece :: Text -> Either Text RangeOrder
parseUrlPiece Text
txt =
    case Text
txt of
      Text
"asc"  -> RangeOrder -> Either Text RangeOrder
forall (f :: * -> *) a. Applicative f => a -> f a
pure RangeOrder
RangeAsc
      Text
"desc" -> RangeOrder -> Either Text RangeOrder
forall (f :: * -> *) a. Applicative f => a -> f a
pure RangeOrder
RangeDesc
      Text
_      -> Text -> Either Text RangeOrder
forall a b. a -> Either a b
Left Text
"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 '[field] -> Text
toUrlPiece AcceptRanges '[field]
AcceptRanges =
    String -> Text
Text.pack (Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy field
forall k (t :: k). Proxy t
Proxy @field))

instance (ToHttpApiData (AcceptRanges (f ': fs)), KnownSymbol field) => ToHttpApiData (AcceptRanges (field ': f ': fs)) where
  toUrlPiece :: AcceptRanges (field : f : fs) -> Text
toUrlPiece AcceptRanges (field : f : fs)
AcceptRanges =
    String -> Text
Text.pack (Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy field
forall k (t :: k). Proxy t
Proxy @field)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AcceptRanges (f : fs) -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece (AcceptRanges (f : fs)
forall (fields :: [Symbol]). AcceptRanges fields
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 fields res -> Text
toUrlPiece (ContentRange RangeType res field
start RangeType res field
end Proxy field
field) =
    String -> Text
Text.pack (Proxy field -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy field
field) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
encodeText (Text -> Text)
-> (RangeType res field -> Text) -> RangeType res field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeType res field -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece) RangeType res field
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
encodeText (Text -> Text)
-> (RangeType res field -> Text) -> RangeType res field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeType res field -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece) RangeType res field
end


--
-- USE RANGES
--

-- | 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 :: *

  -- | Get the corressponding value of a Resource
  getFieldValue :: Proxy field -> resource -> RangeType resource field

  -- | Get parsing options for the 'Range' defined on this 'field'
  getRangeOptions :: Proxy field -> Proxy resource -> RangeOptions
  getRangeOptions Proxy field
_ Proxy resource
_ = RangeOptions
defaultOptions

  -- | 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
    -> Range field (RangeType resource field)
  getDefaultRange Proxy resource
_ =
    let
      RangeOptions{Int
RangeOrder
defaultRangeOrder :: RangeOrder
defaultRangeOffset :: Int
defaultRangeLimit :: Int
defaultRangeOrder :: RangeOptions -> RangeOrder
defaultRangeOffset :: RangeOptions -> Int
defaultRangeLimit :: RangeOptions -> Int
..} = Proxy field -> Proxy resource -> RangeOptions
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> Proxy resource -> RangeOptions
getRangeOptions (Proxy field
forall k (t :: k). Proxy t
Proxy @field) (Proxy resource
forall k (t :: k). Proxy t
Proxy @resource)
    in Range :: forall (field :: Symbol) a.
(KnownSymbol field, IsRangeType a) =>
Maybe a -> Int -> Int -> RangeOrder -> Proxy field -> Range field a
Range
      { rangeValue :: Maybe (RangeType resource field)
rangeValue  = Maybe (RangeType resource field)
forall a. Maybe a
Nothing @(RangeType resource field)
      , rangeLimit :: Int
rangeLimit  = Int
defaultRangeLimit
      , rangeOffset :: Int
rangeOffset = Int
defaultRangeOffset
      , rangeOrder :: RangeOrder
rangeOrder  = RangeOrder
defaultRangeOrder
      , rangeField :: Proxy field
rangeField  = Proxy field
forall k (t :: k). Proxy t
Proxy @field
      }

-- | 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 return, 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 field (RangeType resource field)
-> [resource]
-> m (Headers (PageHeaders fields resource) [resource])
returnRange Range{Int
Maybe (RangeType resource field)
Proxy field
RangeOrder
rangeField :: Proxy field
rangeOrder :: RangeOrder
rangeOffset :: Int
rangeLimit :: Int
rangeValue :: Maybe (RangeType resource field)
rangeField :: forall (field :: Symbol) a. Range field a -> Proxy field
rangeOrder :: forall (field :: Symbol) a. Range field a -> RangeOrder
rangeOffset :: forall (field :: Symbol) a. Range field a -> Int
rangeLimit :: forall (field :: Symbol) a. Range field a -> Int
rangeValue :: forall (field :: Symbol) a. Range field a -> Maybe a
..} [resource]
rs = do
  let boundaries :: Maybe (RangeType resource field, RangeType resource field)
boundaries = (,)
        (RangeType resource field
 -> RangeType resource field
 -> (RangeType resource field, RangeType resource field))
-> Maybe (RangeType resource field)
-> Maybe
     (RangeType resource field
      -> (RangeType resource field, RangeType resource field))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (resource -> RangeType resource field)
-> Maybe resource -> Maybe (RangeType resource field)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField) ([resource] -> Maybe resource
forall a. [a] -> Maybe a
Safe.headMay [resource]
rs)
        Maybe
  (RangeType resource field
   -> (RangeType resource field, RangeType resource field))
-> Maybe (RangeType resource field)
-> Maybe (RangeType resource field, RangeType resource field)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (resource -> RangeType resource field)
-> Maybe resource -> Maybe (RangeType resource field)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField) ([resource] -> Maybe resource
forall a. [a] -> Maybe a
Safe.lastMay [resource]
rs)

  case Maybe (RangeType resource field, RangeType resource field)
boundaries of
    Maybe (RangeType resource field, RangeType resource field)
Nothing ->
      Headers (PageHeaders fields resource) [resource]
-> m (Headers (PageHeaders fields resource) [resource])
forall (m :: * -> *) a. Monad m => a -> m a
return (Headers (PageHeaders fields resource) [resource]
 -> m (Headers (PageHeaders fields resource) [resource]))
-> Headers (PageHeaders fields resource) [resource]
-> m (Headers (PageHeaders fields resource) [resource])
forall a b. (a -> b) -> a -> b
$ AcceptRanges fields
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
-> Headers (PageHeaders fields resource) [resource]
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader AcceptRanges fields
forall (fields :: [Symbol]). AcceptRanges fields
AcceptRanges (Headers
   '[Header'
       '[Optional, Strict] "Content-Range" (ContentRange fields resource),
     Header "Next-Range" (Ranges fields resource)]
   [resource]
 -> Headers (PageHeaders fields resource) [resource])
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
-> Headers (PageHeaders fields resource) [resource]
forall a b. (a -> b) -> a -> b
$ Headers '[Header "Next-Range" (Ranges fields resource)] [resource]
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
orig -> new
noHeader (Headers '[Header "Next-Range" (Ranges fields resource)] [resource]
 -> Headers
      '[Header'
          '[Optional, Strict] "Content-Range" (ContentRange fields resource),
        Header "Next-Range" (Ranges fields resource)]
      [resource])
-> Headers
     '[Header "Next-Range" (Ranges fields resource)] [resource]
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
forall a b. (a -> b) -> a -> b
$ [resource]
-> Headers
     '[Header "Next-Range" (Ranges fields resource)] [resource]
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
orig -> new
noHeader [resource]
rs

    Just (RangeType resource field
start, RangeType resource field
end) -> do
      let nextOffset :: Int
nextOffset | Maybe (RangeType resource field)
rangeValue Maybe (RangeType resource field)
-> Maybe (RangeType resource field) -> Bool
forall a. Eq a => a -> a -> Bool
== RangeType resource field -> Maybe (RangeType resource field)
forall a. a -> Maybe a
Just RangeType resource field
end = Int
rangeOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [resource] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [resource]
rs
                     | Bool
otherwise              = [resource] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([resource] -> Int) -> [resource] -> Int
forall a b. (a -> b) -> a -> b
$ (resource -> Bool) -> [resource] -> [resource]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (RangeType resource field -> RangeType resource field -> Bool
forall a. Eq a => a -> a -> Bool
(==) RangeType resource field
end (RangeType resource field -> Bool)
-> (resource -> RangeType resource field) -> resource -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField) ([resource] -> [resource]
forall a. [a] -> [a]
reverse [resource]
rs)

      let nextRange :: Ranges fields resource
nextRange = Range field (RangeType resource field) -> Ranges fields resource
forall (fields :: [Symbol]) (field :: Symbol) resource.
(PutRange fields field, HasPagination resource field) =>
Range field (RangeType resource field) -> Ranges fields resource
putRange Range :: forall (field :: Symbol) a.
(KnownSymbol field, IsRangeType a) =>
Maybe a -> Int -> Int -> RangeOrder -> Proxy field -> Range field a
Range
            { rangeValue :: Maybe (RangeType resource field)
rangeValue  = RangeType resource field -> Maybe (RangeType resource field)
forall a. a -> Maybe a
Just RangeType resource field
end
            , rangeLimit :: Int
rangeLimit  = Int
rangeLimit
            , rangeOffset :: Int
rangeOffset = Int
nextOffset
            , rangeOrder :: RangeOrder
rangeOrder  = RangeOrder
rangeOrder
            , rangeField :: Proxy field
rangeField  = Proxy field
rangeField
            }

      let contentRange :: ContentRange fields resource
contentRange = ContentRange :: forall (fields :: [Symbol]) resource (field :: Symbol).
(KnownSymbol field, ToHttpApiData (RangeType resource field)) =>
RangeType resource field
-> RangeType resource field
-> Proxy field
-> ContentRange fields resource
ContentRange
            { contentRangeStart :: RangeType resource field
contentRangeStart = RangeType resource field
start
            , contentRangeEnd :: RangeType resource field
contentRangeEnd   = RangeType resource field
end
            , contentRangeField :: Proxy field
contentRangeField = Proxy field
rangeField
            }

      Headers (PageHeaders fields resource) [resource]
-> m (Headers (PageHeaders fields resource) [resource])
forall (m :: * -> *) a. Monad m => a -> m a
return (Headers (PageHeaders fields resource) [resource]
 -> m (Headers (PageHeaders fields resource) [resource]))
-> Headers (PageHeaders fields resource) [resource]
-> m (Headers (PageHeaders fields resource) [resource])
forall a b. (a -> b) -> a -> b
$ AcceptRanges fields
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
-> Headers (PageHeaders fields resource) [resource]
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader AcceptRanges fields
forall (fields :: [Symbol]). AcceptRanges fields
AcceptRanges (Headers
   '[Header'
       '[Optional, Strict] "Content-Range" (ContentRange fields resource),
     Header "Next-Range" (Ranges fields resource)]
   [resource]
 -> Headers (PageHeaders fields resource) [resource])
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
-> Headers (PageHeaders fields resource) [resource]
forall a b. (a -> b) -> a -> b
$ ContentRange fields resource
-> Headers
     '[Header "Next-Range" (Ranges fields resource)] [resource]
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader ContentRange fields resource
contentRange (Headers '[Header "Next-Range" (Ranges fields resource)] [resource]
 -> Headers
      '[Header'
          '[Optional, Strict] "Content-Range" (ContentRange fields resource),
        Header "Next-Range" (Ranges fields resource)]
      [resource])
-> Headers
     '[Header "Next-Range" (Ranges fields resource)] [resource]
-> Headers
     '[Header'
         '[Optional, Strict] "Content-Range" (ContentRange fields resource),
       Header "Next-Range" (Ranges fields resource)]
     [resource]
forall a b. (a -> b) -> a -> b
$ Ranges fields resource
-> [resource]
-> Headers
     '[Header "Next-Range" (Ranges fields resource)] [resource]
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader Ranges fields resource
nextRange [resource]
rs

-- | Default values to apply when parsing a 'Range'
data RangeOptions  = RangeOptions
  { RangeOptions -> Int
defaultRangeLimit  :: Int         -- ^ Default limit if not provided, default to @100@
  , RangeOptions -> Int
defaultRangeOffset :: Int         -- ^ Default offset if not provided, default to @0@
  , RangeOptions -> RangeOrder
defaultRangeOrder  :: RangeOrder  -- ^ Default order if not provided, default to 'RangeDesc'
  } deriving (RangeOptions -> RangeOptions -> Bool
(RangeOptions -> RangeOptions -> Bool)
-> (RangeOptions -> RangeOptions -> Bool) -> Eq RangeOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RangeOptions -> RangeOptions -> Bool
$c/= :: RangeOptions -> RangeOptions -> Bool
== :: RangeOptions -> RangeOptions -> Bool
$c== :: RangeOptions -> RangeOptions -> Bool
Eq, Int -> RangeOptions -> ShowS
[RangeOptions] -> ShowS
RangeOptions -> String
(Int -> RangeOptions -> ShowS)
-> (RangeOptions -> String)
-> ([RangeOptions] -> ShowS)
-> Show RangeOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RangeOptions] -> ShowS
$cshowList :: [RangeOptions] -> ShowS
show :: RangeOptions -> String
$cshow :: RangeOptions -> String
showsPrec :: Int -> RangeOptions -> ShowS
$cshowsPrec :: Int -> RangeOptions -> ShowS
Show)


-- | Some default options of default values for a Range (limit 100; offset 0; order desc)
defaultOptions :: RangeOptions
defaultOptions :: RangeOptions
defaultOptions =
  Int -> Int -> RangeOrder -> RangeOptions
RangeOptions Int
100 Int
0 RangeOrder
RangeDesc


-- | 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 field (RangeType resource field) -> [resource] -> [resource]
applyRange Range{Int
Maybe (RangeType resource field)
Proxy field
RangeOrder
rangeField :: Proxy field
rangeOrder :: RangeOrder
rangeOffset :: Int
rangeLimit :: Int
rangeValue :: Maybe (RangeType resource field)
rangeField :: forall (field :: Symbol) a. Range field a -> Proxy field
rangeOrder :: forall (field :: Symbol) a. Range field a -> RangeOrder
rangeOffset :: forall (field :: Symbol) a. Range field a -> Int
rangeLimit :: forall (field :: Symbol) a. Range field a -> Int
rangeValue :: forall (field :: Symbol) a. Range field a -> Maybe a
..} =
  let
    sortRel :: resource -> resource -> Ordering
sortRel =
      case RangeOrder
rangeOrder of
        RangeOrder
RangeDesc ->
          \resource
a resource
b -> RangeType resource field -> RangeType resource field -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField resource
b) (Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField resource
a)

        RangeOrder
RangeAsc ->
          \resource
a resource
b -> RangeType resource field -> RangeType resource field -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField resource
a) (Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField resource
b)

    dropRel :: resource -> Bool
dropRel =
      case (Maybe (RangeType resource field)
rangeValue, RangeOrder
rangeOrder) of
        (Maybe (RangeType resource field)
Nothing, RangeOrder
_) ->
          Bool -> resource -> Bool
forall a b. a -> b -> a
const Bool
False

        (Just RangeType resource field
a, RangeOrder
RangeDesc) ->
          (RangeType resource field -> RangeType resource field -> Bool
forall a. Ord a => a -> a -> Bool
> RangeType resource field
a) (RangeType resource field -> Bool)
-> (resource -> RangeType resource field) -> resource -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField

        (Just RangeType resource field
a, RangeOrder
RangeAsc) ->
          (RangeType resource field -> RangeType resource field -> Bool
forall a. Ord a => a -> a -> Bool
< RangeType resource field
a) (RangeType resource field -> Bool)
-> (resource -> RangeType resource field) -> resource -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy field -> resource -> RangeType resource field
forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField
  in
      Int -> [resource] -> [resource]
forall a. Int -> [a] -> [a]
List.take Int
rangeLimit
    ([resource] -> [resource])
-> ([resource] -> [resource]) -> [resource] -> [resource]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [resource] -> [resource]
forall a. Int -> [a] -> [a]
List.drop Int
rangeOffset
    ([resource] -> [resource])
-> ([resource] -> [resource]) -> [resource] -> [resource]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (resource -> Bool) -> [resource] -> [resource]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhile resource -> Bool
dropRel
    ([resource] -> [resource])
-> ([resource] -> [resource]) -> [resource] -> [resource]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (resource -> resource -> Ordering) -> [resource] -> [resource]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy resource -> resource -> Ordering
sortRel