servant-pagination 2.0.0 → 2.1.0

raw patch · 9 files changed

+246/−31 lines, 9 filesdep +QuickCheckdep +hspecdep ~basedep ~servantdep ~servant-serverPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, hspec

Dependency ranges changed: base, servant, servant-server, text

API changes (from Hackage documentation)

Files

• .stylish-haskell.yaml +7/−2
• CHANGELOG.md +8/−0
• README.md +1/−1
• examples/Complex.hs +1/−1
• examples/Simple.hs +1/−1
• servant-pagination.cabal +58/−8
• src/Servant/Pagination.hs +51/−18
• test/Servant/PaginationSpec.hs +118/−0
• test/Spec.hs +1/−0

@@ -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:

@@ -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

@@ -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

@@ -54,7 +54,7 @@  defaultRange :: Range "name" String defaultRange =-  getDefaultRange (Proxy @Color) Nothing+  getDefaultRange (Proxy @Color)  server :: Server API server mrange =

@@ -32,7 +32,7 @@  defaultRange :: Range "name" String defaultRange =-  getDefaultRange (Proxy @Color) Nothing+  getDefaultRange (Proxy @Color)  server :: Server API server mrange = do

@@ -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

@@ -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 = (,)

@@ -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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}