c2a06bc · typeable/servant

git.iko.soy/typeable/servant

More generous acceptable status codes for servant-client

commitc2a06bc0902ef88baab66b8d229855f66e2a0f17 authorJulian K. Arni <jkarni@gmail.com> dateWed 7 Oct 2015, 15:24 (11 years ago) parentad39feb

3 files changed+34−45

compare with master

unifiedsplit

servant-client/src/Servant/Client.hs+16−26 servant-client/src/Servant/Common/Req.hs+9−9 servant-client/test/Servant/ClientSpec.hs+9−10

servant-client/src/Servant/Client.hs+16−26

@@ -130,10 +130,8 @@ instance

130130 (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where

131131 type Client (Delete cts' a) = ExceptT ServantError IO a

132132 clientWithRoute Proxy req baseurl manager =

133− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager

133+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager

134134

135−-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content

136−-- HTTP header.

137135instance

138136#if MIN_VERSION_base(4,8,0)

139137 {-# OVERLAPPING #-}

@@ -141,7 +139,7 @@ instance

141139 HasClient (Delete cts ()) where

142140 type Client (Delete cts ()) = ExceptT ServantError IO ()

143141 clientWithRoute Proxy req baseurl manager =

144− void $ performRequestNoBody H.methodDelete req [204] baseurl manager

142+ void $ performRequestNoBody H.methodDelete req baseurl manager

145143

146144-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the

147145-- corresponding headers.

@@ -153,7 +151,7 @@ instance

153151 ) => HasClient (Delete cts' (Headers ls a)) where

154152 type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

155153 clientWithRoute Proxy req baseurl manager = do

156− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager

154+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager

157155 return $ Headers { getResponse = resp

158156 , getHeadersHList = buildHeadersTo hdrs

159157 }

@@ -169,10 +167,8 @@ instance

169167 (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where

170168 type Client (Get (ct ': cts) result) = ExceptT ServantError IO result

171169 clientWithRoute Proxy req baseurl manager =

172− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl manager

170+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager

173171

174−-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content

175−-- HTTP status.

176172instance

177173#if MIN_VERSION_base(4,8,0)

178174 {-# OVERLAPPING #-}

@@ -180,7 +176,7 @@ instance

180176 HasClient (Get (ct ': cts) ()) where

181177 type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()

182178 clientWithRoute Proxy req baseurl manager =

183− performRequestNoBody H.methodGet req [204] baseurl manager

179+ performRequestNoBody H.methodGet req baseurl manager

184180

185181-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the

186182-- corresponding headers.

@@ -192,7 +188,7 @@ instance

192188 ) => HasClient (Get (ct ': cts) (Headers ls a)) where

193189 type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

194190 clientWithRoute Proxy req baseurl manager = do

195− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl manager

191+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager

196192 return $ Headers { getResponse = resp

197193 , getHeadersHList = buildHeadersTo hdrs

198194 }

@@ -251,10 +247,8 @@ instance

251247 (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where

252248 type Client (Post (ct ': cts) a) = ExceptT ServantError IO a

253249 clientWithRoute Proxy req baseurl manager =

254− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl manager

250+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager

255251

256−-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content

257−-- HTTP header.

258252instance

259253#if MIN_VERSION_base(4,8,0)

260254 {-# OVERLAPPING #-}

@@ -262,7 +256,7 @@ instance

262256 HasClient (Post (ct ': cts) ()) where

263257 type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()

264258 clientWithRoute Proxy req baseurl manager =

265− void $ performRequestNoBody H.methodPost req [204] baseurl manager

259+ void $ performRequestNoBody H.methodPost req baseurl manager

266260

267261-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the

268262-- corresponding headers.

@@ -274,7 +268,7 @@ instance

274268 ) => HasClient (Post (ct ': cts) (Headers ls a)) where

275269 type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

276270 clientWithRoute Proxy req baseurl manager = do

277− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl manager

271+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager

278272 return $ Headers { getResponse = resp

279273 , getHeadersHList = buildHeadersTo hdrs

280274 }

@@ -290,10 +284,8 @@ instance

290284 (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where

291285 type Client (Put (ct ': cts) a) = ExceptT ServantError IO a

292286 clientWithRoute Proxy req baseurl manager =

293− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl manager

287+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager

294288

295−-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content

296−-- HTTP header.

297289instance

298290#if MIN_VERSION_base(4,8,0)

299291 {-# OVERLAPPING #-}

@@ -301,7 +293,7 @@ instance

301293 HasClient (Put (ct ': cts) ()) where

302294 type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()

303295 clientWithRoute Proxy req baseurl manager =

304− void $ performRequestNoBody H.methodPut req [204] baseurl manager

296+ void $ performRequestNoBody H.methodPut req baseurl manager

305297

306298-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the

307299-- corresponding headers.

@@ -313,7 +305,7 @@ instance

313305 ) => HasClient (Put (ct ': cts) (Headers ls a)) where

314306 type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

315307 clientWithRoute Proxy req baseurl manager= do

316− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl manager

308+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager

317309 return $ Headers { getResponse = resp

318310 , getHeadersHList = buildHeadersTo hdrs

319311 }

@@ -329,10 +321,8 @@ instance

329321 (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where

330322 type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a

331323 clientWithRoute Proxy req baseurl manager =

332− snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl manager

324+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager

333325

334−-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content

335−-- HTTP header.

336326instance

337327#if MIN_VERSION_base(4,8,0)

338328 {-# OVERLAPPING #-}

@@ -340,7 +330,7 @@ instance

340330 HasClient (Patch (ct ': cts) ()) where

341331 type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()

342332 clientWithRoute Proxy req baseurl manager =

343− void $ performRequestNoBody H.methodPatch req [204] baseurl manager

333+ void $ performRequestNoBody H.methodPatch req baseurl manager

344334

345335-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the

346336-- corresponding headers.

@@ -352,7 +342,7 @@ instance

352342 ) => HasClient (Patch (ct ': cts) (Headers ls a)) where

353343 type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)

354344 clientWithRoute Proxy req baseurl manager = do

355− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl manager

345+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager

356346 return $ Headers { getResponse = resp

357347 , getHeadersHList = buildHeadersTo hdrs

358348 }

@@ -623,7 +613,7 @@ instance HasClient Raw where

623613

624614 clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw

625615 clientWithRoute Proxy req baseurl manager httpMethod = do

626− performRequest httpMethod req (const True) baseurl manager

616+ performRequest httpMethod req baseurl manager

627617

628618-- | If you use a 'ReqBody' in one of your endpoints in your API,

629619-- the corresponding querying function will automatically take

servant-client/src/Servant/Common/Req.hs+9−9

@@ -131,10 +131,10 @@ displayHttpRequest :: Method -> String

131131displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"

132132

133133

134−performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> Manager

134+performRequest :: Method -> Req -> BaseUrl -> Manager

135135 -> ExceptT ServantError IO ( Int, ByteString, MediaType

136136 , [HTTP.Header], Response ByteString)

137−performRequest reqMethod req isWantedStatus reqHost manager = do

137+performRequest reqMethod req reqHost manager = do

138138 partialRequest <- liftIO $ reqToRequest req reqHost

139139

140140 let request = partialRequest { Client.method = reqMethod

@@ -156,25 +156,25 @@ performRequest reqMethod req isWantedStatus reqHost manager = do

156156 Just t -> case parseAccept t of

157157 Nothing -> throwE $ InvalidContentTypeHeader (cs t) body

158158 Just t' -> pure t'

159− unless (isWantedStatus status_code) $

159+ unless (status_code >= 200 && status_code < 300) $

160160 throwE $ FailureResponse status ct body

161161 return (status_code, body, ct, hrds, response)

162162

163163

164164performRequestCT :: MimeUnrender ct result =>

165− Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)

166−performRequestCT ct reqMethod req wantedStatus reqHost manager = do

165+ Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)

166+performRequestCT ct reqMethod req reqHost manager = do

167167 let acceptCT = contentType ct

168168 (_status, respBody, respCT, hrds, _response) <-

169− performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost manager

169+ performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager

170170 unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody

171171 case mimeUnrender ct respBody of

172172 Left err -> throwE $ DecodeFailure err respCT respBody

173173 Right val -> return (hrds, val)

174174

175−performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ()

176−performRequestNoBody reqMethod req wantedStatus reqHost manager =

177− void $ performRequest reqMethod req (`elem` wantedStatus) reqHost manager

175+performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()

176+performRequestNoBody reqMethod req reqHost manager =

177+ void $ performRequest reqMethod req reqHost manager

178178

179179catchConnectionError :: IO a -> IO (Either ServantError a)

180180catchConnectionError action =

servant-client/test/Servant/ClientSpec.hs+9−10

@@ -226,15 +226,14 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

226226 C.responseBody response `shouldBe` body

227227 C.responseStatus response `shouldBe` ok200

228228

229− it "Servant.API.Raw on failure" $ \(_, baseUrl) -> do

229+ it "Servant.API.Raw should return a Left in case of failure" $ do

230230 let getRawFailure = getNth (Proxy :: Proxy 11) $ client api baseUrl manager

231231 res <- runExceptT (getRawFailure methodGet)

232232 case res of

233− Left e -> assertFailure $ show e

234− Right (code, body, ct, _, response) -> do

235− (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")

236− C.responseBody response `shouldBe` body

237− C.responseStatus response `shouldBe` badRequest400

233+ Right _ -> assertFailure "expected Left, but got Right"

234+ Left e -> do

235+ Servant.Client.responseStatus e `shouldBe` status400

236+ Servant.Client.responseBody e `shouldBe` "rawFailure"

238237

239238 it "Returns headers appropriately" $ \(_, baseUrl) -> do

240239 let getRespHeaders = getNth (Proxy :: Proxy 13) $ client api baseUrl manager

@@ -349,14 +348,14 @@ pathGen = fmap NonEmpty path

349348class GetNth (n :: Nat) a b | n a -> b where

350349 getNth :: Proxy n -> a -> b

351350

352−instance

351+instance

353352#if MIN_VERSION_base(4,8,0)

354353 {-# OVERLAPPING #-}

355354#endif

356355 GetNth 0 (x :<|> y) x where

357356 getNth _ (x :<|> _) = x

358357

359−instance

358+instance

360359#if MIN_VERSION_base(4,8,0)

361360 {-# OVERLAPPING #-}

362361#endif

@@ -366,14 +365,14 @@ instance

366365class GetLast a b | a -> b where

367366 getLast :: a -> b

368367

369−instance

368+instance

370369#if MIN_VERSION_base(4,8,0)

371370 {-# OVERLAPPING #-}

372371#endif

373372 (GetLast b c) => GetLast (a :<|> b) c where

374373 getLast (_ :<|> b) = getLast b

375374

376−instance

375+instance

377376#if MIN_VERSION_base(4,8,0)

378377 {-# OVERLAPPING #-}

379378#endif