fix serverSatisfies

src/Servant/QuickCheck/Internal/Predicates.hs

@@ -3,9 +3,10 @@ module Servant.QuickCheck.Internal.Predicates where
 import Data.Monoid ((<>))
 import GHC.Generics (Generic)
 import Control.Monad
-import Network.HTTP.Client (Request, Response, responseStatus)
+import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs)
 import Network.HTTP.Types (status500)
 import qualified Data.ByteString.Lazy as LBS
+import Data.Bifunctor (Bifunctor(..))
 import Data.Text (Text)
 
 -- | @500 Internal Server Error@ should be avoided - it may represent some
@@ -13,9 +14,8 @@ import Data.Text (Text)
 -- indication of how to proceed or what went wrong.
 --
 -- This function checks that the response code is not 500.
-not500 :: ResponsePredicate Text [Text]
+not500 :: ResponsePredicate Text Bool
-not500 = ResponsePredicate "not500" (\resp ->
+not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
-        if responseStatus resp == status500 then ["not500"] else [])
 
 {-
 -- | Returning anything other than an object when returning JSON is considered
@@ -158,6 +158,10 @@ data ResponsePredicate n r = ResponsePredicate
   , respPred :: Response LBS.ByteString -> r
   } deriving (Functor, Generic)
 
+instance Bifunctor ResponsePredicate where
+  first f (ResponsePredicate a b) = ResponsePredicate (f a) b
+  second = fmap
+
 instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
   mempty = ResponsePredicate mempty mempty
   a `mappend` b = ResponsePredicate
@@ -167,15 +171,20 @@ instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
 
 data RequestPredicate n r = RequestPredicate
   { reqPredName :: n
-  , reqResps    :: Request -> IO [Response LBS.ByteString]
+  , reqResps    :: Request -> Manager -> IO [Response LBS.ByteString]
   , reqPred     :: ResponsePredicate n r
   } deriving (Generic, Functor)
 
+instance Bifunctor RequestPredicate where
+  first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c)
+  second = fmap
+
+-- TODO: This isn't actually a monoid
 instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
-  mempty = RequestPredicate mempty (\_ -> return mempty) mempty
+  mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty
   a `mappend` b = RequestPredicate
     { reqPredName = reqPredName a <> reqPredName b
-    , reqResps = \x -> liftM2 (<>) (reqResps a x) (reqResps b x)
+    , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
     , reqPred = reqPred a <> reqPred b
     }
 
@@ -194,17 +203,21 @@ class JoinPreds a where
   joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
 
 instance JoinPreds (RequestPredicate Text Bool) where
-  joinPreds p (Predicates x y) = Predicates (p <> x) y
+  joinPreds p (Predicates x y) = Predicates (go <> x) y
+    where go = let p' = first return p
+               in fmap (\z -> if z then [] else reqPredName p') p'
 
 instance JoinPreds (ResponsePredicate Text Bool) where
-  joinPreds p (Predicates x y) = Predicates x (p <> y)
+  joinPreds p (Predicates x y) = Predicates x (go <> y)
+    where go = let p' = first return p
+               in fmap (\z -> if z then [] else respPredName p') p'
 
 infixr 6 <%>
-(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r
+(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
 (<%>) = joinPreds
 
-finishPredicates :: Predicates [Text] [Text] -> Request -> IO [Text]
+finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
-finishPredicates p req = do
+finishPredicates p req mgr = do
-  resps <- reqResps (reqPreds p) req
+  resps <- reqResps (reqPreds p) req mgr
   let preds = reqPred (reqPreds p) <> respPreds p
   return $ mconcat [respPred preds r | r <- resps ]

src/Servant/QuickCheck/Internal/QuickCheck.hs

@@ -3,7 +3,7 @@ module Servant.QuickCheck.Internal.QuickCheck where
 
 import           Data.Proxy               (Proxy)
 import           Network.HTTP.Client      (Manager, defaultManagerSettings,
-                                           newManager, httpLbs)
+                                           newManager, httpLbs, checkStatus, Request)
 import           Network.Wai.Handler.Warp (withApplication)
 import           Servant                  (HasServer, Server, serve)
 import           Servant.Client           (BaseUrl (..), Scheme (..) )
@@ -44,8 +44,8 @@ serversEqual :: HasGenRequest a =>
 serversEqual api burl1 burl2 args req = do
   let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
   r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
-    resp1 <- run $ httpLbs req1 defManager
+    resp1 <- run $ httpLbs (noCheckStatus req1) defManager
-    resp2 <- run $ httpLbs req2 defManager
+    resp2 <- run $ httpLbs (noCheckStatus req2) defManager
     assert $ getResponseEquality req resp1 resp2
   case r of
     Success {} -> return ()
@@ -55,11 +55,12 @@ serversEqual api burl1 burl2 args req = do
     InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
 
 serverSatisfies :: (HasGenRequest a) =>
-  Proxy a -> BaseUrl -> Args -> Predicates Text [Text] -> Expectation
+  Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
 serverSatisfies api burl args preds = do
   let reqs = ($ burl) <$> genRequest api
   r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
-     v <- run $ finishPredicates preds req
+     v <- run $ finishPredicates preds (noCheckStatus req) defManager
+     {-run $ print v-}
      assert $ null v
   case r of
     Success {} -> return ()
@@ -69,6 +70,9 @@ serverSatisfies api burl args preds = do
     InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
 
 
+noCheckStatus :: Request -> Request
+noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
+
 defManager :: Manager
 defManager = unsafePerformIO $ newManager defaultManagerSettings
 {-# NOINLINE defManager #-}