git.iko.soy/servant-quickcheck
on master help sign in
Comprehensive instances for HasGenRequest.
3189902Julian K. Arni
servant-quickcheck.cabal+2
compare with master
unifiedsplit
@@ -41,6 +41,7 @@ library
41 , warp >= 3.2.4 && < 3.3
41 , warp >= 3.2.4 && < 3.3
42 , process == 1.2.*
42 , process == 1.2.*
43 , temporary == 1.2.*
43 , temporary == 1.2.*
44+ , case-insensitive
44 , hspec
45 , hspec
45 , text == 1.*
46 , text == 1.*
46 hs-source-dirs: src
47 hs-source-dirs: src
@@ -74,6 +75,7 @@ test-suite spec
74 , warp
75 , warp
75 , servant-server
76 , servant-server
76 , servant-client
77 , servant-client
78+ , servant
77 , transformers
79 , transformers
78 , QuickCheck
80 , QuickCheck
79 , quickcheck-io
81 , quickcheck-io
src/Servant/QuickCheck.hs+1
@@ -36,6 +36,7 @@ module Servant.QuickCheck
36 , (<%>)
36 , (<%>)
37 , Predicates
37 , Predicates
38 , not500
38 , not500
39+ , onlyJsonObjects
39
40
40 -- ** Re-exports
41 -- ** Re-exports
41 , BaseUrl(..)
42 , BaseUrl(..)
src/Servant/QuickCheck/Internal/HasGenRequest.hs+39
@@ -82,6 +82,31 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
82 param = cs $ symbolVal (Proxy :: Proxy x)
82 param = cs $ symbolVal (Proxy :: Proxy x)
83 new = arbitrary :: Gen c
83 new = arbitrary :: Gen c
84
84
85+instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
86+ => HasGenRequest (QueryParams x c :> b) where
87+ genRequest _ = do
88+ new' <- new
89+ old' <- old
90+ return $ \burl -> let r = old' burl in r {
91+ queryString = queryString r
92+ <> if length new' > 0 then fold (toParam <$> new') else ""}
93+ where
94+ old = genRequest (Proxy :: Proxy b)
95+ param = cs $ symbolVal (Proxy :: Proxy x)
96+ new = arbitrary :: Gen [c]
97+ toParam c = param <> "[]=" <> cs (toQueryParam c)
98+ fold = foldr1 (\a b -> a <> "&" <> b)
99+
100+instance (KnownSymbol x, HasGenRequest b)
101+ => HasGenRequest (QueryFlag x :> b) where
102+ genRequest _ = do
103+ old' <- old
104+ return $ \burl -> let r = old' burl in r {
105+ queryString = queryString r <> param <> "=" }
106+ where
107+ old = genRequest (Proxy :: Proxy b)
108+ param = cs $ symbolVal (Proxy :: Proxy x)
109+
85instance (ReflectMethod method)
110instance (ReflectMethod method)
86 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
111 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
87 genRequest _ = return $ \burl -> def
112 genRequest _ = return $ \burl -> def
@@ -91,3 +116,17 @@ instance (ReflectMethod method)
91 , method = reflectMethod (Proxy :: Proxy method)
116 , method = reflectMethod (Proxy :: Proxy method)
92 }
117 }
93
118
119+instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
120+ genRequest _ = genRequest (Proxy :: Proxy a)
121+
122+instance (HasGenRequest a) => HasGenRequest (IsSecure :> a) where
123+ genRequest _ = genRequest (Proxy :: Proxy a)
124+
125+instance (HasGenRequest a) => HasGenRequest (HttpVersion :> a) where
126+ genRequest _ = genRequest (Proxy :: Proxy a)
127+
128+instance (HasGenRequest a) => HasGenRequest (Vault :> a) where
129+ genRequest _ = genRequest (Proxy :: Proxy a)
130+
131+instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where
132+ genRequest _ = genRequest (Proxy :: Proxy a)
src/Servant/QuickCheck/Internal/Predicates.hs+23−12
@@ -1,13 +1,17 @@
1module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
2
2
3−import Data.Monoid ((<>))
4−import GHC.Generics (Generic)
5−import Control.Monad
3+import Control.Monad
6−import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs)
4+import Data.Aeson (Object, decode)
7−import Network.HTTP.Types (status500)
5+import Data.Bifunctor (Bifunctor (..))
8import qualified Data.ByteString.Lazy as LBS
6import qualified Data.ByteString.Lazy as LBS
9−import Data.Bifunctor (Bifunctor(..))
7+import qualified Data.ByteString as SBS
8+import Data.CaseInsensitive (mk)
9+import Data.Monoid ((<>))
10−import Data.Text (Text)
10+import Data.Text (Text)
11+import GHC.Generics (Generic)
12+import Network.HTTP.Client (Manager, Request, Response, httpLbs,
13+ responseBody, responseStatus, responseHeaders)
14+import Network.HTTP.Types (status500)
11
15
12-- | @500 Internal Server Error@ should be avoided - it may represent some
16-- | @500 Internal Server Error@ should be avoided - it may represent some
13-- issue with the application code, and it moreover gives the client little
17-- issue with the application code, and it moreover gives the client little
@@ -17,7 +21,6 @@ import Data.Text (Text)
17not500 :: ResponsePredicate Text Bool
21not500 :: ResponsePredicate Text Bool
18not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
22not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
19
23
20−{-
21-- | Returning anything other than an object when returning JSON is considered
24-- | Returning anything other than an object when returning JSON is considered
22-- bad practice, as:
25-- bad practice, as:
23--
26--
@@ -30,10 +33,13 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
30--
33--
31-- This function checks that any @application/json@ responses only return JSON
34-- This function checks that any @application/json@ responses only return JSON
32-- objects (and not arrays, strings, numbers, or booleans) at the top level.
35-- objects (and not arrays, strings, numbers, or booleans) at the top level.
33−onlyJsonObjects :: Response b -> IO Bool
36+onlyJsonObjects :: ResponsePredicate Text Bool
34onlyJsonObjects
37onlyJsonObjects
35− = ResponsePredicate "onlyJsonObjects" _
38+ = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
39+ Nothing -> False
40+ Just (_ :: Object) -> True)
36
41
42+{-
37-- | When creating a new resource, it is good practice to provide a @Location@
43-- | When creating a new resource, it is good practice to provide a @Location@
38-- header with a link to the created resource.
44-- header with a link to the created resource.
39--
45--
@@ -42,9 +48,9 @@ onlyJsonObjects
42-- requests.
48-- requests.
43--
49--
44-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
50-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
45−createContainsValidLocation :: Response b -> IO Bool
51+createContainsValidLocation :: ResponsePredicate Text Bool
46createContainsValidLocation
52createContainsValidLocation
47− = ResponsePredicate "createContainsValidLocation" _
53+ = ResponsePredicate "createContainsValidLocation" (\resp ->
48
54
49getsHaveLastModifiedHeader :: Response b -> IO Bool
55getsHaveLastModifiedHeader :: Response b -> IO Bool
50getsHaveLastModifiedHeader
56getsHaveLastModifiedHeader
@@ -221,3 +227,8 @@ finishPredicates p req mgr = do
221 resps <- reqResps (reqPreds p) req mgr
227 resps <- reqResps (reqPreds p) req mgr
222 let preds = reqPred (reqPreds p) <> respPreds p
228 let preds = reqPred (reqPreds p) <> respPreds p
223 return $ mconcat [respPred preds r | r <- resps ]
229 return $ mconcat [respPred preds r | r <- resps ]
230+
231+-- * helpers
232+
233+hasHeader :: SBS.ByteString -> Response b -> Bool
234+hasHeader hdr r = mk hdr `elem` (fst <$> responseHeaders r)
test/Servant/QuickCheck/InternalSpec.hs+15
@@ -8,13 +8,17 @@ import Data.Proxy
8import Servant
8import Servant
9import Test.Hspec
9import Test.Hspec
10import Test.QuickCheck
10import Test.QuickCheck
11+import Servant.API.Internal.Test.ComprehensiveAPI
11
12
12import Servant.QuickCheck
13import Servant.QuickCheck
13
14
15+import Servant.QuickCheck.Internal (genRequest)
16+
14spec :: Spec
17spec :: Spec
15spec = do
18spec = do
16 serversEqualSpec
19 serversEqualSpec
17 serverSatisfiesSpec
20 serverSatisfiesSpec
21+ isComprehensiveSpec
18
22
19serversEqualSpec :: Spec
23serversEqualSpec :: Spec
20serversEqualSpec = describe "serversEqual" $ do
24serversEqualSpec = describe "serversEqual" $ do
@@ -32,6 +36,17 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
32 withServantServer api server $ \burl ->
36 withServantServer api server $ \burl ->
33 serverSatisfies api burl args (not500 <%> mempty)
37 serverSatisfies api burl args (not500 <%> mempty)
34
38
39+ it "fails for false predicates" $ do
40+ withServantServer api server $ \burl ->
41+ serverSatisfies api burl args (onlyJsonObjects <%> mempty)
42+
43+isComprehensiveSpec :: Spec
44+isComprehensiveSpec = describe "HasGenRequest" $ do
45+
46+ it "has instances for all 'servant' combinators" $ do
47+ let _g = genRequest comprehensiveAPI
48+ True `shouldBe` True -- This is a type-level check
49+
35
50
36------------------------------------------------------------------------------
51------------------------------------------------------------------------------
37-- APIs
52-- APIs