diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -2,20 +2,25 @@ columns: 100 language_extensions: - BangPatterns - - DefaultSignatures + - ConstraintKinds - DataKinds + - DefaultSignatures - DeriveDataTypeable - DeriveFunctor - DeriveGeneric - ExistentialQuantification - FlexibleContexts + - FlexibleInstances - GADTs - - GeneralizedNewtypeDeriving + - KindSignatures - MultiParamTypeClasses - OverloadedStrings + - ParallelListComp - RecordWildCards - ScopedTypeVariables - TupleSections + - TypeApplications + - TypeFamilies - TypeOperators steps: - simple_align: diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog +## v2.1.0 (2018-04-16) + +- Add some tests (QuickCheck round-up & control some Ranges parsing) +- Add `Show` and `Eq` instances for Ranges +- Expose `putRange` function +- Review `getDefaultRange` signature (remove Maybe argument) + + ## v2.0.0 (2018-04-06) - Review internal implementation and public API (ditch Range combinator to favor type-level diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -71,7 +71,7 @@ ```hs defaultRange :: Range "name" String defaultRange = - getDefaultRange (Proxy @Color) Nothing + getDefaultRange (Proxy @Color) server :: Maybe (Ranges '["name"] Color) -> Handler (Headers (PageHeaders '["name"] Color) [Color]) server mrange = do diff --git a/examples/Complex.hs b/examples/Complex.hs --- a/examples/Complex.hs +++ b/examples/Complex.hs @@ -54,7 +54,7 @@ defaultRange :: Range "name" String defaultRange = - getDefaultRange (Proxy @Color) Nothing + getDefaultRange (Proxy @Color) server :: Server API server mrange = diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -32,7 +32,7 @@ defaultRange :: Range "name" String defaultRange = - getDefaultRange (Proxy @Color) Nothing + getDefaultRange (Proxy @Color) server :: Server API server mrange = do diff --git a/servant-pagination.cabal b/servant-pagination.cabal --- a/servant-pagination.cabal +++ b/servant-pagination.cabal @@ -5,7 +5,7 @@ to communicate about a possible pagination feature of an endpoint, enabling a client to consume the API in different fashions (pagination with offset / limit, endless scroll using last referenced resources, ascending and descending ordering, etc.) -version: 2.0.0 +version: 2.1.0 homepage: https://github.com/chordify/haskell-servant-pagination bug-reports: https://github.com/chordify/haskell-servant-pagination/issues license: LGPL-3 @@ -16,7 +16,6 @@ category: Web build-type: Simple cabal-version: >=1.20 - extra-source-files: README.md CHANGELOG.md stack.yaml @@ -37,8 +36,9 @@ default-language: Haskell2010 ghc-options: -Wall -j4 default-extensions: BangPatterns - , DefaultSignatures + , ConstraintKinds , DataKinds + , DefaultSignatures , DeriveDataTypeable , DeriveFunctor , DeriveGeneric @@ -51,8 +51,10 @@ , OverloadedStrings , ParallelListComp , RecordWildCards - , TupleSections , ScopedTypeVariables + , TupleSections + , TypeApplications + , TypeFamilies , TypeOperators build-depends: base >= 4 && < 5 @@ -63,6 +65,7 @@ exposed-modules: Servant.Pagination + executable servant-pagination-simple if !flag(examples) buildable: False @@ -72,8 +75,9 @@ ghc-options: -Wall -j4 -threaded -rtsopts -with-rtsopts=-N default-extensions: BangPatterns - , DefaultSignatures + , ConstraintKinds , DataKinds + , DefaultSignatures , DeriveDataTypeable , DeriveFunctor , DeriveGeneric @@ -86,8 +90,10 @@ , OverloadedStrings , ParallelListComp , RecordWildCards - , TupleSections , ScopedTypeVariables + , TupleSections + , TypeApplications + , TypeFamilies , TypeOperators build-depends: base >= 4 && < 5 @@ -99,6 +105,7 @@ other-modules: Color + executable servant-pagination-complex if !flag(examples) buildable: False @@ -108,8 +115,9 @@ ghc-options: -Wall -j4 -threaded -rtsopts -with-rtsopts=-N default-extensions: BangPatterns - , DefaultSignatures + , ConstraintKinds , DataKinds + , DefaultSignatures , DeriveDataTypeable , DeriveFunctor , DeriveGeneric @@ -122,8 +130,10 @@ , OverloadedStrings , ParallelListComp , RecordWildCards - , TupleSections , ScopedTypeVariables + , TupleSections + , TypeApplications + , TypeFamilies , TypeOperators build-depends: base >= 4 && < 5 @@ -134,3 +144,43 @@ , warp >= 3.2 && < 4 other-modules: Color + + +test-suite servant-pagination-test + hs-source-dirs: test + main-is: Spec.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -j4 + + default-extensions: BangPatterns + , ConstraintKinds + , DataKinds + , DefaultSignatures + , DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , ExistentialQuantification + , FlexibleContexts + , FlexibleInstances + , GADTs + , KindSignatures + , MultiParamTypeClasses + , OverloadedStrings + , ParallelListComp + , RecordWildCards + , ScopedTypeVariables + , TupleSections + , TypeApplications + , TypeFamilies + , TypeOperators + + + build-depends: base + , servant-pagination + , QuickCheck + , hspec + , servant-server + , text + + other-modules: Servant.PaginationSpec diff --git a/src/Servant/Pagination.hs b/src/Servant/Pagination.hs --- a/src/Servant/Pagination.hs +++ b/src/Servant/Pagination.hs @@ -76,7 +76,7 @@ -- -- defaultRange :: 'Range' "name" 'String' -- defaultRange = --- 'getDefaultRange' ('Data.Proxy.Proxy' @Color) 'Data.Maybe.Nothing' +-- 'getDefaultRange' ('Data.Proxy.Proxy' @Color) -- -- server :: 'Servant.Server.Server' API -- server mrange = do @@ -89,13 +89,6 @@ -- main = -- 'Network.Wai.Handler.Warp.run' 1337 ('Servant.Server.serve' ('Data.Proxy.Proxy' @API) server) -- @ - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - module Servant.Pagination ( -- * Types @@ -114,11 +107,12 @@ -- * Use Ranges , extractRange + , putRange , returnRange , applyRange ) where -import Data.List (filter, find) +import Data.List (filter, find, intercalate) import Data.Maybe (listToMaybe) import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>)) @@ -136,7 +130,7 @@ -- TYPES -- --- | Set of constraints that must apply to every type target of a Range +-- | Set of constraints that must apply to every type target of a 'Range' type IsRangeType a = ( Show a , Ord a @@ -159,6 +153,18 @@ => 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 + + -- | An actual 'Range' instance obtained from parsing / to generate a @Range@ HTTP Header. data Range (field :: Symbol) (a :: *) = (KnownSymbol field, IsRangeType a) => Range @@ -169,12 +175,36 @@ , rangeField :: Proxy field -- ^ Actual field this Range actually refers to } +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 + + -- | 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 extrated to a type bound by the allowed 'fields' on a given 'resource'. + -- 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' @@ -189,10 +219,12 @@ 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 #-} -- | Put a 'Range' in a 'Ranges' @@ -204,9 +236,11 @@ 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 @@ -233,7 +267,7 @@ ) => FromHttpApiData (Ranges (field ': fields) resource) where parseUrlPiece txt = let - RangeOptions{..} = getRangeOptions (Proxy @resource) (Proxy @field) + RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource) toTuples = filter (/= "") . Text.splitOn (Text.singleton ' ') @@ -350,7 +384,7 @@ getFieldValue :: Proxy field -> resource -> RangeType resource field -- | Get parsing options for the 'Range' defined on this 'field' - getRangeOptions :: Proxy resource -> Proxy field -> RangeOptions + getRangeOptions :: Proxy field -> Proxy resource -> RangeOptions getRangeOptions _ _ = defaultOptions -- | Create a default 'Range' from a value and default 'RangeOptions'. Typical use-case @@ -358,13 +392,12 @@ getDefaultRange :: IsRangeType (RangeType resource field) => Proxy resource - -> Maybe (RangeType resource field) -> Range field (RangeType resource field) - getDefaultRange _ val = + getDefaultRange _ = let - RangeOptions{..} = getRangeOptions (Proxy @resource) (Proxy @field) + RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource) in Range - { rangeValue = val + { rangeValue = Nothing @(RangeType resource field) , rangeLimit = defaultRangeLimit , rangeOffset = defaultRangeOffset , rangeOrder = defaultRangeOrder @@ -394,7 +427,7 @@ , PutRange fields field ) => Range field (RangeType resource field) -- ^ Actual 'Range' used to retrieve the results - -> [resource] -- ^ Resources to returned, fetched from a db or a local store + -> [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{..} rs = do let boundaries = (,) diff --git a/test/Servant/PaginationSpec.hs b/test/Servant/PaginationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/PaginationSpec.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.PaginationSpec + ( spec + ) where + + +import Data.Either (isLeft) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Servant (FromHttpApiData (..), ToHttpApiData (..)) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck (Arbitrary (..), property, withMaxSuccess) +import Test.QuickCheck.Gen (Gen, choose, oneof, scale, sized, vectorOf) +import Test.QuickCheck.Modifiers (Positive (..)) + +import Servant.Pagination + + +spec :: Spec +spec = do + describe "round-up properties" $ do + it "parseUrlPiece . toUrlPiece = pure" $ withMaxSuccess 10000 $ property $ + \x -> (fmap extractA . parseUrlPiece . toUrlPiece) x == (pure . extractA) x + + it "parseUrlPiece . toUrlPiece = pure" $ withMaxSuccess 10000 $ property $ + \x -> (fmap extractB . parseUrlPiece . toUrlPiece) x == (pure . extractB) x + + describe "try-out ranges" $ do + let r0 = getDefaultRange (Proxy @Resource) :: Range "fieldA" Int + + it "Range: fieldA" $ + let + Right r = parseUrlPiece "fieldA" + r' = r0 + in + extractA r `shouldBe` pure r' + + it "Range: fieldA 14; limit 42" $ + let + Right r = parseUrlPiece "fieldA 14; limit 42" + r' = r0 { rangeValue = Just 14, rangeLimit = 42 } + in + extractA r `shouldBe` pure r' + + it "Range: fieldA; order asc; offset 2" $ + let + Right r = parseUrlPiece "fieldA; order asc; offset 42" + r' = r0 { rangeOffset = 42, rangeOrder = RangeAsc } + in + extractA r `shouldBe` pure r' + + it "Range: fieldA xxx" $ + isLeft (parseUrlPiece "fieldA xxx" :: Either Text (Ranges '["fieldA", "fieldB"] Resource)) + + it "Range: fieldC" $ + isLeft (parseUrlPiece "fieldC" :: Either Text (Ranges '["fieldA", "fieldB"] Resource)) + + it "Range: fieldB" $ + isLeft (parseUrlPiece "fieldB" :: Either Text (Ranges '["fieldA"] Resource)) + where + extractA :: Ranges '["fieldA", "fieldB"] Resource -> Maybe (Range "fieldA" Int) + extractA = extractRange + + extractB :: Ranges '["fieldA", "fieldB"] Resource -> Maybe (Range "fieldB" SimpleString) + extractB = extractRange + + +data Resource = Resource + { fieldA :: Int + , fieldB :: SimpleString + } deriving (Show, Eq) + +newtype SimpleString = SimpleString + { getSimpleString :: String + } deriving (Show, Eq, Ord) + +instance Arbitrary SimpleString where + arbitrary = + SimpleString <$> scale (+1) (sized $ flip vectorOf $ choose ('a', 'z')) + +instance FromHttpApiData SimpleString where + parseUrlPiece = + fmap SimpleString . parseUrlPiece + +instance ToHttpApiData SimpleString where + toUrlPiece = + toUrlPiece . getSimpleString + +instance HasPagination Resource "fieldA" where + type RangeType Resource "fieldA" = Int + getFieldValue _ = fieldA + +instance HasPagination Resource "fieldB" where + type RangeType Resource "fieldB" = SimpleString + getFieldValue _ = fieldB + +instance Arbitrary (Ranges '["fieldA", "fieldB"] Resource) where + arbitrary = oneof + [ putRange <$> (arbitrary :: Gen (Range "fieldA" Int)) + , putRange <$> (arbitrary :: Gen (Range "fieldB" SimpleString)) + ] + +instance (IsRangeType a, Arbitrary a) => Arbitrary (Range "fieldA" a) where + arbitrary = Range + <$> arbitrary + <*> fmap getPositive arbitrary + <*> fmap getPositive arbitrary + <*> oneof [pure RangeAsc, pure RangeDesc] + <*> pure Proxy + +instance (IsRangeType a, Arbitrary a) => Arbitrary (Range "fieldB" a) where + arbitrary = Range + <$> arbitrary + <*> fmap getPositive arbitrary + <*> fmap getPositive arbitrary + <*> oneof [pure RangeAsc, pure RangeDesc] + <*> pure Proxy diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}