git.iko.soy/servant-quickcheck
on b3a7b64 help sign in
servant-quickcheck/src/Servant/QuickCheck/Internal/Predicates.hs
328 lines 12 kB history raw
1{-# LANGUAGE MultiWayIf #-}
2module Servant.QuickCheck.Internal.Predicates where
4import Control.Monad
5import Data.Aeson (Object, decode)
6import Data.Bifunctor (Bifunctor (..))
7import qualified Data.ByteString as SBS
8import qualified Data.ByteString.Char8 as SBSC
9import qualified Data.ByteString.Lazy as LBS
10import Data.CaseInsensitive (mk)
11import Data.Either (isRight)
12import Data.List.Split (wordsBy)
13import Data.Maybe (isJust)
14import Data.Monoid ((<>))
15import Data.Text (Text)
16import GHC.Generics (Generic)
17import Network.HTTP.Client (Manager, Request, Response, httpLbs,
18 method, responseBody, responseHeaders,
19 responseStatus)
20import Network.HTTP.Types (methodGet, methodHead, parseMethod,
21 status401, renderStdMethod, status405, status500)
23-- | [__Best Practice__]
24--
25-- @500 Internal Server Error@ should be avoided - it may represent some
26-- issue with the application code, and it moreover gives the client little
27-- indication of how to proceed or what went wrong.
28--
29-- This function checks that the response code is not 500.
30not500 :: ResponsePredicate Text Bool
31not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
33-- | [__Best Practice__]
34--
35-- Returning anything other than an object when returning JSON is considered
36-- bad practice, as:
37--
38-- (1) it is hard to modify the returned value while maintaining backwards
39-- compatibility
40-- (2) many older tools do not support top-level arrays
41-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
42-- on what RFC you're going by
43-- (4) there are security issues with top-level arrays
44--
45-- This function checks that any @application/json@ responses only return JSON
46-- objects (and not arrays, strings, numbers, or booleans) at the top level.
47--
48-- __References__:
49--
50-- * JSON Grammar: <https://tools.ietf.org/html/rfc7159#section-2 RFC 7159 Section 2>
51-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
52onlyJsonObjects :: ResponsePredicate Text Bool
53onlyJsonObjects
54 = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
55 Nothing -> False
56 Just (_ :: Object) -> True)
58{-
59-- | When creating a new resource, it is good practice to provide a @Location@
60-- header with a link to the created resource.
61--
62-- This function checks that every @201 Created@ response contains a @Location@
63-- header, and that the link in it responds with a 2XX response code to @GET@
64-- requests.
65--
66-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
67createContainsValidLocation :: ResponsePredicate Text Bool
68createContainsValidLocation
69 = ResponsePredicate "createContainsValidLocation" (\resp ->
71getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
72getsHaveLastModifiedHeader
73 = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
75-}
77-- | [__RFC Compliance__]
78--
79-- When an HTTP request has a method that is not allowed,
80-- a 405 response should be returned. Additionally, it is good practice to
81-- return an @Allow@
82-- header with the list of allowed methods.
83--
84-- This function checks that every @405 Method Not Allowed@ response contains
85-- an @Allow@ header with a list of standard HTTP methods.
86--
87-- __References__:
88--
89-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
90-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
91notAllowedContainsAllowHeader :: RequestPredicate Text Bool
92notAllowedContainsAllowHeader
93 = RequestPredicate
94 { reqPredName = name
95 , reqResps = \req mgr -> mapM (flip httpLbs mgr)
96 [ req { method = renderStdMethod m }
97 | m <- [minBound .. maxBound ]
98 , renderStdMethod m /= method req ]
99 , reqPred = pred'
100 }
101 where
102 name = "notAllowedContainsAllowHeader"
103 pred' = ResponsePredicate name (\resp ->
104 if responseStatus resp == status405
105 then hasValidHeader "Allow" go resp
106 else True)
107 where
108 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
109 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
111 {-
112-- | When a request contains an @Accept@ header, the server must either return
113-- content in one of the requested representations, or respond with @406 Not
114-- Acceptable@.
115--
116-- This function checks that every *successful* response has a @Content-Type@
117-- header that matches the @Accept@ header.
118--
119-- __References__:
120--
121-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
122honoursAcceptHeader :: RequestPredicate b Bool
123honoursAcceptHeader
124 = RequestPredicate name (ResponsePredicate name $ \req mgr -> do
126 resp <- httpLbs req mgr
127 let scode = responseStatus resp
128 sctype = maybeToList $ lookup "Content-Type" $ responseHeaders resp
129 sacc = fromMaybe "*/*" $ lookup "Accept" $ requestHeaders req
130 if 100 < scode && scode < 300
131 then isJust matchAccept sacc sctype
132 else True)
133 where name = "honoursAcceptHeader"
135-}
136-- | [__Best Practice__]
137--
138-- Whether or not a representation should be cached, it is good practice to
139-- have a @Cache-Control@ header for @GET@ requests. If the representation
140-- should not be cached, used @Cache-Control: no-cache@.
141--
142-- This function checks that @GET@ responses have @Cache-Control@ header.
143-- It does NOT currently check that the header is valid.
144--
145-- __References__:
146--
147-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
148getsHaveCacheControlHeader :: RequestPredicate Text Bool
149getsHaveCacheControlHeader
150 = RequestPredicate
151 { reqPredName = name
152 , reqResps = \req mgr -> if method req == methodGet
153 then return <$> httpLbs req mgr
154 else return []
155 , reqPred = ResponsePredicate name $ \resp ->
156 isJust $ lookup "Cache-Control" $ responseHeaders resp
157 }
158 where name = "getsHaveCacheControlHeader"
160-- | [__Best Practice__]
161--
162-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
163headsHaveCacheControlHeader :: RequestPredicate Text Bool
164headsHaveCacheControlHeader
165 = RequestPredicate
166 { reqPredName = name
167 , reqResps = \req mgr -> if method req == methodHead
168 then return <$> httpLbs req mgr
169 else return []
170 , reqPred = ResponsePredicate name $ \resp ->
171 isJust $ lookup "Cache-Control" $ responseHeaders resp
172 }
173 where name = "headsHaveCacheControlHeader"
175{-
176-- |
177--
178-- If the original request modifies the resource, this function makes two
179-- requests:
180--
181-- (1) Once, with the original request and a future date as the
182-- @If-Unmodified-Since@, which is expected to succeed.
183-- (2) Then with the original request again, with a @If-Unmodified-Since@
184-- safely in the past. Since presumably the representation has been changed
185-- recently (by the first request), this is expected to fail with @412
186-- Precondition Failure@.
187--
188-- Note that the heuristic used to guess whether the original request modifies
189-- a resource is simply whether the method is @PUT@ or @PATCH@, which may be
190-- incorrect in certain circumstances.
191supportsIfUnmodifiedSince :: Predicate b Bool
192supportsIfUnmodifiedSince
193 = ResponsePredicate "supportsIfUnmodifiedSince" _
195-- | @OPTIONS@ responses should contain an @Allow@ header with the list of
196-- allowed methods.
197--
198-- If a request is an @OPTIONS@ request, and if the response is a successful
199-- one, this function checks the response for an @Allow@ header. It fails if:
200--
201-- (1) There is no @Allow@ header
202-- (2) The @Allow@ header does not have standard HTTP methods in the correct
203-- format
204-- (3) Making a request to the same URL with one of those methods results in
205-- a 404 or 405.
206optionsContainsValidAllow :: Predicate b Bool
207optionsContainsValidAllow
208 = ResponsePredicate "optionsContainsValidAllow" _
210-- | Link headers are a standardized way of presenting links that may be
211-- relevant to a client.
212--
213-- This function checks that any @Link@ headers have values in the correct
214-- format.
215--
216-- __References__:
217--
218-- * <https://tools.ietf.org/html/rfc5988 RFC 5988 Section 5>
219linkHeadersAreValid :: Predicate b Bool
220linkHeadersAreValid
221 = ResponsePredicate "linkHeadersAreValid" _
223-}
224-- | [__RFC Compliance__]
225--
226-- Any @401 Unauthorized@ response must include a @WWW-Authenticate@ header.
227--
228-- This function checks that, if a response has status code 401, it contains a
229-- @WWW-Authenticate@ header.
230--
231-- __References__:
232--
233-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
234unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
235unauthorizedContainsWWWAuthenticate
236 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
237 if responseStatus resp == status401
238 then hasValidHeader "WWW-Authenticate" (const True) resp
239 else True)
241-- * Predicate logic
243-- The idea with all this footwork is to not waste any requests. Rather than
244-- generating new requests and only applying one predicate to the response, we
245-- apply as many predicates as possible.
246--
247-- Still, this is all kind of ugly.
249data ResponsePredicate n r = ResponsePredicate
250 { respPredName :: n
251 , respPred :: Response LBS.ByteString -> r
252 } deriving (Functor, Generic)
254instance Bifunctor ResponsePredicate where
255 first f (ResponsePredicate a b) = ResponsePredicate (f a) b
256 second = fmap
258instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
259 mempty = ResponsePredicate mempty mempty
260 a `mappend` b = ResponsePredicate
261 { respPredName = respPredName a <> respPredName b
262 , respPred = respPred a <> respPred b
263 }
265data RequestPredicate n r = RequestPredicate
266 { reqPredName :: n
267 , reqResps :: Request -> Manager -> IO [Response LBS.ByteString]
268 , reqPred :: ResponsePredicate n r
269 } deriving (Generic, Functor)
271instance Bifunctor RequestPredicate where
272 first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c)
273 second = fmap
275-- TODO: This isn't actually a monoid
276instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
277 mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty
278 a `mappend` b = RequestPredicate
279 { reqPredName = reqPredName a <> reqPredName b
280 , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
281 , reqPred = reqPred a <> reqPred b
282 }
284data Predicates n r = Predicates
285 { reqPreds :: RequestPredicate n r
286 , respPreds :: ResponsePredicate n r
287 } deriving (Generic, Functor)
289instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
290 mempty = Predicates mempty mempty
291 a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
295class JoinPreds a where
296 joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
298instance JoinPreds (RequestPredicate Text Bool) where
299 joinPreds p (Predicates x y) = Predicates (go <> x) y
300 where go = let p' = first return p
301 in fmap (\z -> if z then [] else reqPredName p') p'
303instance JoinPreds (ResponsePredicate Text Bool) where
304 joinPreds p (Predicates x y) = Predicates x (go <> y)
305 where go = let p' = first return p
306 in fmap (\z -> if z then [] else respPredName p') p'
309-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
310-- the existing predicates.
311--
312-- > not500 <%> onlyJsonObjects <%> empty
313(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
314(<%>) = joinPreds
315infixr 6 <%>
317finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
318finishPredicates p req mgr = do
319 resps <- reqResps (reqPreds p) req mgr
320 let preds = reqPred (reqPreds p) <> respPreds p
321 return $ mconcat [respPred preds r | r <- resps ]
323-- * helpers
325hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool
326hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
327 Nothing -> False
328 Just v -> p v