@@ -1,132 +1,149 @@
1−-- | This module contains all logic related to constructing or using
3−{-# LANGUAGE UndecidableInstances #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
7−import Data.Aeson (ToJSON (toJSON), Value (..))
3+import Data.Monoid ((<>))
8−import Data.Proxy (Proxy (..))
4+import GHC.Generics (Generic)
9−import Data.Void
5+import Control.Monad
10−import Network.HTTP.Types (statusCode)
6+import Network.HTTP.Client (Request, Response)
11−import Servant.Common.Req (ServantError (..))
12−import Test.QuickCheck
15−-- | An HList containing predicates (functions of type @a -> Bool@). This
9+-- | @500 Internal Server Error@ should be avoided - it may represent some
16−-- datatype is used to represent both filters (what values to discard when
10+-- issue with the application code, and it moreover gives the client little
17−-- generating arguments to test an API) and tests results (what to consider a
11+-- indication of how to proceed or what went wrong.
20−-- For both filters and test results, only the *first* predicate of the
21−-- appropriate type is used.
23−-- Use 'emptyPredicates', 'addPredicate', 'addLeftPredicate' and
24−-- 'addRightPredicate' to construct a @Predicates@.
25−data Predicates a where
26− HNil :: Predicates '[]
27− HCons :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
28− HConsC :: Constraint a -> Predicates b -> Predicates (Constraint a ': b)
30−class HasPredicate a b where
31− getPredicate :: Predicates a -> b -> Bool
33−instance {-# OVERLAPPING #-} HasPredicate '[] a where
34− getPredicate _ = const True
36−-- TODO: Find some better way of distinguishing how the predicate is being used
37−instance {-# OVERLAPPING #-} HasPredicate '[] (Either ServantError a) where
38− getPredicate _ = discard
40−instance {-# OVERLAPPING #-} HasPredicate (a ': xs) a where
41− getPredicate (HCons a _) = a
42− getPredicate (HConsC _ _) = error "not impossible, but non-sensical"
44−data Constraint ctx = Constraint
45− { getConstraint :: forall a . (ctx a) => a -> Bool }
47−-- This is a little bit of a hack. Ideally instances would match when the
48−-- predicate is polymorphic, but that doesn't work since the polymorphic type
49−-- may have to unify with multiple distict values.
51−-- It may however be possible to define a MPTC from monomorphic to polymorphic
52−-- datatypes to avoid this issue.
53−instance {-# OVERLAPPING #-}
54− HasPredicate (Either ServantError Void ': xs) (Either ServantError a) where
55− getPredicate (HCons f _) x = case x of
59−instance {-# OVERLAPPING #-} (ctx a)
60− => HasPredicate (Constraint ctx ': xs) (Either ServantError a) where
61− getPredicate (HConsC f _) x = case x of
62− Left _ -> discard -- Not clear whether checking for FailureResponse is better
63− Right v -> getConstraint f v
64− getPredicate (HCons _ _) _ = error "not impossible, but non-sensical"
66−instance {-# OVERLAPPABLE #-} (ls ~ (b ': xs), HasPredicate xs a)
67− => HasPredicate ls a where
68− getPredicate (HCons _ xs) = getPredicate xs
69− getPredicate _ = error "impossible"
71−-- | Add a predicate to a list of predicates. Note that the predicate may not
73−addPredicate :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
76−-- | Add a predicate with a class constraint.
78−-- Note that every possible argument must be an instance of that class for this
79−-- to typecheck. In other words, if the @Predicates@ is being used for return
80−-- types, every return type in the API must be an instance of the class. If
81−-- it's being used for filtering, every capture, header, body, etc. type must
82−-- be an instance of that class.
84−-- This can be used to for example test that returned JSON has certain
85−-- properties, or (via generics) that if any datatype contains a (possibly
86−-- nested) field of a particular type, it always meets certain properties.
87−addPolyPredicate :: proxy ctx -> (forall a. ctx a => a -> Bool) -> Predicates b
88− -> Predicates (Constraint ctx ': b)
89−addPolyPredicate _ p = HConsC (Constraint p)
91−-- | Given a predicate over an @p :: a -> Bool@, add a predicate to the @Predicates@
92−-- list that succeeds on an @val :: Either ServantError a@ if @val@ is a
93−-- @Left@, or a @Right v@ such that @p a == True@.
94−addRightPredicate :: (a -> Bool) -> Predicates b -> Predicates (Either ServantError a ': b)
95−addRightPredicate p = addPredicate $ either (const True) p
97−-- | The @Left@ analog of 'addRightPredicate'.
98−addLeftPredicate :: (ServantError -> Bool) -> Predicates b
99− -> Predicates (Either ServantError Void ': b)
100−addLeftPredicate p = addPredicate $ either p (error "impossible")
102−-- | An empty list of predicates. This doesn't discard any values when used as
103−-- a filter, and doesn't fail any value when used as a condition to satisfy.
104−emptyPredicates :: Predicates '[]
105−emptyPredicates = HNil
107−-- * Useful predicates
109−-- | A @Predicates@ list that fails a test if the response is an HTTP 500 error.
110−never500s :: Predicates '[Either ServantError Void]
111−never500s = addLeftPredicate go emptyPredicates
113− go (FailureResponse x _ _) = statusCode x /= 500
116−-- | A @Predicates@ list that fails a test if the response is anything but a
117−-- top-level object (e.g., if it is an array or literal).
13+-- This function checks that the response code is not 500.
14+not500 :: Response b -> IO Bool
16+ = ResponsePredicate "not500" _
119−-- Returning anything other than object is considered bad practice, as
18+-- | Returning anything other than an object when returning JSON is considered
121-- (1) it is hard to modify the returned value while maintaining backwards
21-- (1) it is hard to modify the returned value while maintaining backwards
122−-- compatibility;
22+-- compatibility
123−-- (2) many older tools do not support top-level arrays;
23+-- (2) many older tools do not support top-level arrays
124-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
24-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
125−-- on what RFC you're going by;
25+-- on what RFC you're going by
126−-- (4) there are security issues with top-level arrays.
26+-- (4) there are security issues with top-level arrays
28+-- This function checks that any @application/json@ responses only return JSON
29+-- objects (and not arrays, strings, numbers, or booleans) at the top level.
127−onlyJsonObjects :: Predicates '[Constraint ToJSON]
30+onlyJsonObjects :: Response b -> IO Bool
128−onlyJsonObjects = addPolyPredicate (Proxy :: Proxy ToJSON) go emptyPredicates
31+onlyJsonObjects
129− where
32+ = ResponsePredicate "onlyJsonObjects" _
130− go x = case toJSON x of
33+
131− Object _ -> True
34+-- | When creating a new resource, it is good practice to provide a @Location@
132− _ -> False
35+-- header with a link to the created resource.
37+-- This function checks that every @201 Created@ response contains a @Location@
38+-- header, and that the link in it responds with a 2XX response code to @GET@
41+-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
42+createContainsValidLocation :: Response b -> IO Bool
43+createContainsValidLocation
44+ = ResponsePredicate "createContainsValidLocation" _
46+getsHaveLastModifiedHeader :: Response b -> IO Bool
47+getsHaveLastModifiedHeader
48+ = ResponsePredicate "getsHaveLastModifiedHeader" _
50+-- | When an HTTP request has a method that is not allowed, a 405 response
51+-- should be returned. Additionally, it is good practice to return an @Allow@
52+-- header with the list of allowed methods.
54+-- This function checks that every @405 Method Not Allowed@ response contains
55+-- an @Allow@ header with a list of standard HTTP methods.
56+notAllowedContainsAllowHeader :: Response b -> IO Bool
57+notAllowedContainsAllowHeader
58+ = ResponsePredicate "notAllowedContainsAllowHeader" _
60+-- | When a request contains an @Accept@ header, the server must either return
61+-- content in one of the requested representations, or respond with @406 Not
64+-- This function checks that every *successful* response has a @Content-Type@
65+-- header that matches the @Accept@ header.
66+honoursAcceptHeader :: Predicate b Bool
68+ = RequestPredicate "honoursAcceptHeader" _
70+-- | Whether or not a representation should be cached, it is good practice to
71+-- have a @Cache-Control@ header for @GET@ requests. If the representation
72+-- should not be cached, used @Cache-Control: no-cache@.
74+-- This function checks that @GET@ responses have a valid @Cache-Control@
77+-- References: RFC 7234 Section 5.2
78+-- https://tools.ietf.org/html/rfc7234#section-5.2
79+getsHaveCacheControlHeader :: Predicate b Bool
80+getsHaveCacheControlHeader
81+ = ResponsePredicate "getsHaveCacheControlHeader" _
83+-- | Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
84+headsHaveCacheControlHeader :: Predicate b Bool
85+headsHaveCacheControlHeader
86+ = ResponsePredicate "headsHaveCacheControlHeader" _
90+-- If the original request modifies the resource, this function makes two
93+-- (1) Once, with the original request and a future date as the
94+-- @If-Unmodified-Since@, which is expected to succeed.
95+-- (2) Then with the original request again, with a @If-Unmodified-Since@
96+-- safely in the past. Since presumably the representation has been changed
97+-- recently (by the first request), this is expected to fail with @412
98+-- Precondition Failure@.
100+-- Note that the heuristic used to guess whether the original request modifies
101+-- a resource is simply whether the method is @PUT@ or @PATCH@, which may be
102+-- incorrect in certain circumstances.
103+supportsIfUnmodifiedSince :: Predicate b Bool
104+supportsIfUnmodifiedSince
105+ = ResponsePredicate "supportsIfUnmodifiedSince" _
107+-- | @OPTIONS@ responses should contain an @Allow@ header with the list of
110+-- If a request is an @OPTIONS@ request, and if the response is a successful
111+-- one, this function checks the response for an @Allow@ header. It fails if:
113+-- (1) There is no @Allow@ header
114+-- (2) The @Allow@ header does not have standard HTTP methods in the correct
116+-- (3) Making a request to the same URL with one of those methods results in
118+optionsContainsValidAllow :: Predicate b Bool
119+optionsContainsValidAllow
120+ = ResponsePredicate "optionsContainsValidAllow" _
122+-- | Link headers are a standardized way of presenting links that may be
123+-- relevant to a client.
125+-- This function checks that any @Link@ headers have values in the correct
128+-- References: RFC 5988 Section 5
129+-- https://tools.ietf.org/html/rfc5988
130+linkHeadersAreValid :: Predicate b Bool
132+ = ResponsePredicate "linkHeadersAreValid" _
134+-- | Any @401 Unauthorized@ response must include a @WWW-Authenticate@ header.
136+-- This function checks that, if a response has status code 401, it contains a
137+-- @WWW-Authenticate@ header.
139+-- References: RFC 7235 Section 4.1
140+-- https://tools.ietf.org/html/rfc7235#section-4.1
141+unauthorizedContainsWWWAuthenticate :: Predicate b Bool
142+unauthorizedContainsWWWAuthenticate
143+ = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _
147+ = ResponsePredicate String (Response b -> IO r)
148+ | RequestPredicate String (Request -> [Response b -> IO r] -> IO r)