@@ -1,36 +1,27 @@
1module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
3−import Control.Exception (catch, throw)
3+import Control.Monad
4−import Control.Monad (liftM2, unless, when)
5import Data.Aeson (Object, decode)
4import Data.Aeson (Object, decode)
6−import Data.Bifunctor (first)
5+import Data.Bifunctor (Bifunctor (..))
7import qualified Data.ByteString as SBS
6import qualified Data.ByteString as SBS
8import qualified Data.ByteString.Char8 as SBSC
7import qualified Data.ByteString.Char8 as SBSC
9import qualified Data.ByteString.Lazy as LBS
8import qualified Data.ByteString.Lazy as LBS
10−import Data.CaseInsensitive (foldCase, foldedCase, mk)
9+import Data.CaseInsensitive (mk)
11import Data.Either (isRight)
10import Data.Either (isRight)
12import Data.List.Split (wordsBy)
11import Data.List.Split (wordsBy)
13−import Data.Maybe (fromMaybe, isJust)
12+import Data.Maybe (fromMaybe, isJust, maybeToList)
14−import Data.Semigroup (Semigroup (..))
13+import Data.Monoid ((<>))
15−import qualified Data.Text as T
14+import Data.Text (Text)
16−import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
18import GHC.Generics (Generic)
15import GHC.Generics (Generic)
19import Network.HTTP.Client (Manager, Request, Response, httpLbs,
16import Network.HTTP.Client (Manager, Request, Response, httpLbs,
20− method, parseRequest, requestHeaders,
17+ method, parseUrl, requestHeaders,
21 responseBody, responseHeaders,
18 responseBody, responseHeaders,
22 responseStatus)
19 responseStatus)
23import Network.HTTP.Media (matchAccept)
20import Network.HTTP.Media (matchAccept)
24import Network.HTTP.Types (methodGet, methodHead, parseMethod,
21import Network.HTTP.Types (methodGet, methodHead, parseMethod,
25− renderStdMethod, status100, status200,
22+ renderStdMethod, status200, status201,
26− status201, status300, status401,
23+ status300, status401, status405,
27− status405, status500)
24+ status500)
29−import System.Clock (Clock (Monotonic), diffTimeSpec,
32−import Servant.QuickCheck.Internal.ErrorTypes
35-- | [__Best Practice__]
26-- | [__Best Practice__]
@@ -39,27 +30,8 @@ import Servant.QuickCheck.Internal.ErrorTypes
39-- indication of how to proceed or what went wrong.
30-- indication of how to proceed or what went wrong.
41-- This function checks that the response code is not 500.
32-- This function checks that the response code is not 500.
44−not500 :: ResponsePredicate
33+not500 :: ResponsePredicate Text Bool
45−not500 = ResponsePredicate $ \resp ->
34+not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
46− when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
50−-- This function checks that the response from the server does not take longer
51−-- than the specified number of nanoseconds.
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
64-- | [__Best Practice__]
36-- | [__Best Practice__]
@@ -80,17 +52,11 @@ notLongerThan maxAllowed
81-- * JSON Grammar: <https://tools.ietf.org/html/rfc7159#section-2 RFC 7159 Section 2>
53-- * 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>
54-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
85−onlyJsonObjects :: ResponsePredicate
55+onlyJsonObjects :: ResponsePredicate Text Bool
86onlyJsonObjects
56onlyJsonObjects
87− = ResponsePredicate (\resp -> do
88− case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
90− Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do
91− case (decode (responseBody resp) :: Maybe Object) of
57+ = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
92− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
58+ Nothing -> False
93− Just _ -> return ())
59+ Just (_ :: Object) -> True)
95-- | __Optional__
61-- | __Optional__
@@ -109,61 +75,29 @@ onlyJsonObjects
110-- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>
76-- * 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>
77-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
114−createContainsValidLocation :: RequestPredicate
78+createContainsValidLocation :: RequestPredicate Text Bool
115createContainsValidLocation
79createContainsValidLocation
116− = RequestPredicate $ \req mgr -> do
80+ = RequestPredicate
117− let n = "createContainsValidLocation"
81+ { reqPredName = "createContainsValidLocation"
118− resp <- httpLbs req mgr
82+ , reqResps = \req mgr -> do
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
125− resp2 <- httpLbs x mgr
126− status2XX (Just req) resp2 n
127− return [resp, resp2]
132−-- The @Last-Modified@ header represents the time a resource was last
133−-- modified. It is used to drive caching and conditional requests.
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.
141−-- The @Last-Modified@ header can also be used in conjunction with the
142−-- @If-Unmodified-Since@ header to drive optimistic concurrency.
144−-- The @Last-Modified@ date must be in RFC 822 format.
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>
155−getsHaveLastModifiedHeader :: RequestPredicate
156−getsHaveLastModifiedHeader
157− = RequestPredicate $ \req mgr ->
158− if (method req == methodGet)
160 resp <- httpLbs req mgr
83 resp <- httpLbs req mgr
161− unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
84+ if responseStatus resp == status201
162− throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
85+ then case lookup "Location" $ responseHeaders resp of
163− return [resp]
86+ Nothing -> return (False, [resp])
87+ Just l -> case parseUrl $ SBSC.unpack l of
88+ Nothing -> return (False, [resp])
90+ resp2 <- httpLbs x mgr
91+ return (status2XX resp2, [resp, resp2])
164− else return []
92+ else return (True, [resp])
96+getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
97+getsHaveLastModifiedHeader
98+ = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
168-- | [__RFC Compliance__]
102-- | [__RFC Compliance__]
@@ -175,32 +109,26 @@ getsHaveLastModifiedHeader
175-- This function checks that every @405 Method Not Allowed@ response contains
109-- This function checks that every @405 Method Not Allowed@ response contains
176-- an @Allow@ header with a list of standard HTTP methods.
110-- an @Allow@ header with a list of standard HTTP methods.
178−-- Note that 'servant' itself does not currently set the @Allow@ headers.
180-- __References__:
112-- __References__:
182-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
114-- * @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>
115-- * 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>
187−notAllowedContainsAllowHeader :: RequestPredicate
116+notAllowedContainsAllowHeader :: RequestPredicate Text Bool
188notAllowedContainsAllowHeader
117notAllowedContainsAllowHeader
189− = RequestPredicate $ \req mgr -> do
118+ = RequestPredicate
119+ { reqPredName = "notAllowedContainsAllowHeader"
120+ , reqResps = \req mgr -> do
190− let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
121+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
122+ | m <- [minBound .. maxBound ]
191− , renderStdMethod m /= method req ]
123+ , renderStdMethod m /= method req ]
192− resp <- mapM (flip httpLbs mgr) reqs
124+ return (all pred' resp, resp)
194− case filter pred' (zip reqs resp) of
195− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
198− pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
127+ pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
129 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
130 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
204-- | [__RFC Compliance__]
132-- | [__RFC Compliance__]
206-- When a request contains an @Accept@ header, the server must either return
134-- When a request contains an @Accept@ header, the server must either return
@@ -208,27 +136,24 @@ notAllowedContainsAllowHeader
208-- Acceptable@.
136-- Acceptable@.
210-- This function checks that every *successful* response has a @Content-Type@
138-- 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
139+-- header that matches the @Accept@ header.
212−-- matches the quality descriptions of the @Accept@ header correctly.
214-- __References__:
141-- __References__:
216-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
143-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
219−honoursAcceptHeader :: RequestPredicate
144+honoursAcceptHeader :: RequestPredicate b Bool
220honoursAcceptHeader
145honoursAcceptHeader
221− = RequestPredicate $ \req mgr -> do
146+ = RequestPredicate
147+ { reqPredName = "honoursAcceptHeader"
148+ , reqResps = \req mgr -> do
222− resp <- httpLbs req mgr
149+ resp <- httpLbs req mgr
223− let scode = responseStatus resp
150+ let scode = responseStatus resp
224− sctype = lookup "Content-Type" $ responseHeaders resp
151+ sctype = lookup "Content-Type" $ responseHeaders resp
225− sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
152+ sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
226− if status100 < scode && scode < status300
153+ if 100 < scode && scode < 300
227− then if isJust $ sctype >>= \x -> matchAccept [x] sacc
154+ then return (isJust $ sctype >>= \x -> matchAccept x sacc, [resp])
228− then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
230− else return [resp]
155+ else return (True, [resp])
233-- | [__Best Practice__]
158-- | [__Best Practice__]
@@ -242,34 +167,32 @@ honoursAcceptHeader
242-- __References__:
167-- __References__:
244-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
169-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
247−getsHaveCacheControlHeader :: RequestPredicate
170+getsHaveCacheControlHeader :: RequestPredicate Text Bool
248getsHaveCacheControlHeader
171getsHaveCacheControlHeader
249− = RequestPredicate $ \req mgr ->
172+ = RequestPredicate
173+ { reqPredName = "getsHaveCacheControlHeader"
250− if (method req == methodGet)
174+ , reqResps = \req mgr -> if method req == methodGet
252− resp <- httpLbs req mgr
176+ resp <- httpLbs req mgr
253− unless (hasValidHeader "Cache-Control" (const True) resp) $ do
177+ let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
254− throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
178+ return (good, [resp])
256− else return []
179+ else return (True, [])
258-- | [__Best Practice__]
182-- | [__Best Practice__]
260-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
184-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
263−headsHaveCacheControlHeader :: RequestPredicate
185+headsHaveCacheControlHeader :: RequestPredicate Text Bool
264headsHaveCacheControlHeader
186headsHaveCacheControlHeader
265− = RequestPredicate $ \req mgr ->
187+ = RequestPredicate
188+ { reqPredName = "headsHaveCacheControlHeader"
266− if (method req == methodHead)
189+ , reqResps = \req mgr -> if method req == methodHead
268− resp <- httpLbs req mgr
191+ resp <- httpLbs req mgr
269− unless (hasValidHeader "Cache-Control" (const True) resp) $
192+ let good = hasValidHeader "Cache-Control" (const True) resp
270− throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
193+ return (good, [resp])
272− else return []
194+ else return (True, [])
@@ -329,37 +252,12 @@ linkHeadersAreValid
329-- __References__:
252-- __References__:
331-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
254-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
334−unauthorizedContainsWWWAuthenticate :: ResponsePredicate
255+unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
335unauthorizedContainsWWWAuthenticate
256unauthorizedContainsWWWAuthenticate
336− = ResponsePredicate $ \resp ->
257+ = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
337 if responseStatus resp == status401
258 if responseStatus resp == status401
338− then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
259+ then hasValidHeader "WWW-Authenticate" (const True) resp
339− throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
340− else return ()
260+ else True)
343−-- | [__RFC Compliance__]
345−-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
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`.
352−-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
354−htmlIncludesDoctype :: ResponsePredicate
356− = ResponsePredicate $ \resp ->
357− if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
359− let htmlContent = foldCase . LBS.take 20 $ responseBody resp
360− unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
361− throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
364-- * Predicate logic
262-- * Predicate logic
@@ -369,77 +267,76 @@ htmlIncludesDoctype
370-- Still, this is all kind of ugly.
268-- Still, this is all kind of ugly.
372−-- | A predicate that depends only on the response.
375−newtype ResponsePredicate = ResponsePredicate
270+data ResponsePredicate n r = ResponsePredicate
376− { getResponsePredicate :: Response LBS.ByteString -> IO ()
272+ , respPred :: Response LBS.ByteString -> r
377− } deriving (Generic)
273+ } deriving (Functor, Generic)
379−instance Semigroup ResponsePredicate where
275+instance Bifunctor ResponsePredicate where
380− ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
276+ first f (ResponsePredicate a b) = ResponsePredicate (f a) b
382−instance Monoid ResponsePredicate where
279+instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
383− mempty = ResponsePredicate $ const $ return ()
280+ mempty = ResponsePredicate mempty mempty
384− mappend = (<>)
281+ a `mappend` b = ResponsePredicate
282+ { respPredName = respPredName a <> respPredName b
283+ , respPred = respPred a <> respPred b
386−-- | A predicate that depends on both the request and the response.
389−newtype RequestPredicate = RequestPredicate
286+data RequestPredicate n r = RequestPredicate
390− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
288+ , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])
391− } deriving (Generic)
289+ } deriving (Generic, Functor)
393−-- TODO: This isn't actually a monoid
394−instance Monoid RequestPredicate where
291+instance Bifunctor RequestPredicate where
395− mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
292+ first f (RequestPredicate a b) = RequestPredicate (f a) b
396− mappend = (<>)
293+ second = fmap
398-- TODO: This isn't actually a monoid
295-- TODO: This isn't actually a monoid
399−instance Semigroup RequestPredicate where
296+instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
297+ mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
400− RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
298+ a `mappend` b = RequestPredicate
401− liftM2 (<>) (a r mgr) (b r mgr)
299+ { reqPredName = reqPredName a <> reqPredName b
402−
300+ , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
403−-- | A set of predicates. Construct one with 'mempty' and '<%>'.
301+ }
404−data Predicates = Predicates
303+data Predicates n r = Predicates
405− { requestPredicates :: RequestPredicate
304+ { reqPreds :: RequestPredicate n r
406− , responsePredicates :: ResponsePredicate
305+ , respPreds :: ResponsePredicate n r
407− } deriving (Generic)
306+ } deriving (Generic, Functor)
308+instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
309+ mempty = Predicates mempty mempty
310+ a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
409−instance Semigroup Predicates where
410− a <> b = Predicates (requestPredicates a <> requestPredicates b)
411− (responsePredicates a <> responsePredicates b)
413−instance Monoid Predicates where
414− mempty = Predicates mempty mempty
417class JoinPreds a where
314class JoinPreds a where
418− joinPreds :: a -> Predicates -> Predicates
315+ joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
420−instance JoinPreds (RequestPredicate ) where
317+instance JoinPreds (RequestPredicate Text Bool) where
421− joinPreds p (Predicates x y) = Predicates (p <> x) y
318+ joinPreds p (Predicates x y) = Predicates (go <> x) y
319+ where go = let p' = first return p
320+ in fmap (\z -> if z then [] else reqPredName p') p'
322+instance JoinPreds (ResponsePredicate Text Bool) where
323+ joinPreds p (Predicates x y) = Predicates x (go <> y)
324+ where go = let p' = first return p
325+ in fmap (\z -> if z then [] else respPredName p') p'
423−instance JoinPreds (ResponsePredicate ) where
424− joinPreds p (Predicates x y) = Predicates x (p <> y)
426-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
328-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
427-- the existing predicates.
329-- the existing predicates.
429-- > not500 <%> onlyJsonObjects <%> empty
331-- > not500 <%> onlyJsonObjects <%> empty
432−(<%>) :: JoinPreds a => a -> Predicates -> Predicates
332+(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
433(<%>) = joinPreds
333(<%>) = joinPreds
434infixr 6 <%>
334infixr 6 <%>
436−finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
336+finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
437−finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
337+finishPredicates p req mgr = do
438− where
338+ (soFar, resps) <- reqResps (reqPreds p) req mgr
439− go = do
339+ return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
440− resps <- getRequestPredicate (requestPredicates p) req mgr
441− mapM_ (getResponsePredicate $ responsePredicates p) resps
444-- * helpers
341-- * helpers
@@ -448,14 +345,5 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
448 Nothing -> False
345 Nothing -> False
449 Just v -> p v
346 Just v -> p v
451−isRFC822Date :: SBS.ByteString -> Bool
348+status2XX :: Response b -> Bool
453− = case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of
455− Just (_ :: UTCTime) -> True
457−status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
458−status2XX mreq resp t
459− | status200 <= responseStatus resp && responseStatus resp < status300
349+status2XX r = status200 <= responseStatus r && responseStatus r < status300
461− | otherwise = throw $ PredicateFailure t mreq resp