@@ -55,19 +55,35 @@ onlyJsonObjects
5555 Nothing -> False
5656 Just (_ :: Object) -> True)
5757
58−{-
59−-- | When creating a new resource, it is good practice to provide a @Location@
58+-- | __Optional__
59+--
60+-- When creating a new resource, it is good practice to provide a @Location@
6061-- header with a link to the created resource.
6162--
6263-- This function checks that every @201 Created@ response contains a @Location@
6364-- header, and that the link in it responds with a 2XX response code to @GET@
6465-- requests.
6566--
66−-- References: <RFC 7231, Section 6.3.2 https://tools.ietf.org/html/rfc7231#section-6.3.2>
67−createContainsValidLocation :: ResponsePredicate Text Bool
68−createContainsValidLocation
69− = ResponsePredicate "createContainsValidLocation" (\resp ->
67+-- This is considered optional because other means of linking to the resource
68+-- (e.g. via the response body) are also acceptable; linking to the resource in
69+-- some way is considered best practice.
70+--
71+-- __References__:
72+--
73+-- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>
74+-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
75+{-createContainsValidLocation :: RequestPredicate Text Bool-}
76+{-createContainsValidLocation-}
77+ {-= RequestPredicate-}
78+ {-{ reqPredName = "createContainsValidLocation"-}
79+ {-, reqResps = \req mg -> do-}
80+ {-resp <- httpLbs mgr req-}
81+ {-if responseStatus resp == status201-}
82+ {-then case lookup "Location" $ responseHeaders resp of-}
83+ {-Nothing -> return []-}
84+ {-Just l -> if-}
7085
86+{-
7187getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
7288getsHaveLastModifiedHeader
7389 = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
@@ -91,19 +107,15 @@ getsHaveLastModifiedHeader
91107notAllowedContainsAllowHeader :: RequestPredicate Text Bool
92108notAllowedContainsAllowHeader
93109 = 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'
110+ { reqPredName = "notAllowedContainsAllowHeader"
111+ , reqResps = \req mgr -> do
112+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
113+ | m <- [minBound .. maxBound ]
114+ , renderStdMethod m /= method req ]
115+ return (all pred' resp, resp)
100116 }
101117 where
102− name = "notAllowedContainsAllowHeader"
103− pred' = ResponsePredicate name (\resp ->
104− if responseStatus resp == status405
105− then hasValidHeader "Allow" go resp
106− else True)
118+ pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
107119 where
108120 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
109121 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -148,14 +160,14 @@ honoursAcceptHeader
148160getsHaveCacheControlHeader :: RequestPredicate Text Bool
149161getsHaveCacheControlHeader
150162 = RequestPredicate
151− { reqPredName = name
163+ { reqPredName = "getsHaveCacheControlHeader"
152164 , 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
165+ then do
166+ resp <- httpLbs req mgr
167+ let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
168+ return (good, [resp])
169+ else return (True, [])
157170 }
158− where name = "getsHaveCacheControlHeader"
159171
160172-- | [__Best Practice__]
161173--
@@ -163,15 +175,14 @@ getsHaveCacheControlHeader
163175headsHaveCacheControlHeader :: RequestPredicate Text Bool
164176headsHaveCacheControlHeader
165177 = RequestPredicate
166− { reqPredName = name
178+ { reqPredName = "headsHaveCacheControlHeader"
167179 , 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
180+ then do
181+ resp <- httpLbs req mgr
182+ let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
183+ return (good, [resp])
184+ else return (True, [])
172185 }
173− where name = "headsHaveCacheControlHeader"
174−
175186{-
176187-- |
177188--
@@ -264,21 +275,19 @@ instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
264275
265276data RequestPredicate n r = RequestPredicate
266277 { reqPredName :: n
267− , reqResps :: Request -> Manager -> IO [Response LBS.ByteString]
268− , reqPred :: ResponsePredicate n r
278+ , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])
269279 } deriving (Generic, Functor)
270280
271281instance Bifunctor RequestPredicate where
272− first f (RequestPredicate a b c) = RequestPredicate (f a) b (first f c)
282+ first f (RequestPredicate a b) = RequestPredicate (f a) b
273283 second = fmap
274284
275285-- TODO: This isn't actually a monoid
276286instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
277− mempty = RequestPredicate mempty (\r m -> return <$> httpLbs r m) mempty
287+ mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
278288 a `mappend` b = RequestPredicate
279289 { reqPredName = reqPredName a <> reqPredName b
280290 , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
281− , reqPred = reqPred a <> reqPred b
282291 }
283292
284293data Predicates n r = Predicates
@@ -316,9 +325,8 @@ infixr 6 <%>
316325
317326finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
318327finishPredicates 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 ]
328+ (soFar, resps) <- reqResps (reqPreds p) req mgr
329+ return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
322330
323331-- * helpers
324332