module Servant.Pagination
(
Ranges
, Range(..)
, RangeOrder(..)
, AcceptRanges (..)
, ContentRange (..)
, PageHeaders
, IsRangeType
, HasPagination(..)
, RangeOptions(..)
, defaultOptions
, 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 Servant
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Safe
type IsRangeType a =
( Show a
, Ord a
, Eq a
, FromHttpApiData a
, ToHttpApiData a
)
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 _ _ = flip mappend "Ranges"
instance (Show (Ranges fields res)) => Show (Ranges (field ': fields) res) where
showsPrec prec (Lift r) s = showsPrec prec r s
showsPrec prec (Ranges r) s =
let
inner = "Ranges@" ++ showsPrec 11 r s
in
if prec > 10 then "(" ++ inner ++ ")" else inner
data Range (field :: Symbol) (a :: *) =
(KnownSymbol field, IsRangeType a) => Range
{ rangeValue :: Maybe a
, rangeLimit :: Int
, rangeOffset :: Int
, rangeOrder :: RangeOrder
, rangeField :: Proxy field
}
instance Eq (Range field a) where
(Range val0 lim0 off0 ord0 _) == (Range val1 lim1 off1 ord1 _) =
val0 == val1
&& lim0 == lim1
&& off0 == off1
&& ord0 == ord1
instance Show (Range field a) where
showsPrec prec Range{..} =
let
inner = "Range {" ++ args ++ "}"
args = intercalate ", "
[ "rangeValue = " ++ show rangeValue
, "rangeLimit = " ++ show rangeLimit
, "rangeOffset = " ++ show rangeOffset
, "rangeOrder = " ++ show rangeOrder
, "rangeField = " ++ "\"" ++ symbolVal rangeField ++ "\""
]
in
flip mappend $ if prec > 10 then
"(" ++ inner ++ ")"
else
inner
class ExtractRange (fields :: [Symbol]) (field :: Symbol) where
extractRange
:: HasPagination resource field
=> Ranges fields resource
-> Maybe (Range field (RangeType resource field))
instance ExtractRange (field ': fields) field where
extractRange (Ranges r) = Just r
extractRange (Lift _) = Nothing
{-# INLINE extractRange #-}
instance {-# OVERLAPPABLE #-} ExtractRange fields field => ExtractRange (y ': fields) field where
extractRange (Ranges _) = Nothing
extractRange (Lift r) = extractRange r
{-# INLINE extractRange #-}
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 = Ranges
{-# INLINE putRange #-}
instance {-# OVERLAPPABLE #-} (PutRange fields field) => PutRange (y ': fields) field where
putRange = Lift . putRange
{-# INLINE putRange #-}
instance ToHttpApiData (Ranges fields resource) where
toUrlPiece (Lift range) =
toUrlPiece range
toUrlPiece (Ranges Range{..}) =
Text.pack (symbolVal rangeField)
<> maybe "" (\v -> " " <> toUrlPiece v) rangeValue
<> ";limit " <> toUrlPiece rangeLimit
<> ";offset " <> toUrlPiece rangeOffset
<> ";order " <> toUrlPiece rangeOrder
instance FromHttpApiData (Ranges '[] resource) where
parseUrlPiece _ =
Left "Invalid Range"
instance
( FromHttpApiData (Ranges fields resource)
, HasPagination resource field
, KnownSymbol field
, IsRangeType (RangeType resource field)
) => FromHttpApiData (Ranges (field ': fields) resource) where
parseUrlPiece txt =
let
RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource)
toTuples =
filter (/= "") . Text.splitOn (Text.singleton ' ')
args =
map toTuples $ Text.splitOn (Text.singleton ';') txt
field =
Text.pack $ symbolVal (Proxy @field)
in
case args of
(field' : value) : rest | field == field' -> do
opts <-
traverse parseOpt rest
range <- Range
<$> sequence (fmap parseQueryParam (listToMaybe value))
<*> ifOpt "limit" defaultRangeLimit opts
<*> ifOpt "offset" defaultRangeOffset opts
<*> ifOpt "order" defaultRangeOrder opts
<*> pure (Proxy @field)
pure $ Ranges range
_ ->
Lift <$> (parseUrlPiece txt :: Either Text (Ranges fields resource))
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)
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"
type PageHeaders (fields :: [Symbol]) (resource :: *) =
'[ Header "Accept-Ranges" (AcceptRanges fields)
, Header "Content-Range" (ContentRange fields resource)
, Header "Next-Range" (Ranges fields resource)
]
data AcceptRanges (fields :: [Symbol]) = AcceptRanges
instance (KnownSymbol field) => ToHttpApiData (AcceptRanges '[field]) where
toUrlPiece AcceptRanges =
Text.pack (symbolVal (Proxy @field))
instance (ToHttpApiData (AcceptRanges (f ': fs)), KnownSymbol field) => ToHttpApiData (AcceptRanges (field ': f ': fs)) where
toUrlPiece AcceptRanges =
Text.pack (symbolVal (Proxy @field)) <> "," <> toUrlPiece (AcceptRanges @(f ': fs))
data ContentRange (fields :: [Symbol]) resource =
forall field. (KnownSymbol field, ToHttpApiData (RangeType resource field)) => ContentRange
{ contentRangeStart :: RangeType resource field
, contentRangeEnd :: RangeType resource field
, contentRangeField :: Proxy field
}
instance ToHttpApiData (ContentRange fields res) where
toUrlPiece (ContentRange start end field) =
Text.pack (symbolVal field) <> " " <> toUrlPiece start <> ".." <> toUrlPiece end
class KnownSymbol field => HasPagination resource field where
type RangeType resource field :: *
getFieldValue :: Proxy field -> resource -> RangeType resource field
getRangeOptions :: Proxy field -> Proxy resource -> RangeOptions
getRangeOptions _ _ = defaultOptions
getDefaultRange
:: IsRangeType (RangeType resource field)
=> Proxy resource
-> Range field (RangeType resource field)
getDefaultRange _ =
let
RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource)
in Range
{ rangeValue = Nothing @(RangeType resource field)
, rangeLimit = defaultRangeLimit
, rangeOffset = defaultRangeOffset
, rangeOrder = defaultRangeOrder
, rangeField = Proxy @field
}
returnRange
:: ( 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{..} rs = do
let boundaries = (,)
<$> fmap (getFieldValue rangeField) (Safe.headMay rs)
<*> fmap (getFieldValue rangeField) (Safe.lastMay rs)
case boundaries of
Nothing ->
return $ addHeader AcceptRanges $ noHeader $ noHeader rs
Just (start, end) -> do
let nextOffset | rangeValue == Just end = rangeOffset + length rs
| otherwise = length $ takeWhile ((==) end . getFieldValue rangeField) (reverse rs)
let nextRange = putRange Range
{ rangeValue = Just end
, rangeLimit = rangeLimit
, rangeOffset = nextOffset
, rangeOrder = rangeOrder
, rangeField = rangeField
}
let contentRange = ContentRange
{ contentRangeStart = start
, contentRangeEnd = end
, contentRangeField = rangeField
}
return $ addHeader AcceptRanges $ addHeader contentRange $ addHeader nextRange rs
data RangeOptions = RangeOptions
{ defaultRangeLimit :: Int
, defaultRangeOffset :: Int
, defaultRangeOrder :: RangeOrder
} deriving (Eq, Show)
defaultOptions :: RangeOptions
defaultOptions =
RangeOptions 100 0 RangeDesc
applyRange
:: HasPagination resource field
=> Range field (RangeType resource field)
-> [resource]
-> [resource]
applyRange Range{..} =
let
sortRel =
case rangeOrder of
RangeDesc ->
\a b -> compare (getFieldValue rangeField b) (getFieldValue rangeField a)
RangeAsc ->
\a b -> compare (getFieldValue rangeField a) (getFieldValue rangeField b)
dropRel =
case (rangeValue, rangeOrder) of
(Nothing, _) ->
const False
(Just a, RangeDesc) ->
(> a) . getFieldValue rangeField
(Just a, RangeAsc) ->
(< a) . getFieldValue rangeField
in
List.take rangeLimit
. List.drop rangeOffset
. List.dropWhile dropRel
. List.sortBy sortRel