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