diff --git a/servant-pagination.cabal b/servant-pagination.cabal index fa07a55..0968991 100644 --- a/servant-pagination.cabal +++ b/servant-pagination.cabal @@ -88,6 +88,7 @@ library , servant-server >= 0.11 && < 0.20 , safe >= 0.3 && < 1 , uri-encode >= 1.5 && < 1.6 + , openapi3 >=3.2.3 && <3.3 hs-source-dirs: src diff --git a/src/Servant/Pagination.hs b/src/Servant/Pagination.hs index e24a258..58a0885 100644 --- a/src/Servant/Pagination.hs +++ b/src/Servant/Pagination.hs @@ -118,10 +118,10 @@ module Servant.Pagination , applyRange ) where -import Data.List (filter, find, intercalate) +import Data.List (find, intercalate) import Data.Maybe (listToMaybe) -import Data.Proxy (Proxy (..)) -import Data.Semigroup ((<>)) +import Data.OpenApi (ToParamSchema (..)) +import Data.String (fromString) import Data.Text (Text) import GHC.Generics (Generic) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) @@ -129,6 +129,7 @@ import Network.URI.Encode (decodeText, encodeText) import Servant import qualified Data.List as List +import qualified Data.OpenApi as O import qualified Data.Text as Text import qualified Safe @@ -137,6 +138,10 @@ import qualified Safe -- TYPES -- +-- | Helper type to define 'Header' with 'Description'. +type HeaderWithDescription name a description = + Header' '[Description description, Optional, Strict] name a + -- | Set of constraints that must apply to every type target of a 'Range' type IsRangeType a = ( Show a @@ -249,7 +254,6 @@ instance {-# OVERLAPPABLE #-} (PutRange fields field) => PutRange (y ': fields) putRange = Lift . putRange {-# INLINE putRange #-} - instance ToHttpApiData (Ranges fields resource) where toUrlPiece (Lift range) = toUrlPiece range @@ -320,6 +324,16 @@ instance | n < 0 = Left "Limit must be non-negative" | otherwise = return n +instance ToParamSchema (Ranges fields resource) where + toParamSchema _ = + mempty + { O._schemaType = Just O.OpenApiString + , O._schemaFormat = + Just " [][; offset ][; limit ][; order ]" + , O._schemaExample = + Just $ fromString "createdAt 2017-02-19T12%3A56%3A28.000Z; offset 0; limit 100; order desc" + } + -- | Define the sorting order of the paginated resources (ascending or descending) data RangeOrder = RangeAsc @@ -351,13 +365,20 @@ instance FromHttpApiData RangeOrder where -- :> '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) + '[ HeaderWithDescription "Accept-Ranges" (AcceptRanges fields) + "A comma-separated list of fields upon which a pagination range can be defined" + , HeaderWithDescription "Content-Range" (ContentRange fields resource) + "Actual pagination range corresponding to the content being returned." + , HeaderWithDescription "Next-Range" (Ranges fields resource) + "Indicate what should be the next Range header in order to retrieve the next range" ] -- | Accepted Ranges in the `Accept-Ranges` response's header data AcceptRanges (fields :: [Symbol]) = AcceptRanges + deriving (Show, Eq) + +instance ToHttpApiData (AcceptRanges '[]) where + toUrlPiece AcceptRanges = mempty instance (KnownSymbol field) => ToHttpApiData (AcceptRanges '[field]) where toUrlPiece AcceptRanges = @@ -367,6 +388,23 @@ instance (ToHttpApiData (AcceptRanges (f ': fs)), KnownSymbol field) => ToHttpAp toUrlPiece AcceptRanges = Text.pack (symbolVal (Proxy @field)) <> "," <> toUrlPiece (AcceptRanges @(f ': fs)) +instance FromHttpApiData (AcceptRanges '[]) where + parseUrlPiece _ = Left "Invalid Accept Ranges" + +instance KnownSymbol field => FromHttpApiData (AcceptRanges (field ': fields)) where + parseUrlPiece txt = + let field = Text.pack $ symbolVal (Proxy @field) + in + case Text.splitOn "," txt of + field' : _ | field == field' -> pure $ AcceptRanges @(field ': fields) + _ -> Left "Invalid Accept Ranges" + +instance ToParamSchema (AcceptRanges fields) where + toParamSchema _ = + mempty + { O._schemaType = Just O.OpenApiString + , O._schemaExample = Just $ fromString "createdAt, modifiedAt" + } -- | Actual range returned, in the `Content-Range` response's header data ContentRange (fields :: [Symbol]) resource = @@ -376,10 +414,54 @@ data ContentRange (fields :: [Symbol]) resource = , contentRangeField :: Proxy field } +instance Eq (ContentRange (field ': fields) a) where + (ContentRange start0 end0 _) == (ContentRange start1 end1 _) = + toUrlPiece start0 == toUrlPiece start1 + && toUrlPiece end0 == toUrlPiece end1 + +instance Show (ContentRange (field ': fields) a) where + showsPrec prec ContentRange{..} = + let + inner = "ContentRange {" ++ args ++ "}" + args = intercalate ", " + [ "contentRangeStart = " ++ Text.unpack (encodeText $ toUrlPiece contentRangeStart) + , "contentRangeEnd = " ++ Text.unpack (encodeText $ toUrlPiece contentRangeEnd) + , "contentRangeField = " ++ "\"" ++ symbolVal contentRangeField ++ "\"" + ] + in + flip mappend $ if prec > 10 then + "(" ++ inner ++ ")" + else + inner + instance ToHttpApiData (ContentRange fields res) where toUrlPiece (ContentRange start end field) = Text.pack (symbolVal field) <> " " <> (encodeText . toUrlPiece) start <> ".." <> (encodeText . toUrlPiece) end +instance FromHttpApiData (ContentRange '[] resource) where + parseUrlPiece _ = Left "Invalid Content Range" + +instance + ( KnownSymbol field + , ToHttpApiData (RangeType resource field) + , FromHttpApiData (RangeType resource field) + ) => FromHttpApiData (ContentRange (field ': fields) resource) where + parseUrlPiece txt = + case Text.splitOn ".." . snd $ Text.breakOnEnd " " txt of + [start, end] -> + ContentRange + <$> parseUrlPiece start + <*> parseUrlPiece end + <*> pure (Proxy @field) + _otherwise -> Left "Invalid Content Range" + +instance ToParamSchema (ContentRange fields resource) where + toParamSchema _ = + mempty + { O._schemaType = Just O.OpenApiString + , O._schemaExample = + Just $ fromString "createdAt 2017-01-15T23%3A14%3A51.000Z..2017-02-18T06%3A10%3A23.000Z" + } -- -- USE RANGES diff --git a/test/Servant/PaginationSpec.hs b/test/Servant/PaginationSpec.hs index 24aaca9..7e42992 100644 --- a/test/Servant/PaginationSpec.hs +++ b/test/Servant/PaginationSpec.hs @@ -28,6 +28,14 @@ spec = do it "parseUrlPiece . toUrlPiece = pure" $ withMaxSuccess 10000 $ property $ \x -> (fmap extractB . parseUrlPiece . toUrlPiece) x == (pure . extractB) x + it "parseUrlPiece . toUrlPiece = pure" $ withMaxSuccess 10000 $ property $ + -- FIXME: static input + \(x :: AcceptRanges '["fieldA", "fieldB"]) -> (parseUrlPiece . toUrlPiece) x == pure x + + -- FIXME: static input + it "parseUrlPiece . toUrlPiece = pure" $ withMaxSuccess 10000 $ property $ + \(x :: ContentRange '["fieldA 1..5", "fieldB a..z"] Resource) -> (parseUrlPiece . toUrlPiece) x == pure x + describe "try-out ranges" $ do let r0 = getDefaultRange (Proxy @Resource) :: Range "fieldA" Int @@ -60,6 +68,24 @@ spec = do it "Range: fieldB" $ isLeft (parseUrlPiece "fieldB" :: Either Text (Ranges '["fieldA"] Resource)) + + it "AcceptRange: fieldA xxx" $ + isLeft (parseUrlPiece "fieldA xxx" :: Either Text (AcceptRanges '["fieldA", "fieldB"])) + + it "AcceptRange: fieldC" $ + isLeft (parseUrlPiece "fieldC" :: Either Text (AcceptRanges '["fieldA", "fieldB"])) + + it "AcceptRange: fieldB" $ + isLeft (parseUrlPiece "fieldB" :: Either Text (AcceptRanges '["fieldA"])) + + it "ContentRange: fieldA" $ + isLeft (parseUrlPiece "fieldA" :: Either Text (ContentRange '["fieldA 1..5", "fieldB a..z"] Resource)) + + it "ContentRange: fieldC 1..5" $ + isLeft (parseUrlPiece "fieldC" :: Either Text (ContentRange '["fieldA 1..5", "fieldB a..z"] Resource)) + + it "ContentRange: fieldB a..z" $ + isLeft (parseUrlPiece "fieldB" :: Either Text (ContentRange '["fieldA 1..5"] Resource)) where extractA :: Ranges '["fieldA", "fieldB"] Resource -> Maybe (Range "fieldA" Int) extractA = extractRange @@ -67,7 +93,6 @@ spec = do extractB :: Ranges '["fieldA", "fieldB"] Resource -> Maybe (Range "fieldB" SimpleString) extractB = extractRange - data Resource = Resource { fieldA :: Int , fieldB :: SimpleString @@ -118,3 +143,9 @@ instance (IsRangeType a, Arbitrary a) => Arbitrary (Range "fieldB" a) where <*> fmap getPositive arbitrary <*> oneof [pure RangeAsc, pure RangeDesc] <*> pure Proxy + +instance Arbitrary (AcceptRanges fields) where + arbitrary = pure $ AcceptRanges @fields -- FIXME: bad generator + +instance Arbitrary (ContentRange '["fieldA 1..5", "fieldB a..z"] Resource) where + arbitrary = undefined -- FIXME: bad generator