{-# 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
  , PutRange
  , ExtractRange

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

  -- * Use Ranges
  , extractRange
  , putRange
  , addPageHeaders
  , 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
_ = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 = 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@" forall a. [a] -> [a] -> [a]
++ forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Range field (RangeType res field)
r String
s
    in
      if Int
prec forall a. Ord a => a -> a -> Bool
> Int
10 then String
"(" forall a. [a] -> [a] -> [a]
++ String
inner 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
  { forall (field :: Symbol) a. Range field a -> Maybe a
rangeValue  :: Maybe a     -- ^ The value of that field, beginning of the range
  , forall (field :: Symbol) a. Range field a -> Int
rangeLimit  :: Int         -- ^ Maximum number of resources to return
  , forall (field :: Symbol) a. Range field a -> Int
rangeOffset :: Int         -- ^ Offset, number of resources to skip after the starting value
  , forall (field :: Symbol) a. Range field a -> RangeOrder
rangeOrder  :: RangeOrder  -- ^ The order of sorting (ascending or descending)
  , forall (field :: Symbol) a. 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 forall a. Eq a => a -> a -> Bool
== Maybe a
val1
    Bool -> Bool -> Bool
&& Int
lim0 forall a. Eq a => a -> a -> Bool
== Int
lim1
    Bool -> Bool -> Bool
&& Int
off0 forall a. Eq a => a -> a -> Bool
== Int
off1
    Bool -> Bool -> Bool
&& RangeOrder
ord0 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 {" forall a. [a] -> [a] -> [a]
++ String
args forall a. [a] -> [a] -> [a]
++ String
"}"
      args :: String
args  = forall a. [a] -> [[a]] -> [a]
intercalate String
", "
        [ String
"rangeValue = "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe a
rangeValue
        , String
"rangeLimit = "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
rangeLimit
        , String
"rangeOffset = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
rangeOffset
        , String
"rangeOrder = "  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RangeOrder
rangeOrder
        , String
"rangeField = "  forall a. [a] -> [a] -> [a]
++ String
"\"" forall a. [a] -> [a] -> [a]
++ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy field
rangeField forall a. [a] -> [a] -> [a]
++ String
"\""
        ]
    in
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Monoid a => a -> a -> a
mappend forall a b. (a -> b) -> a -> b
$ if Int
prec forall a. Ord a => a -> a -> Bool
> Int
10 then
        String
"(" forall a. [a] -> [a] -> [a]
++ String
inner 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 :: forall resource.
HasPagination resource field =>
Ranges (field : fields) resource
-> Maybe (Range field (RangeType resource field))
extractRange (Ranges Range field (RangeType resource field)
r) = forall a. a -> Maybe a
Just Range field (RangeType resource field)
r
  extractRange (Lift Ranges fields resource
_)   = forall a. Maybe a
Nothing
  {-# INLINE extractRange #-}

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

instance {-# OVERLAPPABLE #-} (PutRange fields field) => PutRange (y ': fields) field where
  putRange :: forall resource.
HasPagination resource field =>
Range field (RangeType resource field)
-> Ranges (y : fields) resource
putRange = forall (fields :: [Symbol]) resource (y :: Symbol).
Ranges fields resource -> Ranges (y : fields) resource
Lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
    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 (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy field
rangeField)
    forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\RangeType resource field
v -> Text
" " forall a. Semigroup a => a -> a -> a
<> (Text -> Text
encodeText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToHttpApiData a => a -> Text
toUrlPiece) RangeType resource field
v) Maybe (RangeType resource field)
rangeValue
    forall a. Semigroup a => a -> a -> a
<> Text
";limit "  forall a. Semigroup a => a -> a -> a
<> forall a. ToHttpApiData a => a -> Text
toUrlPiece Int
rangeLimit
    forall a. Semigroup a => a -> a -> a
<> Text
";offset " forall a. Semigroup a => a -> a -> a
<> forall a. ToHttpApiData a => a -> Text
toUrlPiece Int
rangeOffset
    forall a. Semigroup a => a -> a -> a
<> Text
";order "  forall a. Semigroup a => a -> a -> a
<> forall a. ToHttpApiData a => a -> Text
toUrlPiece RangeOrder
rangeOrder


instance FromHttpApiData (Ranges '[] resource) where
  parseUrlPiece :: Text -> Either Text (Ranges '[] resource)
parseUrlPiece Text
_ =
    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
..} = forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> Proxy resource -> RangeOptions
getRangeOptions (forall {k} (t :: k). Proxy t
Proxy @field) (forall {k} (t :: k). Proxy t
Proxy @resource)

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

      args :: [[Text]]
args =
        forall a b. (a -> b) -> [a] -> [b]
map Text -> [Text]
toTuples 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 forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @field)
    in
      case [[Text]]
args of
        (Text
field' : [Text]
value) : [[Text]]
rest | Text
field forall a. Eq a => a -> a -> Bool
== Text
field' -> do
          [(Text, Text)]
opts <-
            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 <- forall (field :: Symbol) a.
(KnownSymbol field, IsRangeType a) =>
Maybe a -> Int -> Int -> RangeOrder -> Proxy field -> Range field a
Range
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
decodeText) (forall a. [a] -> Maybe a
listToMaybe [Text]
value)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall o.
FromHttpApiData o =>
Text -> o -> [(Text, Text)] -> Either Text o
ifOpt Text
"limit"  Int
defaultRangeLimit [(Text, Text)]
opts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Either Text Int
checkLimit)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall o.
FromHttpApiData o =>
Text -> o -> [(Text, Text)] -> Either Text o
ifOpt Text
"offset" Int
defaultRangeOffset [(Text, Text)]
opts
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall o.
FromHttpApiData o =>
Text -> o -> [(Text, Text)] -> Either Text o
ifOpt Text
"order"  RangeOrder
defaultRangeOrder [(Text, Text)]
opts
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} (t :: k). Proxy t
Proxy @field)

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

        [[Text]]
_ ->
          forall (fields :: [Symbol]) resource (y :: Symbol).
Ranges fields resource -> Ranges (y : fields) resource
Lift forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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] ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
opt, Text
arg)

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

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

      checkLimit :: Int -> Either Text Int
      checkLimit :: Int -> Either Text Int
checkLimit Int
n
        | Int
n forall a. Ord a => a -> a -> Bool
< Int
0     = forall a b. a -> Either a b
Left Text
"Limit must be non-negative"
        | Bool
otherwise = 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
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
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
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
Ord, 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"  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RangeOrder
RangeAsc
      Text
"desc" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RangeOrder
RangeDesc
      Text
_      -> 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 (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (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 (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @field)) forall a. Semigroup a => a -> a -> a
<> Text
"," forall a. Semigroup a => a -> a -> a
<> forall a. ToHttpApiData a => a -> Text
toUrlPiece (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 (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy field
field) forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> (Text -> Text
encodeText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToHttpApiData a => a -> Text
toUrlPiece) RangeType res field
start forall a. Semigroup a => a -> a -> a
<> Text
".." forall a. Semigroup a => a -> a -> a
<> (Text -> Text
encodeText forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
..} = forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> Proxy resource -> RangeOptions
getRangeOptions (forall {k} (t :: k). Proxy t
Proxy @field) (forall {k} (t :: k). Proxy t
Proxy @resource)
    in Range
      { rangeValue :: Maybe (RangeType resource field)
rangeValue  = 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  = forall {k} (t :: k). Proxy t
Proxy @field
      }

-- | Add headers representing a 'Range' to a list of resources.
--
-- 'Ranges' headers can be quite cumbersome to declare and can be deduced from a
-- collection of resources together with the 'Range' used to retrieve it, so this function
-- is a shortcut for that.
--
-- @
-- 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')
--
--  'return' ('addPageHeaders' range ('applyRange' range resources))
-- @
addPageHeaders
  :: ( 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
  -> Headers (PageHeaders fields resource) [resource]     -- ^ The same resources, but with pagination headers
addPageHeaders :: forall (fields :: [Symbol]) (field :: Symbol) resource.
(ToHttpApiData (AcceptRanges fields), KnownSymbol field,
 HasPagination resource field,
 IsRangeType (RangeType resource field), PutRange fields field) =>
Range field (RangeType resource field)
-> [resource] -> Headers (PageHeaders fields resource) [resource]
addPageHeaders 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 =
  let boundaries :: Maybe (RangeType resource field, RangeType resource field)
boundaries = (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField) (forall a. [a] -> Maybe a
Safe.headMay [resource]
rs)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField) (forall a. [a] -> Maybe a
Safe.lastMay [resource]
rs)
  in case Maybe (RangeType resource field, RangeType resource field)
boundaries of
    Maybe (RangeType resource field, RangeType resource field)
Nothing ->
      forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader forall (fields :: [Symbol]). AcceptRanges fields
AcceptRanges forall a b. (a -> b) -> a -> b
$ forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
orig -> new
noHeader forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just RangeType resource field
end = Int
rangeOffset forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [resource]
rs
                     | Bool
otherwise              = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
(==) RangeType resource field
end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField) (forall a. [a] -> [a]
reverse [resource]
rs)

      let nextRange :: Ranges fields resource
nextRange = forall (fields :: [Symbol]) (field :: Symbol) resource.
(PutRange fields field, HasPagination resource field) =>
Range field (RangeType resource field) -> Ranges fields resource
putRange Range
            { rangeValue :: Maybe (RangeType resource field)
rangeValue  = 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
            { 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
            }

      let addNextRange :: [resource]
-> Headers
     '[Header "Next-Range" (Ranges fields resource)] [resource]
addNextRange | forall (t :: * -> *) a. Foldable t => t a -> Int
length [resource]
rs forall a. Ord a => a -> a -> Bool
< Int
rangeLimit = forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
orig -> new
noHeader
                       | Bool
otherwise              = forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader Ranges fields resource
nextRange

      forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader forall (fields :: [Symbol]). AcceptRanges fields
AcceptRanges forall a b. (a -> b) -> a -> b
$ forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader ContentRange fields resource
contentRange forall a b. (a -> b) -> a -> b
$ [resource]
-> Headers
     '[Header "Next-Range" (Ranges fields resource)] [resource]
addNextRange [resource]
rs

-- | @'returnRange' range rs = 'return' ('addPageHeaders' range rs)@
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 :: forall (m :: * -> *) (fields :: [Symbol]) (field :: Symbol)
       resource.
(Monad m, ToHttpApiData (AcceptRanges fields), KnownSymbol field,
 HasPagination resource field,
 IsRangeType (RangeType resource field), PutRange fields field) =>
Range field (RangeType resource field)
-> [resource]
-> m (Headers (PageHeaders fields resource) [resource])
returnRange Range field (RangeType resource field)
range [resource]
rs = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (fields :: [Symbol]) (field :: Symbol) resource.
(ToHttpApiData (AcceptRanges fields), KnownSymbol field,
 HasPagination resource field,
 IsRangeType (RangeType resource field), PutRange fields field) =>
Range field (RangeType resource field)
-> [resource] -> Headers (PageHeaders fields resource) [resource]
addPageHeaders Range field (RangeType resource field)
range [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
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
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 :: forall resource (field :: Symbol).
HasPagination resource field =>
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 -> forall a. Ord a => a -> a -> Ordering
compare (forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField resource
b) (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 -> forall a. Ord a => a -> a -> Ordering
compare (forall resource (field :: Symbol).
HasPagination resource field =>
Proxy field -> resource -> RangeType resource field
getFieldValue Proxy field
rangeField resource
a) (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
_) ->
          forall a b. a -> b -> a
const Bool
False

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

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