git.iko.soy/servant-quickcheck
on master help sign in
Comprehensive instances for HasGenRequest.
commit3189902c4b0dfe4ba69bce9097550e896b4acf8a authorJulian K. Arni <jkarni@gmail.com> dateSat 23 Apr 2016, 21:43 (11 years ago) parent1c1c3dc
5 files changed+80−12
compare with master
unifiedsplit
servant-quickcheck.cabal+2 src/Servant/QuickCheck.hs+1 src/Servant/QuickCheck/Internal/HasGenRequest.hs+39 src/Servant/QuickCheck/Internal/Predicates.hs+23−12 test/Servant/QuickCheck/InternalSpec.hs+15
servant-quickcheck.cabal+2
@@ -41,6 +41,7 @@ library
4141 , warp >= 3.2.4 && < 3.3
4242 , process == 1.2.*
4343 , temporary == 1.2.*
44+ , case-insensitive
4445 , hspec
4546 , text == 1.*
4647 hs-source-dirs: src
@@ -74,6 +75,7 @@ test-suite spec
7475 , warp
7576 , servant-server
7677 , servant-client
78+ , servant
7779 , transformers
7880 , QuickCheck
7981 , quickcheck-io
src/Servant/QuickCheck.hs+1
@@ -36,6 +36,7 @@ module Servant.QuickCheck
3636 , (<%>)
3737 , Predicates
3838 , not500
39+ , onlyJsonObjects
3940
4041 -- ** Re-exports
4142 , BaseUrl(..)
src/Servant/QuickCheck/Internal/HasGenRequest.hs+39
@@ -82,6 +82,31 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
8282 param = cs $ symbolVal (Proxy :: Proxy x)
8383 new = arbitrary :: Gen c
8484
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+
85110instance (ReflectMethod method)
86111 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
87112 genRequest _ = return $ \burl -> def
@@ -91,3 +116,17 @@ instance (ReflectMethod method)
91116 , method = reflectMethod (Proxy :: Proxy method)
92117 }
93118
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 @@
11module Servant.QuickCheck.Internal.Predicates where
22
3−import Data.Monoid ((<>))
4−import GHC.Generics (Generic)
5−import Control.Monad
6−import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs)
7−import Network.HTTP.Types (status500)
3+import Control.Monad
4+import Data.Aeson (Object, decode)
5+import Data.Bifunctor (Bifunctor (..))
86import qualified Data.ByteString.Lazy as LBS
9−import Data.Bifunctor (Bifunctor(..))
10−import Data.Text (Text)
7+import qualified Data.ByteString as SBS
8+import Data.CaseInsensitive (mk)
9+import Data.Monoid ((<>))
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)
1115
1216-- | @500 Internal Server Error@ should be avoided - it may represent some
1317-- issue with the application code, and it moreover gives the client little
@@ -17,7 +21,6 @@ import Data.Text (Text)
1721not500 :: ResponsePredicate Text Bool
1822not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
1923
20−{-
2124-- | Returning anything other than an object when returning JSON is considered
2225-- bad practice, as:
2326--
@@ -30,10 +33,13 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
3033--
3134-- This function checks that any @application/json@ responses only return JSON
3235-- objects (and not arrays, strings, numbers, or booleans) at the top level.
33−onlyJsonObjects :: Response b -> IO Bool
36+onlyJsonObjects :: ResponsePredicate Text Bool
3437onlyJsonObjects
35− = ResponsePredicate "onlyJsonObjects" _
38+ = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
39+ Nothing -> False
40+ Just (_ :: Object) -> True)
3641
42+{-
3743-- | When creating a new resource, it is good practice to provide a @Location@
3844-- header with a link to the created resource.
3945--
@@ -42,9 +48,9 @@ onlyJsonObjects
4248-- requests.
4349--
4450-- 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
4652createContainsValidLocation
47− = ResponsePredicate "createContainsValidLocation" _
53+ = ResponsePredicate "createContainsValidLocation" (\resp ->
4854
4955getsHaveLastModifiedHeader :: Response b -> IO Bool
5056getsHaveLastModifiedHeader
@@ -221,3 +227,8 @@ finishPredicates p req mgr = do
221227 resps <- reqResps (reqPreds p) req mgr
222228 let preds = reqPred (reqPreds p) <> respPreds p
223229 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
88import Servant
99import Test.Hspec
1010import Test.QuickCheck
11+import Servant.API.Internal.Test.ComprehensiveAPI
1112
1213import Servant.QuickCheck
1314
15+import Servant.QuickCheck.Internal (genRequest)
16+
1417spec :: Spec
1518spec = do
1619 serversEqualSpec
1720 serverSatisfiesSpec
21+ isComprehensiveSpec
1822
1923serversEqualSpec :: Spec
2024serversEqualSpec = describe "serversEqual" $ do
@@ -32,6 +36,17 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
3236 withServantServer api server $ \burl ->
3337 serverSatisfies api burl args (not500 <%> mempty)
3438
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+
3550
3651------------------------------------------------------------------------------
3752-- APIs