Comprehensive instances for HasGenRequest.

servant-quickcheck.cabal

@@ -41,6 +41,7 @@ library
                      , warp >= 3.2.4 && < 3.3
                      , process == 1.2.*
                      , temporary == 1.2.*
+                     , case-insensitive
                      , hspec
                      , text == 1.*
   hs-source-dirs:      src
@@ -74,6 +75,7 @@ test-suite spec
                      , warp
                      , servant-server
                      , servant-client
+                     , servant
                      , transformers
                      , QuickCheck
                      , quickcheck-io

src/Servant/QuickCheck.hs

@@ -36,6 +36,7 @@ module Servant.QuickCheck
   , (<%>)
   , Predicates
   , not500
+  , onlyJsonObjects
 
   -- ** Re-exports
   , BaseUrl(..)

src/Servant/QuickCheck/Internal/HasGenRequest.hs

@@ -82,6 +82,31 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
         param = cs $ symbolVal (Proxy :: Proxy x)
         new = arbitrary :: Gen c
 
+instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
+    => HasGenRequest (QueryParams x c :> b) where
+    genRequest _ = do
+      new' <- new
+      old' <- old
+      return $ \burl -> let r = old' burl in r {
+          queryString = queryString r
+                     <> if length new' > 0 then fold (toParam <$> new') else ""}
+      where
+        old = genRequest (Proxy :: Proxy b)
+        param = cs $ symbolVal (Proxy :: Proxy x)
+        new = arbitrary :: Gen [c]
+        toParam c = param <> "[]=" <> cs (toQueryParam c)
+        fold = foldr1 (\a b -> a <> "&" <> b)
+
+instance (KnownSymbol x, HasGenRequest b)
+    => HasGenRequest (QueryFlag x :> b) where
+    genRequest _ = do
+      old' <- old
+      return $ \burl -> let r = old' burl in r {
+          queryString = queryString r <> param <> "=" }
+      where
+        old = genRequest (Proxy :: Proxy b)
+        param = cs $ symbolVal (Proxy :: Proxy x)
+
 instance (ReflectMethod method)
     => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
     genRequest _ = return $ \burl -> def
@@ -91,3 +116,17 @@ instance (ReflectMethod method)
        , method = reflectMethod (Proxy :: Proxy method)
        }
 
+instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
+    genRequest _ = genRequest (Proxy :: Proxy a)
+
+instance (HasGenRequest a) => HasGenRequest (IsSecure :> a) where
+    genRequest _ = genRequest (Proxy :: Proxy a)
+
+instance (HasGenRequest a) => HasGenRequest (HttpVersion :> a) where
+    genRequest _ = genRequest (Proxy :: Proxy a)
+
+instance (HasGenRequest a) => HasGenRequest (Vault :> a) where
+    genRequest _ = genRequest (Proxy :: Proxy a)
+
+instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where
+    genRequest _ = genRequest (Proxy :: Proxy a)

src/Servant/QuickCheck/Internal/Predicates.hs

@@ -1,13 +1,17 @@
 module Servant.QuickCheck.Internal.Predicates where
 
-import Data.Monoid ((<>))
-import GHC.Generics (Generic)
-import Control.Monad
-import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs)
-import Network.HTTP.Types (status500)
+import           Control.Monad
+import           Data.Aeson           (Object, decode)
+import           Data.Bifunctor       (Bifunctor (..))
 import qualified Data.ByteString.Lazy as LBS
-import Data.Bifunctor (Bifunctor(..))
-import Data.Text (Text)
+import qualified Data.ByteString      as SBS
+import           Data.CaseInsensitive (mk)
+import           Data.Monoid          ((<>))
+import           Data.Text            (Text)
+import           GHC.Generics         (Generic)
+import           Network.HTTP.Client  (Manager, Request, Response, httpLbs,
+                                       responseBody, responseStatus, responseHeaders)
+import           Network.HTTP.Types   (status500)
 
 -- | @500 Internal Server Error@ should be avoided - it may represent some
 -- issue with the application code, and it moreover gives the client little
@@ -17,7 +21,6 @@ import Data.Text (Text)
 not500 :: ResponsePredicate Text Bool
 not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
 
-{-
 -- | Returning anything other than an object when returning JSON is considered
 -- bad practice, as:
 --
@@ -30,10 +33,13 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
 --
 -- This function checks that any @application/json@ responses only return JSON
 -- objects (and not arrays, strings, numbers, or booleans) at the top level.
-onlyJsonObjects :: Response b -> IO Bool
+onlyJsonObjects :: ResponsePredicate Text Bool
 onlyJsonObjects
-  = ResponsePredicate "onlyJsonObjects" _
+  = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
+      Nothing -> False
+      Just (_ :: Object) -> True)
 
+{-
 -- | When creating a new resource, it is good practice to provide a @Location@
 -- header with a link to the created resource.
 --
@@ -42,9 +48,9 @@ onlyJsonObjects
 -- requests.
 --
 -- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
-createContainsValidLocation :: Response b -> IO Bool
+createContainsValidLocation :: ResponsePredicate Text Bool
 createContainsValidLocation
-  = ResponsePredicate "createContainsValidLocation" _
+  = ResponsePredicate "createContainsValidLocation" (\resp ->
 
 getsHaveLastModifiedHeader :: Response b -> IO Bool
 getsHaveLastModifiedHeader
@@ -221,3 +227,8 @@ finishPredicates p req mgr = do
   resps <- reqResps (reqPreds p) req mgr
   let preds = reqPred (reqPreds p) <> respPreds p
   return $ mconcat [respPred preds r | r <- resps ]
+
+-- * helpers
+
+hasHeader :: SBS.ByteString -> Response b -> Bool
+hasHeader hdr r = mk hdr `elem` (fst <$> responseHeaders r)

test/Servant/QuickCheck/InternalSpec.hs

@@ -8,13 +8,17 @@ import Data.Proxy
 import Servant
 import Test.Hspec
 import Test.QuickCheck
+import Servant.API.Internal.Test.ComprehensiveAPI
 
 import Servant.QuickCheck
 
+import Servant.QuickCheck.Internal (genRequest)
+
 spec :: Spec
 spec = do
   serversEqualSpec
   serverSatisfiesSpec
+  isComprehensiveSpec
 
 serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
@@ -32,6 +36,17 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
     withServantServer api server $ \burl ->
       serverSatisfies api burl args (not500 <%> mempty)
 
+  it "fails for false predicates" $ do
+    withServantServer api server $ \burl ->
+      serverSatisfies api burl args (onlyJsonObjects <%> mempty)
+
+isComprehensiveSpec :: Spec
+isComprehensiveSpec = describe "HasGenRequest" $ do
+
+  it "has instances for all 'servant' combinators" $ do
+    let _g = genRequest comprehensiveAPI
+    True `shouldBe` True -- This is a type-level check
+
 
 ------------------------------------------------------------------------------
 -- APIs