@@ -3,9 +3,10 @@ module Servant.QuickCheck.Internal.Predicates where
33import Data.Monoid ((<>))
44import GHC.Generics (Generic)
55import Control.Monad
6−import Network.HTTP.Client (Request, Response, responseStatus)
6+import Network.HTTP.Client (Request, Response, responseStatus, Manager, httpLbs)
77import Network.HTTP.Types (status500)
88import qualified Data.ByteString.Lazy as LBS
9+import Data.Bifunctor (Bifunctor(..))
910import Data.Text (Text)
1011
1112-- | @500 Internal Server Error@ should be avoided - it may represent some
@@ -13,9 +14,8 @@ import Data.Text (Text)
1314-- indication of how to proceed or what went wrong.
1415--
1516-- This function checks that the response code is not 500.
16−not500 :: ResponsePredicate Text [Text]
17−not500 = ResponsePredicate "not500" (\resp ->
18− if responseStatus resp == status500 then ["not500"] else [])
17+not500 :: ResponsePredicate Text Bool
18+not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
1919
2020{-
2121-- | Returning anything other than an object when returning JSON is considered
@@ -158,6 +158,10 @@ data ResponsePredicate n r = ResponsePredicate
158158 , respPred :: Response LBS.ByteString -> r
159159 } deriving (Functor, Generic)
160160
161+instance Bifunctor ResponsePredicate where
162+ first f (ResponsePredicate a b) = ResponsePredicate (f a) b
163+ second = fmap
164+
161165instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
162166 mempty = ResponsePredicate mempty mempty
163167 a `mappend` b = ResponsePredicate
@@ -167,15 +171,20 @@ instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
167171
168172data RequestPredicate n r = RequestPredicate
169173 { reqPredName :: n
170− , reqResps :: Request -> IO [Response LBS.ByteString]
174+ , reqResps :: Request -> Manager -> IO [Response LBS.ByteString]
171175 , reqPred :: ResponsePredicate n r
172176 } deriving (Generic, Functor)
173177
178+instance Bifunctor RequestPredicate where
179+ first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c)
180+ second = fmap
181+
182+-- TODO: This isn't actually a monoid
174183instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
175− mempty = RequestPredicate mempty (\_ -> return mempty) mempty
184+ mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty
176185 a `mappend` b = RequestPredicate
177186 { reqPredName = reqPredName a <> reqPredName b
178− , reqResps = \x -> liftM2 (<>) (reqResps a x) (reqResps b x)
187+ , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
179188 , reqPred = reqPred a <> reqPred b
180189 }
181190
@@ -194,17 +203,21 @@ class JoinPreds a where
194203 joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
195204
196205instance JoinPreds (RequestPredicate Text Bool) where
197− joinPreds p (Predicates x y) = Predicates (p <> x) y
206+ joinPreds p (Predicates x y) = Predicates (go <> x) y
207+ where go = let p' = first return p
208+ in fmap (\z -> if z then [] else reqPredName p') p'
198209
199210instance JoinPreds (ResponsePredicate Text Bool) where
200− joinPreds p (Predicates x y) = Predicates x (p <> y)
211+ joinPreds p (Predicates x y) = Predicates x (go <> y)
212+ where go = let p' = first return p
213+ in fmap (\z -> if z then [] else respPredName p') p'
201214
202215infixr 6 <%>
203−(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r
216+(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
204217(<%>) = joinPreds
205218
206−finishPredicates :: Predicates [Text] [Text] -> Request -> IO [Text]
207−finishPredicates p req = do
208− resps <- reqResps (reqPreds p) req
219+finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
220+finishPredicates p req mgr = do
221+ resps <- reqResps (reqPreds p) req mgr
209222 let preds = reqPred (reqPreds p) <> respPreds p
210223 return $ mconcat [respPred preds r | r <- resps ]