@@ -1,28 +1,36 @@
11module Servant.QuickCheck.Internal.Predicates where
22
3−import Control.Monad (liftM2)
3+import Control.Exception (catch, throw)
4+import Control.Monad (liftM2, unless, when)
45import Data.Aeson (Object, decode)
5−import Data.Bifunctor (Bifunctor (..))
6−import Prelude.Compat
6+import Data.Bifunctor (first)
77import qualified Data.ByteString as SBS
88import qualified Data.ByteString.Char8 as SBSC
99import qualified Data.ByteString.Lazy as LBS
10−import Data.CaseInsensitive (mk)
10+import Data.CaseInsensitive (foldCase, foldedCase, mk)
1111import Data.Either (isRight)
1212import Data.List.Split (wordsBy)
1313import Data.Maybe (fromMaybe, isJust)
14−import Data.Monoid ((<>))
15−import Data.Text (Text)
14+import Data.Semigroup (Semigroup (..))
15+import qualified Data.Text as T
16+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
17+ rfc822DateFormat)
1618import GHC.Generics (Generic)
1719import Network.HTTP.Client (Manager, Request, Response, httpLbs,
18− method, parseUrl, requestHeaders,
20+ method, parseRequest, requestHeaders,
1921 responseBody, responseHeaders,
2022 responseStatus)
2123import Network.HTTP.Media (matchAccept)
2224import Network.HTTP.Types (methodGet, methodHead, parseMethod,
23− renderStdMethod, status200, status201,
24− status300, status401, status405,
25− status500, status100)
25+ renderStdMethod, status100, status200,
26+ status201, status300, status401,
27+ status405, status500)
28+import Prelude.Compat
29+import System.Clock (Clock (Monotonic), diffTimeSpec,
30+ getTime, toNanoSecs)
31+
32+import Servant.QuickCheck.Internal.ErrorTypes
33+
2634
2735-- | [__Best Practice__]
2836--
@@ -33,8 +41,25 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,
3341-- This function checks that the response code is not 500.
3442--
3543-- /Since 0.0.0.0/
36−not500 :: ResponsePredicate Text Bool
37−not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
44+not500 :: ResponsePredicate
45+not500 = ResponsePredicate $ \resp ->
46+ when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
47+
48+-- | [__Optional__]
49+--
50+-- This function checks that the response from the server does not take longer
51+-- than the specified number of nanoseconds.
52+--
53+-- /Since 0.0.2.1/
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
62+ return []
3863
3964-- | [__Best Practice__]
4065--
@@ -57,11 +82,15 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
5782-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
5883--
5984-- /Since 0.0.0.0/
60−onlyJsonObjects :: ResponsePredicate Text Bool
85+onlyJsonObjects :: ResponsePredicate
6186onlyJsonObjects
62− = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
63− Nothing -> False
64− Just (_ :: Object) -> True)
87+ = ResponsePredicate (\resp -> do
88+ case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
89+ Nothing -> return ()
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
93+ Just _ -> return ())
6594
6695-- | __Optional__
6796--
@@ -82,29 +111,59 @@ onlyJsonObjects
82111-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
83112--
84113-- /Since 0.0.0.0/
85−createContainsValidLocation :: RequestPredicate Text Bool
114+createContainsValidLocation :: RequestPredicate
86115createContainsValidLocation
87− = RequestPredicate
88− { reqPredName = "createContainsValidLocation"
89− , reqResps = \req mgr -> do
116+ = RequestPredicate $ \req mgr -> do
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
124+ Just x -> do
125+ resp2 <- httpLbs x mgr
126+ status2XX (Just req) resp2 n
127+ return [resp, resp2]
128+ else return [resp]
129+
130+-- | [__Optional__]
131+--
132+-- The @Last-Modified@ header represents the time a resource was last
133+-- modified. It is used to drive caching and conditional requests.
134+--
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.
140+--
141+-- The @Last-Modified@ header can also be used in conjunction with the
142+-- @If-Unmodified-Since@ header to drive optimistic concurrency.
143+--
144+-- The @Last-Modified@ date must be in RFC 822 format.
145+--
146+-- __References__:
147+--
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>
153+--
154+-- /Since 0.0.2.1/
155+getsHaveLastModifiedHeader :: RequestPredicate
156+getsHaveLastModifiedHeader
157+ = RequestPredicate $ \req mgr ->
158+ if (method req == methodGet)
159+ then do
90160 resp <- httpLbs req mgr
91− if responseStatus resp == status201
92− then case lookup "Location" $ responseHeaders resp of
93− Nothing -> return (False, [resp])
94− Just l -> case parseUrl $ SBSC.unpack l of
95− Nothing -> return (False, [resp])
96− Just x -> do
97− resp2 <- httpLbs x mgr
98− return (status2XX resp2, [resp, resp2])
99− else return (True, [resp])
100− }
161+ unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
162+ throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
163+ return [resp]
164+ else return []
101165
102−{-
103−getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
104−getsHaveLastModifiedHeader
105− = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
106166
107−-}
108167
109168-- | [__RFC Compliance__]
110169--
@@ -116,24 +175,27 @@ getsHaveLastModifiedHeader
116175-- This function checks that every @405 Method Not Allowed@ response contains
117176-- an @Allow@ header with a list of standard HTTP methods.
118177--
178+-- Note that 'servant' itself does not currently set the @Allow@ headers.
179+--
119180-- __References__:
120181--
121182-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
122183-- * 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>
123185--
124186-- /Since 0.0.0.0/
125−notAllowedContainsAllowHeader :: RequestPredicate Text Bool
187+notAllowedContainsAllowHeader :: RequestPredicate
126188notAllowedContainsAllowHeader
127− = RequestPredicate
128− { reqPredName = "notAllowedContainsAllowHeader"
129− , reqResps = \req mgr -> do
130− resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
131− | m <- [minBound .. maxBound ]
132− , renderStdMethod m /= method req ]
133− return (all pred' resp, resp)
134− }
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
193+
194+ case filter pred' (zip reqs resp) of
195+ (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
196+ [] -> return resp
135197 where
136− pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
198+ pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
137199 where
138200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
139201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -154,19 +216,19 @@ notAllowedContainsAllowHeader
154216-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
155217--
156218-- /Since 0.0.0.0/
157−honoursAcceptHeader :: RequestPredicate Text Bool
219+honoursAcceptHeader :: RequestPredicate
158220honoursAcceptHeader
159− = RequestPredicate
160− { reqPredName = "honoursAcceptHeader"
161− , reqResps = \req mgr -> do
162− resp <- httpLbs req mgr
163− let scode = responseStatus resp
164− sctype = lookup "Content-Type" $ responseHeaders resp
165− sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
166− if status100 < scode && scode < status300
167− then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])
168− else return (True, [resp])
169− }
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
229+ else return [resp]
230+ else return [resp]
231+
170232
171233-- | [__Best Practice__]
172234--
@@ -182,34 +244,32 @@ honoursAcceptHeader
182244-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
183245--
184246-- /Since 0.0.0.0/
185−getsHaveCacheControlHeader :: RequestPredicate Text Bool
247+getsHaveCacheControlHeader :: RequestPredicate
186248getsHaveCacheControlHeader
187− = RequestPredicate
188− { reqPredName = "getsHaveCacheControlHeader"
189− , reqResps = \req mgr -> if method req == methodGet
190− then do
191− resp <- httpLbs req mgr
192− let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
193− return (good, [resp])
194− else return (True, [])
195− }
249+ = RequestPredicate $ \req mgr ->
250+ if (method req == methodGet)
251+ then do
252+ resp <- httpLbs req mgr
253+ unless (hasValidHeader "Cache-Control" (const True) resp) $ do
254+ throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
255+ return [resp]
256+ else return []
196257
197258-- | [__Best Practice__]
198259--
199260-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
200261--
201262-- /Since 0.0.0.0/
202−headsHaveCacheControlHeader :: RequestPredicate Text Bool
263+headsHaveCacheControlHeader :: RequestPredicate
203264headsHaveCacheControlHeader
204− = RequestPredicate
205− { reqPredName = "headsHaveCacheControlHeader"
206− , reqResps = \req mgr -> if method req == methodHead
207− then do
208− resp <- httpLbs req mgr
209− let good = hasValidHeader "Cache-Control" (const True) resp
210− return (good, [resp])
211− else return (True, [])
212− }
265+ = RequestPredicate $ \req mgr ->
266+ if (method req == methodHead)
267+ then do
268+ resp <- httpLbs req mgr
269+ unless (hasValidHeader "Cache-Control" (const True) resp) $
270+ throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
271+ return [resp]
272+ else return []
213273{-
214274-- |
215275--
@@ -271,12 +331,35 @@ linkHeadersAreValid
271331-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
272332--
273333-- /Since 0.0.0.0/
274−unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
334+unauthorizedContainsWWWAuthenticate :: ResponsePredicate
275335unauthorizedContainsWWWAuthenticate
276− = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
336+ = ResponsePredicate $ \resp ->
277337 if responseStatus resp == status401
278− then hasValidHeader "WWW-Authenticate" (const True) resp
279− else True)
338+ then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339+ throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
340+ else return ()
341+
342+
343+-- | [__RFC Compliance__]
344+--
345+-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
346+--
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`.
349+--
350+-- __References__:
351+--
352+-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
353+-- /Since 0.3.0.0/
354+htmlIncludesDoctype :: ResponsePredicate
355+htmlIncludesDoctype
356+ = ResponsePredicate $ \resp ->
357+ if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
358+ then do
359+ let htmlContent = foldCase . LBS.take 20 $ responseBody resp
360+ unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
361+ throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
362+ else return ()
280363
281364-- * Predicate logic
282365
@@ -289,67 +372,56 @@ unauthorizedContainsWWWAuthenticate
289372-- | A predicate that depends only on the response.
290373--
291374-- /Since 0.0.0.0/
292−data ResponsePredicate n r = ResponsePredicate
293− { respPredName :: n
294− , respPred :: Response LBS.ByteString -> r
295− } deriving (Functor, Generic)
296−
297−instance Bifunctor ResponsePredicate where
298− first f (ResponsePredicate a b) = ResponsePredicate (f a) b
299− second = fmap
300−
301−instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
302− mempty = ResponsePredicate mempty mempty
303− a `mappend` b = ResponsePredicate
304− { respPredName = respPredName a <> respPredName b
305− , respPred = respPred a <> respPred b
306− }
375+newtype ResponsePredicate = ResponsePredicate
376+ { getResponsePredicate :: Response LBS.ByteString -> IO ()
377+ } deriving (Generic)
378+
379+instance Semigroup ResponsePredicate where
380+ ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
381+
382+instance Monoid ResponsePredicate where
383+ mempty = ResponsePredicate $ const $ return ()
384+ mappend = (<>)
307385
308386-- | A predicate that depends on both the request and the response.
309387--
310388-- /Since 0.0.0.0/
311−data RequestPredicate n r = RequestPredicate
312− { reqPredName :: n
313− , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])
314− } deriving (Generic, Functor)
389+newtype RequestPredicate = RequestPredicate
390+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
391+ } deriving (Generic)
315392
316−instance Bifunctor RequestPredicate where
317− first f (RequestPredicate a b) = RequestPredicate (f a) b
318− second = fmap
393+-- TODO: This isn't actually a monoid
394+instance Monoid RequestPredicate where
395+ mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
396+ mappend = (<>)
319397
320398-- TODO: This isn't actually a monoid
321−instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
322− mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
323− a `mappend` b = RequestPredicate
324− { reqPredName = reqPredName a <> reqPredName b
325− , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
326− }
399+instance Semigroup RequestPredicate where
400+ RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
401+ liftM2 (<>) (a r mgr) (b r mgr)
327402
328403-- | A set of predicates. Construct one with 'mempty' and '<%>'.
329−data Predicates n r = Predicates
330− { reqPreds :: RequestPredicate n r
331− , respPreds :: ResponsePredicate n r
332− } deriving (Generic, Functor)
333−
334−instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
335− mempty = Predicates mempty mempty
336− a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
404+data Predicates = Predicates
405+ { requestPredicates :: RequestPredicate
406+ , responsePredicates :: ResponsePredicate
407+ } deriving (Generic)
337408
409+instance Semigroup Predicates where
410+ a <> b = Predicates (requestPredicates a <> requestPredicates b)
411+ (responsePredicates a <> responsePredicates b)
338412
413+instance Monoid Predicates where
414+ mempty = Predicates mempty mempty
415+ mappend = (<>)
339416
340417class JoinPreds a where
341− joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
342−
343−instance JoinPreds (RequestPredicate Text Bool) where
344− joinPreds p (Predicates x y) = Predicates (go <> x) y
345− where go = let p' = first return p
346− in fmap (\z -> if z then [] else reqPredName p') p'
418+ joinPreds :: a -> Predicates -> Predicates
347419
348−instance JoinPreds (ResponsePredicate Text Bool) where
349− joinPreds p (Predicates x y) = Predicates x (go <> y)
350− where go = let p' = first return p
351− in fmap (\z -> if z then [] else respPredName p') p'
420+instance JoinPreds (RequestPredicate ) where
421+ joinPreds p (Predicates x y) = Predicates (p <> x) y
352422
423+instance JoinPreds (ResponsePredicate ) where
424+ joinPreds p (Predicates x y) = Predicates x (p <> y)
353425
354426-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
355427-- the existing predicates.
@@ -357,14 +429,17 @@ instance JoinPreds (ResponsePredicate Text Bool) where
357429-- > not500 <%> onlyJsonObjects <%> empty
358430--
359431-- /Since 0.0.0.0/
360−(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
432+(<%>) :: JoinPreds a => a -> Predicates -> Predicates
361433(<%>) = joinPreds
362434infixr 6 <%>
363435
364−finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
365−finishPredicates p req mgr = do
366− (soFar, resps) <- reqResps (reqPreds p) req mgr
367− return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
436+finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
437+finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
438+ where
439+ go = do
440+ resps <- getRequestPredicate (requestPredicates p) req mgr
441+ mapM_ (getResponsePredicate $ responsePredicates p) resps
442+ return Nothing
368443
369444-- * helpers
370445
@@ -373,5 +448,14 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
373448 Nothing -> False
374449 Just v -> p v
375450
376−status2XX :: Response b -> Bool
377−status2XX r = status200 <= responseStatus r && responseStatus r < status300
451+isRFC822Date :: SBS.ByteString -> Bool
452+isRFC822Date s
453+ = case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of
454+ Nothing -> False
455+ Just (_ :: UTCTime) -> True
456+
457+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
458+status2XX mreq resp t
459+ | status200 <= responseStatus resp && responseStatus resp < status300
460+ = return ()
461+ | otherwise = throw $ PredicateFailure t mreq resp