@@ -1,36 +1,28 @@
11module Servant.QuickCheck.Internal.Predicates where
22
3−import Control.Exception (catch, throw)
4−import Control.Monad (liftM2, unless, when)
3+import Control.Monad (liftM2)
54import Data.Aeson (Object, decode)
6−import Data.Bifunctor (first)
5+import Data.Bifunctor (Bifunctor (..))
6+import Prelude.Compat
77import qualified Data.ByteString as SBS
88import qualified Data.ByteString.Char8 as SBSC
99import qualified Data.ByteString.Lazy as LBS
10−import Data.CaseInsensitive (foldCase, foldedCase, mk)
10+import Data.CaseInsensitive (mk)
1111import Data.Either (isRight)
1212import Data.List.Split (wordsBy)
1313import 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)
14+import Data.Monoid ((<>))
15+import Data.Text (Text)
1816import GHC.Generics (Generic)
1917import Network.HTTP.Client (Manager, Request, Response, httpLbs,
20− method, parseRequest, requestHeaders,
18+ method, parseUrl, requestHeaders,
2119 responseBody, responseHeaders,
2220 responseStatus)
2321import Network.HTTP.Media (matchAccept)
2422import 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−
23+ renderStdMethod, status200, status201,
24+ status300, status401, status405,
25+ status500, status100)
3426
3527-- | [__Best Practice__]
3628--
@@ -41,25 +33,8 @@ import Servant.QuickCheck.Internal.ErrorTypes
4133-- This function checks that the response code is not 500.
4234--
4335-- /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 []
36+not500 :: ResponsePredicate Text Bool
37+not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
6338
6439-- | [__Best Practice__]
6540--
@@ -82,15 +57,11 @@ notLongerThan maxAllowed
8257-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
8358--
8459-- /Since 0.0.0.0/
85−onlyJsonObjects :: ResponsePredicate
60+onlyJsonObjects :: ResponsePredicate Text Bool
8661onlyJsonObjects
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 ())
62+ = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
63+ Nothing -> False
64+ Just (_ :: Object) -> True)
9465
9566-- | __Optional__
9667--
@@ -111,59 +82,29 @@ onlyJsonObjects
11182-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
11283--
11384-- /Since 0.0.0.0/
114−createContainsValidLocation :: RequestPredicate
85+createContainsValidLocation :: RequestPredicate Text Bool
11586createContainsValidLocation
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
87+ = RequestPredicate
88+ { reqPredName = "createContainsValidLocation"
89+ , reqResps = \req mgr -> do
16090 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 []
91+ if responseStatus resp == status201
92+ then case lookup "Location" $ responseHeaders resp of
93+ Nothing -> return (False, [resp])
94+ Just l -> case parseUrl $ SBSC.unpack l of
95+ Nothing -> return (False, [resp])
96+ Just x -> do
97+ resp2 <- httpLbs x mgr
98+ return (status2XX resp2, [resp, resp2])
99+ else return (True, [resp])
100+ }
165101
102+{-
103+getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
104+getsHaveLastModifiedHeader
105+ = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
166106
107+-}
167108
168109-- | [__RFC Compliance__]
169110--
@@ -175,27 +116,24 @@ getsHaveLastModifiedHeader
175116-- This function checks that every @405 Method Not Allowed@ response contains
176117-- an @Allow@ header with a list of standard HTTP methods.
177118--
178−-- Note that 'servant' itself does not currently set the @Allow@ headers.
179−--
180119-- __References__:
181120--
182121-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
183122-- * 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>
185123--
186124-- /Since 0.0.0.0/
187−notAllowedContainsAllowHeader :: RequestPredicate
125+notAllowedContainsAllowHeader :: RequestPredicate Text Bool
188126notAllowedContainsAllowHeader
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
127+ = RequestPredicate
128+ { reqPredName = "notAllowedContainsAllowHeader"
129+ , reqResps = \req mgr -> do
130+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
131+ | m <- [minBound .. maxBound ]
132+ , renderStdMethod m /= method req ]
133+ return (all pred' resp, resp)
134+ }
197135 where
198− pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
136+ pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
199137 where
200138 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
201139 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -216,19 +154,19 @@ notAllowedContainsAllowHeader
216154-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
217155--
218156-- /Since 0.0.0.0/
219−honoursAcceptHeader :: RequestPredicate
157+honoursAcceptHeader :: RequestPredicate Text Bool
220158honoursAcceptHeader
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−
159+ = RequestPredicate
160+ { reqPredName = "honoursAcceptHeader"
161+ , reqResps = \req mgr -> do
162+ resp <- httpLbs req mgr
163+ let scode = responseStatus resp
164+ sctype = lookup "Content-Type" $ responseHeaders resp
165+ sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
166+ if status100 < scode && scode < status300
167+ then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])
168+ else return (True, [resp])
169+ }
232170
233171-- | [__Best Practice__]
234172--
@@ -244,32 +182,34 @@ honoursAcceptHeader
244182-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
245183--
246184-- /Since 0.0.0.0/
247−getsHaveCacheControlHeader :: RequestPredicate
185+getsHaveCacheControlHeader :: RequestPredicate Text Bool
248186getsHaveCacheControlHeader
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 []
187+ = RequestPredicate
188+ { reqPredName = "getsHaveCacheControlHeader"
189+ , reqResps = \req mgr -> if method req == methodGet
190+ then do
191+ resp <- httpLbs req mgr
192+ let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
193+ return (good, [resp])
194+ else return (True, [])
195+ }
257196
258197-- | [__Best Practice__]
259198--
260199-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
261200--
262201-- /Since 0.0.0.0/
263−headsHaveCacheControlHeader :: RequestPredicate
202+headsHaveCacheControlHeader :: RequestPredicate Text Bool
264203headsHaveCacheControlHeader
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 []
204+ = RequestPredicate
205+ { reqPredName = "headsHaveCacheControlHeader"
206+ , reqResps = \req mgr -> if method req == methodHead
207+ then do
208+ resp <- httpLbs req mgr
209+ let good = hasValidHeader "Cache-Control" (const True) resp
210+ return (good, [resp])
211+ else return (True, [])
212+ }
273213{-
274214-- |
275215--
@@ -331,35 +271,12 @@ linkHeadersAreValid
331271-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
332272--
333273-- /Since 0.0.0.0/
334−unauthorizedContainsWWWAuthenticate :: ResponsePredicate
274+unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
335275unauthorizedContainsWWWAuthenticate
336− = ResponsePredicate $ \resp ->
276+ = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
337277 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 ()
278+ then hasValidHeader "WWW-Authenticate" (const True) resp
279+ else True)
363280
364281-- * Predicate logic
365282
@@ -372,56 +289,67 @@ htmlIncludesDoctype
372289-- | A predicate that depends only on the response.
373290--
374291-- /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 = (<>)
292+data ResponsePredicate n r = ResponsePredicate
293+ { respPredName :: n
294+ , respPred :: Response LBS.ByteString -> r
295+ } deriving (Functor, Generic)
296+
297+instance Bifunctor ResponsePredicate where
298+ first f (ResponsePredicate a b) = ResponsePredicate (f a) b
299+ second = fmap
300+
301+instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
302+ mempty = ResponsePredicate mempty mempty
303+ a `mappend` b = ResponsePredicate
304+ { respPredName = respPredName a <> respPredName b
305+ , respPred = respPred a <> respPred b
306+ }
385307
386308-- | A predicate that depends on both the request and the response.
387309--
388310-- /Since 0.0.0.0/
389−newtype RequestPredicate = RequestPredicate
390− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
391− } deriving (Generic)
311+data RequestPredicate n r = RequestPredicate
312+ { reqPredName :: n
313+ , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])
314+ } deriving (Generic, Functor)
392315
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 = (<>)
316+instance Bifunctor RequestPredicate where
317+ first f (RequestPredicate a b) = RequestPredicate (f a) b
318+ second = fmap
397319
398320-- 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)
321+instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
322+ mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
323+ a `mappend` b = RequestPredicate
324+ { reqPredName = reqPredName a <> reqPredName b
325+ , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
326+ }
402327
403328-- | A set of predicates. Construct one with 'mempty' and '<%>'.
404−data Predicates = Predicates
405− { requestPredicates :: RequestPredicate
406− , responsePredicates :: ResponsePredicate
407− } deriving (Generic)
329+data Predicates n r = Predicates
330+ { reqPreds :: RequestPredicate n r
331+ , respPreds :: ResponsePredicate n r
332+ } deriving (Generic, Functor)
408333
409−instance Semigroup Predicates where
410− a <> b = Predicates (requestPredicates a <> requestPredicates b)
411− (responsePredicates a <> responsePredicates b)
412−
413−instance Monoid Predicates where
334+instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
414335 mempty = Predicates mempty mempty
415− mappend = (<>)
336+ a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
337+
338+
416339
417340class JoinPreds a where
418− joinPreds :: a -> Predicates -> Predicates
341+ joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
342+
343+instance JoinPreds (RequestPredicate Text Bool) where
344+ joinPreds p (Predicates x y) = Predicates (go <> x) y
345+ where go = let p' = first return p
346+ in fmap (\z -> if z then [] else reqPredName p') p'
419347
420−instance JoinPreds (RequestPredicate ) where
421− joinPreds p (Predicates x y) = Predicates (p <> x) y
348+instance JoinPreds (ResponsePredicate Text Bool) where
349+ joinPreds p (Predicates x y) = Predicates x (go <> y)
350+ where go = let p' = first return p
351+ in fmap (\z -> if z then [] else respPredName p') p'
422352
423−instance JoinPreds (ResponsePredicate ) where
424− joinPreds p (Predicates x y) = Predicates x (p <> y)
425353
426354-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
427355-- the existing predicates.
@@ -429,17 +357,14 @@ instance JoinPreds (ResponsePredicate ) where
429357-- > not500 <%> onlyJsonObjects <%> empty
430358--
431359-- /Since 0.0.0.0/
432−(<%>) :: JoinPreds a => a -> Predicates -> Predicates
360+(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
433361(<%>) = joinPreds
434362infixr 6 <%>
435363
436−finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
437−finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
438− where
439− go = do
440− resps <- getRequestPredicate (requestPredicates p) req mgr
441− mapM_ (getResponsePredicate $ responsePredicates p) resps
442− return Nothing
364+finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
365+finishPredicates p req mgr = do
366+ (soFar, resps) <- reqResps (reqPreds p) req mgr
367+ return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
443368
444369-- * helpers
445370
@@ -448,14 +373,5 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
448373 Nothing -> False
449374 Just v -> p v
450375
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
376+status2XX :: Response b -> Bool
377+status2XX r = status200 <= responseStatus r && responseStatus r < status300