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