@@ -1,461 +1,132 @@
1+-- | This module contains all logic related to constructing or using
2+-- @Predicates@.
3+{-# LANGUAGE UndecidableInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
15module Servant.QuickCheck.Internal.Predicates where
26
3−import Control.Exception (catch, throw)
4−import Control.Monad (liftM2, unless, when)
5−import Data.Aeson (Object, decode)
6−import Data.Bifunctor (first)
7−import qualified Data.ByteString as SBS
8−import qualified Data.ByteString.Char8 as SBSC
9−import qualified Data.ByteString.Lazy as LBS
10−import Data.CaseInsensitive (foldCase, foldedCase, mk)
11−import Data.Either (isRight)
12−import Data.List.Split (wordsBy)
13−import Data.Maybe (fromMaybe, isJust)
14−import Data.Semigroup (Semigroup (..))
15−import qualified Data.Text as T
16−import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
17− rfc822DateFormat)
18−import GHC.Generics (Generic)
19−import Network.HTTP.Client (Manager, Request, Response, httpLbs,
20− method, parseRequest, requestHeaders,
21− responseBody, responseHeaders,
22− responseStatus)
23−import Network.HTTP.Media (matchAccept)
24−import Network.HTTP.Types (methodGet, methodHead, parseMethod,
25− renderStdMethod, status100, status200,
26− status201, status300, status401,
27− status405, status500)
28−import Prelude.Compat
29−import System.Clock (Clock (Monotonic), diffTimeSpec,
30− getTime, toNanoSecs)
31−
32−import Servant.QuickCheck.Internal.ErrorTypes
33−
34−
35−-- | [__Best Practice__]
36−--
37−-- @500 Internal Server Error@ should be avoided - it may represent some
38−-- issue with the application code, and it moreover gives the client little
39−-- indication of how to proceed or what went wrong.
40−--
41−-- This function checks that the response code is not 500.
42−--
43−-- /Since 0.0.0.0/
44−not500 :: ResponsePredicate
45−not500 = ResponsePredicate $ \resp ->
46− when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
47−
48−-- | [__Optional__]
49−--
50−-- This function checks that the response from the server does not take longer
51−-- than the specified number of nanoseconds.
52−--
53−-- /Since 0.0.2.1/
54−notLongerThan :: Integer -> RequestPredicate
55−notLongerThan maxAllowed
56− = RequestPredicate $ \req mgr -> do
57− start <- getTime Monotonic
58− resp <- httpLbs req mgr
59− end <- getTime Monotonic
60− when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $
61− throw $ PredicateFailure "notLongerThan" (Just req) resp
62− return []
7+import Data.Aeson (ToJSON (toJSON), Value (..))
8+import Data.Proxy (Proxy (..))
9+import Data.Void
10+import Network.HTTP.Types (statusCode)
11+import Servant.Common.Req (ServantError (..))
12+import Test.QuickCheck
13+
14+
15+-- | An HList containing predicates (functions of type @a -> Bool@). This
16+-- datatype is used to represent both filters (what values to discard when
17+-- generating arguments to test an API) and tests results (what to consider a
18+-- failing response).
19+--
20+-- For both filters and test results, only the *first* predicate of the
21+-- appropriate type is used.
22+--
23+-- Use 'emptyPredicates', 'addPredicate', 'addLeftPredicate' and
24+-- 'addRightPredicate' to construct a @Predicates@.
25+data Predicates a where
26+ HNil :: Predicates '[]
27+ HCons :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
28+ HConsC :: Constraint a -> Predicates b -> Predicates (Constraint a ': b)
29+
30+class HasPredicate a b where
31+ getPredicate :: Predicates a -> b -> Bool
32+
33+instance {-# OVERLAPPING #-} HasPredicate '[] a where
34+ getPredicate _ = const True
35+
36+-- TODO: Find some better way of distinguishing how the predicate is being used
37+instance {-# OVERLAPPING #-} HasPredicate '[] (Either ServantError a) where
38+ getPredicate _ = discard
39+
40+instance {-# OVERLAPPING #-} HasPredicate (a ': xs) a where
41+ getPredicate (HCons a _) = a
42+ getPredicate (HConsC _ _) = error "not impossible, but non-sensical"
43+
44+data Constraint ctx = Constraint
45+ { getConstraint :: forall a . (ctx a) => a -> Bool }
46+
47+-- This is a little bit of a hack. Ideally instances would match when the
48+-- predicate is polymorphic, but that doesn't work since the polymorphic type
49+-- may have to unify with multiple distict values.
50+--
51+-- It may however be possible to define a MPTC from monomorphic to polymorphic
52+-- datatypes to avoid this issue.
53+instance {-# OVERLAPPING #-}
54+ HasPredicate (Either ServantError Void ': xs) (Either ServantError a) where
55+ getPredicate (HCons f _) x = case x of
56+ Left e -> f (Left e)
57+ Right _ -> True
58+
59+instance {-# OVERLAPPING #-} (ctx a)
60+ => HasPredicate (Constraint ctx ': xs) (Either ServantError a) where
61+ getPredicate (HConsC f _) x = case x of
62+ Left _ -> discard -- Not clear whether checking for FailureResponse is better
63+ Right v -> getConstraint f v
64+ getPredicate (HCons _ _) _ = error "not impossible, but non-sensical"
65+
66+instance {-# OVERLAPPABLE #-} (ls ~ (b ': xs), HasPredicate xs a)
67+ => HasPredicate ls a where
68+ getPredicate (HCons _ xs) = getPredicate xs
69+ getPredicate _ = error "impossible"
70+
71+-- | Add a predicate to a list of predicates. Note that the predicate may not
72+-- be polymorphic.
73+addPredicate :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
74+addPredicate = HCons
75+
76+-- | Add a predicate with a class constraint.
77+--
78+-- Note that every possible argument must be an instance of that class for this
79+-- to typecheck. In other words, if the @Predicates@ is being used for return
80+-- types, every return type in the API must be an instance of the class. If
81+-- it's being used for filtering, every capture, header, body, etc. type must
82+-- be an instance of that class.
83+--
84+-- This can be used to for example test that returned JSON has certain
85+-- properties, or (via generics) that if any datatype contains a (possibly
86+-- nested) field of a particular type, it always meets certain properties.
87+addPolyPredicate :: proxy ctx -> (forall a. ctx a => a -> Bool) -> Predicates b
88+ -> Predicates (Constraint ctx ': b)
89+addPolyPredicate _ p = HConsC (Constraint p)
90+
91+-- | Given a predicate over an @p :: a -> Bool@, add a predicate to the @Predicates@
92+-- list that succeeds on an @val :: Either ServantError a@ if @val@ is a
93+-- @Left@, or a @Right v@ such that @p a == True@.
94+addRightPredicate :: (a -> Bool) -> Predicates b -> Predicates (Either ServantError a ': b)
95+addRightPredicate p = addPredicate $ either (const True) p
96+
97+-- | The @Left@ analog of 'addRightPredicate'.
98+addLeftPredicate :: (ServantError -> Bool) -> Predicates b
99+ -> Predicates (Either ServantError Void ': b)
100+addLeftPredicate p = addPredicate $ either p (error "impossible")
101+
102+-- | An empty list of predicates. This doesn't discard any values when used as
103+-- a filter, and doesn't fail any value when used as a condition to satisfy.
104+emptyPredicates :: Predicates '[]
105+emptyPredicates = HNil
106+
107+-- * Useful predicates
108+
109+-- | A @Predicates@ list that fails a test if the response is an HTTP 500 error.
110+never500s :: Predicates '[Either ServantError Void]
111+never500s = addLeftPredicate go emptyPredicates
112+ where
113+ go (FailureResponse x _ _) = statusCode x /= 500
114+ go _ = True
63115
64−-- | [__Best Practice__]
116+-- | A @Predicates@ list that fails a test if the response is anything but a
117+-- top-level object (e.g., if it is an array or literal).
65118--
66−-- Returning anything other than an object when returning JSON is considered
67−-- bad practice, as:
119+-- Returning anything other than object is considered bad practice, as
68120--
69121-- (1) it is hard to modify the returned value while maintaining backwards
70−-- compatibility
71−-- (2) many older tools do not support top-level arrays
122+-- compatibility;
123+-- (2) many older tools do not support top-level arrays;
72124-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
73−-- on what RFC you're going by
74−-- (4) there are security issues with top-level arrays
75−--
76−-- This function checks that any @application/json@ responses only return JSON
77−-- objects (and not arrays, strings, numbers, or booleans) at the top level.
78−--
79−-- __References__:
80−--
81−-- * JSON Grammar: <https://tools.ietf.org/html/rfc7159#section-2 RFC 7159 Section 2>
82−-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
83−--
84−-- /Since 0.0.0.0/
85−onlyJsonObjects :: ResponsePredicate
86−onlyJsonObjects
87− = ResponsePredicate (\resp -> do
88− case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
89− Nothing -> return ()
90− Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do
91− case (decode (responseBody resp) :: Maybe Object) of
92− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
93− Just _ -> return ())
94−
95−-- | __Optional__
96−--
97−-- When creating a new resource, it is good practice to provide a @Location@
98−-- header with a link to the created resource.
99−--
100−-- This function checks that every @201 Created@ response contains a @Location@
101−-- header, and that the link in it responds with a 2XX response code to @GET@
102−-- requests.
103−--
104−-- This is considered optional because other means of linking to the resource
105−-- (e.g. via the response body) are also acceptable; linking to the resource in
106−-- some way is considered best practice.
107−--
108−-- __References__:
109−--
110−-- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>
111−-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
112−--
113−-- /Since 0.0.0.0/
114−createContainsValidLocation :: RequestPredicate
115−createContainsValidLocation
116− = RequestPredicate $ \req mgr -> do
117− let n = "createContainsValidLocation"
118− resp <- httpLbs req mgr
119− if responseStatus resp == status201
120− then case lookup "Location" $ responseHeaders resp of
121− Nothing -> throw $ PredicateFailure n (Just req) resp
122− Just l -> case parseRequest $ SBSC.unpack l of
123− Nothing -> throw $ PredicateFailure n (Just req) resp
124− Just x -> do
125− resp2 <- httpLbs x mgr
126− status2XX (Just req) resp2 n
127− return [resp, resp2]
128− else return [resp]
129−
130−-- | [__Optional__]
131−--
132−-- The @Last-Modified@ header represents the time a resource was last
133−-- modified. It is used to drive caching and conditional requests.
134−--
135−-- When using this mechanism, the server adds the @Last-Modified@ header to
136−-- responses. Clients may then make requests with the @If-Modified-Since@
137−-- header to conditionally request resources. If the resource has not
138−-- changed since that date, the server responds with a status code of 304
139−-- (@Not Modified@) without a response body.
140−--
141−-- The @Last-Modified@ header can also be used in conjunction with the
142−-- @If-Unmodified-Since@ header to drive optimistic concurrency.
143−--
144−-- The @Last-Modified@ date must be in RFC 822 format.
145−--
146−-- __References__:
147−--
148−-- * 304 Not Modified: <https://tools.ietf.org/html/rfc7232#section-4.1 RFC 7232 Section 4.1>
149−-- * Last-Modified header: <https://tools.ietf.org/html/rfc7232#section-2.2 RFC 7232 Section 2.2>
150−-- * If-Modified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.3 RFC 7232 Section 3.3>
151−-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
152−-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
153−--
154−-- /Since 0.0.2.1/
155−getsHaveLastModifiedHeader :: RequestPredicate
156−getsHaveLastModifiedHeader
157− = RequestPredicate $ \req mgr ->
158− if (method req == methodGet)
159− then do
160− resp <- httpLbs req mgr
161− unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
162− throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
163− return [resp]
164− else return []
165−
166−
167−
168−-- | [__RFC Compliance__]
169−--
170−-- When an HTTP request has a method that is not allowed,
171−-- a 405 response should be returned. Additionally, it is good practice to
172−-- return an @Allow@
173−-- header with the list of allowed methods.
174−--
175−-- This function checks that every @405 Method Not Allowed@ response contains
176−-- an @Allow@ header with a list of standard HTTP methods.
177−--
178−-- Note that 'servant' itself does not currently set the @Allow@ headers.
179−--
180−-- __References__:
181−--
182−-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
183−-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
184−-- * Servant Allow header issue: <https://github.com/haskell-servant/servant/issues/489 Issue #489>
185−--
186−-- /Since 0.0.0.0/
187−notAllowedContainsAllowHeader :: RequestPredicate
188−notAllowedContainsAllowHeader
189− = RequestPredicate $ \req mgr -> do
190− let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
191− , renderStdMethod m /= method req ]
192− resp <- mapM (flip httpLbs mgr) reqs
193−
194− case filter pred' (zip reqs resp) of
195− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
196− [] -> return resp
197− where
198− pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
199− where
200− go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
201− $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
202−
203−
204−-- | [__RFC Compliance__]
205−--
206−-- When a request contains an @Accept@ header, the server must either return
207−-- content in one of the requested representations, or respond with @406 Not
208−-- Acceptable@.
209−--
210−-- This function checks that every *successful* response has a @Content-Type@
211−-- header that matches the @Accept@ header. It does *not* check that the server
212−-- matches the quality descriptions of the @Accept@ header correctly.
213−--
214−-- __References__:
215−--
216−-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
217−--
218−-- /Since 0.0.0.0/
219−honoursAcceptHeader :: RequestPredicate
220−honoursAcceptHeader
221− = RequestPredicate $ \req mgr -> do
222− resp <- httpLbs req mgr
223− let scode = responseStatus resp
224− sctype = lookup "Content-Type" $ responseHeaders resp
225− sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
226− if status100 < scode && scode < status300
227− then if isJust $ sctype >>= \x -> matchAccept [x] sacc
228− then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
229− else return [resp]
230− else return [resp]
231−
232−
233−-- | [__Best Practice__]
234−--
235−-- Whether or not a representation should be cached, it is good practice to
236−-- have a @Cache-Control@ header for @GET@ requests. If the representation
237−-- should not be cached, used @Cache-Control: no-cache@.
238−--
239−-- This function checks that @GET@ responses have @Cache-Control@ header.
240−-- It does NOT currently check that the header is valid.
241−--
242−-- __References__:
243−--
244−-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
245−--
246−-- /Since 0.0.0.0/
247−getsHaveCacheControlHeader :: RequestPredicate
248−getsHaveCacheControlHeader
249− = RequestPredicate $ \req mgr ->
250− if (method req == methodGet)
251− then do
252− resp <- httpLbs req mgr
253− unless (hasValidHeader "Cache-Control" (const True) resp) $ do
254− throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
255− return [resp]
256− else return []
257−
258−-- | [__Best Practice__]
259−--
260−-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
261−--
262−-- /Since 0.0.0.0/
263−headsHaveCacheControlHeader :: RequestPredicate
264−headsHaveCacheControlHeader
265− = RequestPredicate $ \req mgr ->
266− if (method req == methodHead)
267− then do
268− resp <- httpLbs req mgr
269− unless (hasValidHeader "Cache-Control" (const True) resp) $
270− throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
271− return [resp]
272− else return []
273−{-
274−-- |
275−--
276−-- If the original request modifies the resource, this function makes two
277−-- requests:
278−--
279−-- (1) Once, with the original request and a future date as the
280−-- @If-Unmodified-Since@, which is expected to succeed.
281−-- (2) Then with the original request again, with a @If-Unmodified-Since@
282−-- safely in the past. Since presumably the representation has been changed
283−-- recently (by the first request), this is expected to fail with @412
284−-- Precondition Failure@.
285−--
286−-- Note that the heuristic used to guess whether the original request modifies
287−-- a resource is simply whether the method is @PUT@ or @PATCH@, which may be
288−-- incorrect in certain circumstances.
289−supportsIfUnmodifiedSince :: Predicate b Bool
290−supportsIfUnmodifiedSince
291− = ResponsePredicate "supportsIfUnmodifiedSince" _
292−
293−-- | @OPTIONS@ responses should contain an @Allow@ header with the list of
294−-- allowed methods.
295−--
296−-- If a request is an @OPTIONS@ request, and if the response is a successful
297−-- one, this function checks the response for an @Allow@ header. It fails if:
298−--
299−-- (1) There is no @Allow@ header
300−-- (2) The @Allow@ header does not have standard HTTP methods in the correct
301−-- format
302−-- (3) Making a request to the same URL with one of those methods results in
303−-- a 404 or 405.
304−optionsContainsValidAllow :: Predicate b Bool
305−optionsContainsValidAllow
306− = ResponsePredicate "optionsContainsValidAllow" _
307−
308−-- | Link headers are a standardized way of presenting links that may be
309−-- relevant to a client.
310−--
311−-- This function checks that any @Link@ headers have values in the correct
312−-- format.
313−--
314−-- __References__:
315−--
316−-- * <https://tools.ietf.org/html/rfc5988 RFC 5988 Section 5>
317−linkHeadersAreValid :: Predicate b Bool
318−linkHeadersAreValid
319− = ResponsePredicate "linkHeadersAreValid" _
320−
321−-}
322−-- | [__RFC Compliance__]
323−--
324−-- Any @401 Unauthorized@ response must include a @WWW-Authenticate@ header.
325−--
326−-- This function checks that, if a response has status code 401, it contains a
327−-- @WWW-Authenticate@ header.
328−--
329−-- __References__:
330−--
331−-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
332−--
333−-- /Since 0.0.0.0/
334−unauthorizedContainsWWWAuthenticate :: ResponsePredicate
335−unauthorizedContainsWWWAuthenticate
336− = ResponsePredicate $ \resp ->
337− if responseStatus resp == status401
338− then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339− throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
340− else return ()
341−
342−
343−-- | [__RFC Compliance__]
344−--
345−-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
346−--
347−-- This function checks that HTML documents (those with `Content-Type: text/html...`)
348−-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
349−--
350−-- __References__:
351−--
352−-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
353−-- /Since 0.3.0.0/
354−htmlIncludesDoctype :: ResponsePredicate
355−htmlIncludesDoctype
356− = ResponsePredicate $ \resp ->
357− if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
358− then do
359− let htmlContent = foldCase . LBS.take 20 $ responseBody resp
360− unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
361− throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
362− else return ()
363−
364−-- * Predicate logic
365−
366−-- The idea with all this footwork is to not waste any requests. Rather than
367−-- generating new requests and only applying one predicate to the response, we
368−-- apply as many predicates as possible.
369−--
370−-- Still, this is all kind of ugly.
371−
372−-- | A predicate that depends only on the response.
373−--
374−-- /Since 0.0.0.0/
375−newtype ResponsePredicate = ResponsePredicate
376− { getResponsePredicate :: Response LBS.ByteString -> IO ()
377− } deriving (Generic)
378−
379−instance Semigroup ResponsePredicate where
380− ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
381−
382−instance Monoid ResponsePredicate where
383− mempty = ResponsePredicate $ const $ return ()
384− mappend = (<>)
385−
386−-- | A predicate that depends on both the request and the response.
387−--
388−-- /Since 0.0.0.0/
389−newtype RequestPredicate = RequestPredicate
390− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
391− } deriving (Generic)
392−
393−-- TODO: This isn't actually a monoid
394−instance Monoid RequestPredicate where
395− mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
396− mappend = (<>)
397−
398−-- TODO: This isn't actually a monoid
399−instance Semigroup RequestPredicate where
400− RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
401− liftM2 (<>) (a r mgr) (b r mgr)
402−
403−-- | A set of predicates. Construct one with 'mempty' and '<%>'.
404−data Predicates = Predicates
405− { requestPredicates :: RequestPredicate
406− , responsePredicates :: ResponsePredicate
407− } deriving (Generic)
408−
409−instance Semigroup Predicates where
410− a <> b = Predicates (requestPredicates a <> requestPredicates b)
411− (responsePredicates a <> responsePredicates b)
412−
413−instance Monoid Predicates where
414− mempty = Predicates mempty mempty
415− mappend = (<>)
416−
417−class JoinPreds a where
418− joinPreds :: a -> Predicates -> Predicates
419−
420−instance JoinPreds (RequestPredicate ) where
421− joinPreds p (Predicates x y) = Predicates (p <> x) y
422−
423−instance JoinPreds (ResponsePredicate ) where
424− joinPreds p (Predicates x y) = Predicates x (p <> y)
425−
426−-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
427−-- the existing predicates.
428−--
429−-- > not500 <%> onlyJsonObjects <%> empty
430−--
431−-- /Since 0.0.0.0/
432−(<%>) :: JoinPreds a => a -> Predicates -> Predicates
433−(<%>) = joinPreds
434−infixr 6 <%>
435−
436−finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
437−finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
125+-- on what RFC you're going by;
126+-- (4) there are security issues with top-level arrays.
127+onlyJsonObjects :: Predicates '[Constraint ToJSON]
128+onlyJsonObjects = addPolyPredicate (Proxy :: Proxy ToJSON) go emptyPredicates
438129 where
439− go = do
440− resps <- getRequestPredicate (requestPredicates p) req mgr
441− mapM_ (getResponsePredicate $ responsePredicates p) resps
442− return Nothing
443−
444−-- * helpers
445−
446−hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool
447−hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
448− Nothing -> False
449− Just v -> p v
450−
451−isRFC822Date :: SBS.ByteString -> Bool
452−isRFC822Date s
453− = case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of
454− Nothing -> False
455− Just (_ :: UTCTime) -> True
456−
457−status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
458−status2XX mreq resp t
459− | status200 <= responseStatus resp && responseStatus resp < status300
460− = return ()
461− | otherwise = throw $ PredicateFailure t mreq resp
130+ go x = case toJSON x of
131+ Object _ -> True
132+ _ -> False