@@ -1,69 +1,22 @@
1module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
3−import Control.Exception (catch, throw)
3+import Data.Monoid ((<>))
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,
18−import GHC.Generics (Generic)
4+import GHC.Generics (Generic)
19−import Network.HTTP.Client (Manager, Request, Response, httpLbs,
6+import Network.HTTP.Client (Request, Response, responseStatus)
20− method, parseRequest, requestHeaders,
7+import Network.HTTP.Types (status500)
21− responseBody, responseHeaders,
8+import Data.Text (Text)
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)
29−import System.Clock (Clock (Monotonic), diffTimeSpec,
32−import Servant.QuickCheck.Internal.ErrorTypes
35−-- | [__Best Practice__]
37−-- @500 Internal Server Error@ should be avoided - it may represent some
10+-- | @500 Internal Server Error@ should be avoided - it may represent some
38-- issue with the application code, and it moreover gives the client little
11-- issue with the application code, and it moreover gives the client little
39-- indication of how to proceed or what went wrong.
12-- indication of how to proceed or what went wrong.
41-- This function checks that the response code is not 500.
14-- This function checks that the response code is not 500.
44−not500 :: ResponsePredicate
15+not500 :: ResponsePredicate Text b Bool
45−not500 = ResponsePredicate $ \resp ->
16+not500 = ResponsePredicate "not500" (\resp -> responseStatus resp == status500)
46− when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
48−-- | [__Optional__]
18+{-
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__]
66−-- Returning anything other than an object when returning JSON is considered
19+-- | Returning anything other than an object when returning JSON is considered
67-- bad practice, as:
20-- bad practice, as:
69-- (1) it is hard to modify the returned value while maintaining backwards
22-- (1) it is hard to modify the returned value while maintaining backwards
@@ -75,202 +28,64 @@ notLongerThan maxAllowed
76-- This function checks that any @application/json@ responses only return JSON
29-- This function checks that any @application/json@ responses only return JSON
77-- objects (and not arrays, strings, numbers, or booleans) at the top level.
30-- objects (and not arrays, strings, numbers, or booleans) at the top level.
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>
85−onlyJsonObjects :: ResponsePredicate
31+onlyJsonObjects :: Response b -> IO Bool
86onlyJsonObjects
32onlyJsonObjects
87− = ResponsePredicate (\resp -> do
33+ = ResponsePredicate "onlyJsonObjects" _
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
92− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
97−-- When creating a new resource, it is good practice to provide a @Location@
35+-- | When creating a new resource, it is good practice to provide a @Location@
98-- header with a link to the created resource.
36-- header with a link to the created resource.
100-- This function checks that every @201 Created@ response contains a @Location@
38-- 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@
39-- header, and that the link in it responds with a 2XX response code to @GET@
102-- requests.
40-- requests.
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.
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>
42+-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
114−createContainsValidLocation :: RequestPredicate
43+createContainsValidLocation :: Response b -> IO Bool
115createContainsValidLocation
44createContainsValidLocation
116− = RequestPredicate $ \req mgr -> do
117− let n = "createContainsValidLocation"
45+ = ResponsePredicate "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
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
47+getsHaveLastModifiedHeader :: Response b -> IO Bool
156getsHaveLastModifiedHeader
48getsHaveLastModifiedHeader
157− = RequestPredicate $ \req mgr ->
158− if (method req == methodGet)
160− resp <- httpLbs req mgr
161− unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
162− throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
49+ = ResponsePredicate "getsHaveLastModifiedHeader" _
168−-- | [__RFC Compliance__]
170−-- When an HTTP request has a method that is not allowed,
51+-- | When an HTTP request has a method that is not allowed, a 405 response
171−-- a 405 response should be returned. Additionally, it is good practice to
52+-- should be returned. Additionally, it is good practice to return an @Allow@
173-- header with the list of allowed methods.
53-- header with the list of allowed methods.
175-- This function checks that every @405 Method Not Allowed@ response contains
55-- This function checks that every @405 Method Not Allowed@ response contains
176-- an @Allow@ header with a list of standard HTTP methods.
56-- an @Allow@ header with a list of standard HTTP methods.
178−-- Note that 'servant' itself does not currently set the @Allow@ headers.
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>
187−notAllowedContainsAllowHeader :: RequestPredicate
57+notAllowedContainsAllowHeader :: Response b -> IO Bool
188notAllowedContainsAllowHeader
58notAllowedContainsAllowHeader
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
194− case filter pred' (zip reqs resp) of
195− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
59+ = ResponsePredicate "notAllowedContainsAllowHeader" _
198− pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
200− go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
201− $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
204−-- | [__RFC Compliance__]
206−-- When a request contains an @Accept@ header, the server must either return
61+-- | 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
62-- content in one of the requested representations, or respond with @406 Not
208-- Acceptable@.
63-- Acceptable@.
210-- This function checks that every *successful* response has a @Content-Type@
65-- 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
66+-- header that matches the @Accept@ header.
212−-- matches the quality descriptions of the @Accept@ header correctly.
216−-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
219−honoursAcceptHeader :: RequestPredicate
67+honoursAcceptHeader :: Predicate b Bool
220honoursAcceptHeader
68honoursAcceptHeader
221− = RequestPredicate $ \req mgr -> do
69+ = RequestPredicate "honoursAcceptHeader" _
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
233−-- | [__Best Practice__]
235−-- Whether or not a representation should be cached, it is good practice to
71+-- | 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
72-- have a @Cache-Control@ header for @GET@ requests. If the representation
237-- should not be cached, used @Cache-Control: no-cache@.
73-- should not be cached, used @Cache-Control: no-cache@.
239−-- This function checks that @GET@ responses have @Cache-Control@ header.
75+-- This function checks that @GET@ responses have a valid @Cache-Control@
240−-- It does NOT currently check that the header is valid.
76+-- header.
244−-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
246−-- /Since 0.0.0.0/
78+-- References: RFC 7234 Section 5.2
79+-- https://tools.ietf.org/html/rfc7234#section-5.2
247−getsHaveCacheControlHeader :: RequestPredicate
80+getsHaveCacheControlHeader :: Predicate b Bool
248getsHaveCacheControlHeader
81getsHaveCacheControlHeader
249− = RequestPredicate $ \req mgr ->
250− if (method req == methodGet)
252− resp <- httpLbs req mgr
253− unless (hasValidHeader "Cache-Control" (const True) resp) $ do
254− throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
82+ = ResponsePredicate "getsHaveCacheControlHeader" _
258−-- | [__Best Practice__]
260−-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
84+-- | Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
263−headsHaveCacheControlHeader :: RequestPredicate
85+headsHaveCacheControlHeader :: Predicate b Bool
264headsHaveCacheControlHeader
86headsHaveCacheControlHeader
265− = RequestPredicate $ \req mgr ->
266− if (method req == methodHead)
268− resp <- httpLbs req mgr
269− unless (hasValidHeader "Cache-Control" (const True) resp) $
270− throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
87+ = ResponsePredicate "headsHaveCacheControlHeader" _
276-- If the original request modifies the resource, this function makes two
91-- If the original request modifies the resource, this function makes two
@@ -311,151 +126,69 @@ optionsContainsValidAllow
311-- This function checks that any @Link@ headers have values in the correct
126-- This function checks that any @Link@ headers have values in the correct
312-- format.
127-- format.
314−-- __References__:
129+-- References: RFC 5988 Section 5
316−-- * <https://tools.ietf.org/html/rfc5988 RFC 5988 Section 5>
130+-- https://tools.ietf.org/html/rfc5988
317linkHeadersAreValid :: Predicate b Bool
131linkHeadersAreValid :: Predicate b Bool
318linkHeadersAreValid
132linkHeadersAreValid
319 = ResponsePredicate "linkHeadersAreValid" _
133 = ResponsePredicate "linkHeadersAreValid" _
322−-- | [__RFC Compliance__]
324−-- Any @401 Unauthorized@ response must include a @WWW-Authenticate@ header.
135+-- | Any @401 Unauthorized@ response must include a @WWW-Authenticate@ header.
326-- This function checks that, if a response has status code 401, it contains a
137-- This function checks that, if a response has status code 401, it contains a
327-- @WWW-Authenticate@ header.
138-- @WWW-Authenticate@ header.
329−-- __References__:
140+-- References: RFC 7235 Section 4.1
331−-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
141+-- https://tools.ietf.org/html/rfc7235#section-4.1
334−unauthorizedContainsWWWAuthenticate :: ResponsePredicate
142+unauthorizedContainsWWWAuthenticate :: Predicate b Bool
335unauthorizedContainsWWWAuthenticate
143unauthorizedContainsWWWAuthenticate
336− = ResponsePredicate $ \resp ->
337− if responseStatus resp == status401
338− then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339− throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
144+ = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _
340− else return ()
145+-}
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
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.
370−-- Still, this is all kind of ugly.
372−-- | A predicate that depends only on the response.
375−newtype ResponsePredicate = ResponsePredicate
376− { getResponsePredicate :: Response LBS.ByteString -> IO ()
377− } deriving (Generic)
379−instance Semigroup ResponsePredicate where
380− ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
382−instance Monoid ResponsePredicate where
383− mempty = ResponsePredicate $ const $ return ()
386−-- | A predicate that depends on both the request and the response.
147+data ResponsePredicate n b r = ResponsePredicate
387−--
148+ { respPredName :: n
388−-- /Since 0.0.0.0/
149+ , respPred :: Response b -> r
150+ } deriving (Functor, Generic)
152+instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n b r) where
153+ mempty = ResponsePredicate mempty mempty
154+ a `mappend` b = ResponsePredicate
155+ { respPredName = respPredName a <> respPredName b
156+ , respPred = respPred a <> respPred b
389−newtype RequestPredicate = RequestPredicate
159+data RequestPredicate n b r = RequestPredicate
390− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
160+ { reqPredName :: n
161+ , reqPred :: Request -> ResponsePredicate n b r -> IO r
391 } deriving (Generic)
162 } deriving (Generic)
393−-- TODO: This isn't actually a monoid
394−instance Monoid RequestPredicate where
164+instance (Monoid n, Monoid r) => Monoid (RequestPredicate n b r) where
395− mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
165+ mempty = RequestPredicate mempty (\_ _ -> return mempty)
396− mappend = (<>)
166+ a `mappend` b = RequestPredicate
397−
167+ { reqPredName = reqPredName a <> reqPredName b
398−-- TODO: This isn't actually a monoid
168+ , reqPred = \x y -> liftM2 (<>) (reqPred a x y) (reqPred b x y)
399−instance Semigroup RequestPredicate where
169+ }
400− RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
401− liftM2 (<>) (a r mgr) (b r mgr)
403−-- | A set of predicates. Construct one with 'mempty' and '<%>'.
404−data Predicates = Predicates
171+data Predicates n b r = Predicates
405− { requestPredicates :: RequestPredicate
172+ { reqPreds :: RequestPredicate n b r
406− , responsePredicates :: ResponsePredicate
173+ , respPreds :: ResponsePredicate n b r
407 } deriving (Generic)
174 } deriving (Generic)
409−instance Semigroup Predicates where
176+instance (Monoid n, Monoid r) => Monoid (Predicates n b r) where
410− a <> b = Predicates (requestPredicates a <> requestPredicates b)
411− (responsePredicates a <> responsePredicates b)
413−instance Monoid Predicates where
414 mempty = Predicates mempty mempty
177 mempty = Predicates mempty mempty
415− mappend = (<>)
178+ a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
417−class JoinPreds a where
180+class JoinPreds a n b r where
418− joinPreds :: a -> Predicates -> Predicates
181+ joinPreds :: a -> Predicates n b r -> Predicates n b r
420−instance JoinPreds (RequestPredicate ) where
183+instance (Monoid n, Monoid r) => JoinPreds (RequestPredicate n b r) n b r where
421 joinPreds p (Predicates x y) = Predicates (p <> x) y
184 joinPreds p (Predicates x y) = Predicates (p <> x) y
423−instance JoinPreds (ResponsePredicate ) where
186+instance (Monoid n, Monoid r) => JoinPreds (ResponsePredicate n b r) n b r where
424 joinPreds p (Predicates x y) = Predicates x (p <> y)
187 joinPreds p (Predicates x y) = Predicates x (p <> y)
426−-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
427−-- the existing predicates.
429−-- > not500 <%> onlyJsonObjects <%> empty
432−(<%>) :: JoinPreds a => a -> Predicates -> Predicates
434infixr 6 <%>
189infixr 6 <%>
190+(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r
436−finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
193+finishPredicates :: (Monoid r) => Predicates n b r -> Request -> IO r
437−finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
194+finishPredicates p req = (reqPred $ reqPreds p) req (respPreds p)
440− resps <- getRequestPredicate (requestPredicates p) req mgr
441− mapM_ (getResponsePredicate $ responsePredicates p) resps
446−hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool
447−hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
451−isRFC822Date :: SBS.ByteString -> 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
461− | otherwise = throw $ PredicateFailure t mreq resp