@@ -1,132 +1,461 @@
1−-- | This module contains all logic related to constructing or using
2−-- @Predicates@.
3−{-# LANGUAGE UndecidableInstances #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
51module Servant.QuickCheck.Internal.Predicates where
62
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
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
11547
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).
48+-- | [__Optional__]
11849--
119−-- Returning anything other than object is considered bad practice, as
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 []
63+
64+-- | [__Best Practice__]
65+--
66+-- Returning anything other than an object when returning JSON is considered
67+-- bad practice, as:
12068--
12169-- (1) it is hard to modify the returned value while maintaining backwards
122−-- compatibility;
123−-- (2) many older tools do not support top-level arrays;
70+-- compatibility
71+-- (2) many older tools do not support top-level arrays
12472-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
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
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
129438 where
130− go x = case toJSON x of
131− Object _ -> True
132− _ -> False
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