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 Network.URI.Encode (encodeText,decodeText)
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 -> " " <> (encodeText . 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 (parseUrlPiece . decodeText) (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) <> " " <> (encodeText . toUrlPiece) start <> ".." <> (encodeText . 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