summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKtorZ <>2018-04-16 13:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-04-16 13:29:00 (GMT)
commitd6ff09ea772b05142937eda2dfe3be37b6468649 (patch)
tree54285ac5d80c13debc166d440cb8e6461eef3553
parente67d925cd1de44c3168676d30b4296a2de287307 (diff)
version 2.1.0HEAD2.1.0master
-rw-r--r--.stylish-haskell.yaml9
-rw-r--r--CHANGELOG.md8
-rw-r--r--README.md2
-rw-r--r--examples/Complex.hs2
-rw-r--r--examples/Simple.hs2
-rw-r--r--servant-pagination.cabal66
-rw-r--r--src/Servant/Pagination.hs69
-rw-r--r--test/Servant/PaginationSpec.hs118
-rw-r--r--test/Spec.hs1
9 files changed, 246 insertions, 31 deletions
diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml
index 740e848..9611073 100644
--- 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
index a8a109e..062528b 100644
--- 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
index aa7e3eb..1df9e00 100644
--- a/README.md
+++ b/README.md
@@ -71,7 +71,7 @@ fetch the resources demanded by the client. To send the response, one can levera
```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
index 938f243..76c99af 100644
--- a/examples/Complex.hs
+++ b/examples/Complex.hs
@@ -54,7 +54,7 @@ type MyHeaders =
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
index 8e1eb6e..0c9531a 100644
--- a/examples/Simple.hs
+++ b/examples/Simple.hs
@@ -32,7 +32,7 @@ type API =
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
index 871dd5a..1847807 100644
--- a/servant-pagination.cabal
+++ b/servant-pagination.cabal
@@ -5,7 +5,7 @@ description: This module offers opinionated helpers to declare a type-sa
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 @@ copyright: (c) 2018 Chordify
category: Web
build-type: Simple
cabal-version: >=1.20
-
extra-source-files: README.md
CHANGELOG.md
stack.yaml
@@ -37,8 +36,9 @@ library
default-language: Haskell2010
ghc-options: -Wall -j4
default-extensions: BangPatterns
- , DefaultSignatures
+ , ConstraintKinds
, DataKinds
+ , DefaultSignatures
, DeriveDataTypeable
, DeriveFunctor
, DeriveGeneric
@@ -51,8 +51,10 @@ library
, OverloadedStrings
, ParallelListComp
, RecordWildCards
- , TupleSections
, ScopedTypeVariables
+ , TupleSections
+ , TypeApplications
+ , TypeFamilies
, TypeOperators
build-depends: base >= 4 && < 5
@@ -63,6 +65,7 @@ library
exposed-modules: Servant.Pagination
+
executable servant-pagination-simple
if !flag(examples)
buildable: False
@@ -72,8 +75,9 @@ executable servant-pagination-simple
ghc-options: -Wall -j4 -threaded -rtsopts -with-rtsopts=-N
default-extensions: BangPatterns
- , DefaultSignatures
+ , ConstraintKinds
, DataKinds
+ , DefaultSignatures
, DeriveDataTypeable
, DeriveFunctor
, DeriveGeneric
@@ -86,8 +90,10 @@ executable servant-pagination-simple
, OverloadedStrings
, ParallelListComp
, RecordWildCards
- , TupleSections
, ScopedTypeVariables
+ , TupleSections
+ , TypeApplications
+ , TypeFamilies
, TypeOperators
build-depends: base >= 4 && < 5
@@ -99,6 +105,7 @@ executable servant-pagination-simple
other-modules: Color
+
executable servant-pagination-complex
if !flag(examples)
buildable: False
@@ -108,8 +115,9 @@ executable servant-pagination-complex
ghc-options: -Wall -j4 -threaded -rtsopts -with-rtsopts=-N
default-extensions: BangPatterns
- , DefaultSignatures
+ , ConstraintKinds
, DataKinds
+ , DefaultSignatures
, DeriveDataTypeable
, DeriveFunctor
, DeriveGeneric
@@ -122,8 +130,10 @@ executable servant-pagination-complex
, OverloadedStrings
, ParallelListComp
, RecordWildCards
- , TupleSections
, ScopedTypeVariables
+ , TupleSections
+ , TypeApplications
+ , TypeFamilies
, TypeOperators
build-depends: base >= 4 && < 5
@@ -134,3 +144,43 @@ executable servant-pagination-complex
, 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
index 63204b9..722df42 100644
--- 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 @@ module Servant.Pagination
-- * 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 @@ import qualified Safe
-- 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 @@ data Ranges :: [Symbol] -> * -> * where
=> 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 @@ data Range (field :: Symbol) (a :: *) =
, 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 @@ class ExtractRange (fields :: [Symbol]) (field :: Symbol) where
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 @@ class PutRange (fields :: [Symbol]) (field :: Symbol) where
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 @@ instance
) => 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 @@ class KnownSymbol field => HasPagination resource field where
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 @@ class KnownSymbol field => HasPagination resource field where
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 @@ returnRange
, 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
index 0000000..283577a
--- /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
index 0000000..a824f8c
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}