@@ -87,15 +87,26 @@ getsHaveLastModifiedHeader
8787-- __References__:
8888--
8989-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
90−notAllowedContainsAllowHeader :: ResponsePredicate Text Bool
90+-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
91+notAllowedContainsAllowHeader :: RequestPredicate Text Bool
9192notAllowedContainsAllowHeader
92− = ResponsePredicate "notAllowedContainsAllowHeader" (\resp ->
93− if responseStatus resp == status405
94− then hasValidHeader "Allow" go resp
95− else True)
96− where
97− go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
98− $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
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)
99110
100111 {-
101112-- | When a request contains an @Accept@ header, the server must either return
@@ -104,28 +115,64 @@ notAllowedContainsAllowHeader
104115--
105116-- This function checks that every *successful* response has a @Content-Type@
106117-- header that matches the @Accept@ header.
107−honoursAcceptHeader :: Predicate b Bool
118+--
119+-- __References__:
120+--
121+-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
122+honoursAcceptHeader :: RequestPredicate b Bool
108123honoursAcceptHeader
109− = RequestPredicate "honoursAcceptHeader" _
124+ = RequestPredicate name (ResponsePredicate name $ \req mgr -> do
125+
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"
110134
111−-- | Whether or not a representation should be cached, it is good practice to
135+-}
136+-- | [__Best Practice__]
137+--
138+-- Whether or not a representation should be cached, it is good practice to
112139-- have a @Cache-Control@ header for @GET@ requests. If the representation
113140-- should not be cached, used @Cache-Control: no-cache@.
114141--
115−-- This function checks that @GET@ responses have a valid @Cache-Control@
116−-- header.
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__:
117146--
118−-- References: RFC 7234 Section 5.2
119−-- https://tools.ietf.org/html/rfc7234#section-5.2
120−getsHaveCacheControlHeader :: Predicate b Bool
147+-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
148+getsHaveCacheControlHeader :: RequestPredicate Text Bool
121149getsHaveCacheControlHeader
122− = ResponsePredicate "getsHaveCacheControlHeader" _
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"
123159
124−-- | Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
125−headsHaveCacheControlHeader :: Predicate b Bool
160+-- | [__Best Practice__]
161+--
162+-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
163+headsHaveCacheControlHeader :: RequestPredicate Text Bool
126164headsHaveCacheControlHeader
127− = ResponsePredicate "headsHaveCacheControlHeader" _
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"
128174
175+{-
129176-- |
130177--
131178-- If the original request modifies the resource, this function makes two