c2a06bc · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

More generous acceptable status codes for servant-client

c2a06bcJulian K. Arni11 years ago

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

compare with master

unifiedsplit

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

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

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

132 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

134

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

136−-- HTTP header.

137instance

135instance

138#if MIN_VERSION_base(4,8,0)

136#if MIN_VERSION_base(4,8,0)

139 {-# OVERLAPPING #-}

137 {-# OVERLAPPING #-}

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

141 HasClient (Delete cts ()) where

139 HasClient (Delete cts ()) where

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

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

143 clientWithRoute Proxy req baseurl manager =

141 clientWithRoute Proxy req baseurl manager =

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

142+ void $ performRequestNoBody H.methodDelete req baseurl manager

145

143

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

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

147-- corresponding headers.

145-- corresponding headers.

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

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

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

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

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

155 clientWithRoute Proxy req baseurl manager = do

153 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

157 return $ Headers { getResponse = resp

155 return $ Headers { getResponse = resp

158 , getHeadersHList = buildHeadersTo hdrs

156 , getHeadersHList = buildHeadersTo hdrs

159 }

157 }

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

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

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

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

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

171 clientWithRoute Proxy req baseurl manager =

169 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

173

171

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

175−-- HTTP status.

176instance

172instance

177#if MIN_VERSION_base(4,8,0)

173#if MIN_VERSION_base(4,8,0)

178 {-# OVERLAPPING #-}

174 {-# OVERLAPPING #-}

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

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

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

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

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

182 clientWithRoute Proxy req baseurl manager =

178 clientWithRoute Proxy req baseurl manager =

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

179+ performRequestNoBody H.methodGet req baseurl manager

184

180

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

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

186-- corresponding headers.

182-- corresponding headers.

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

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

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

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

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

194 clientWithRoute Proxy req baseurl manager = do

190 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

196 return $ Headers { getResponse = resp

192 return $ Headers { getResponse = resp

197 , getHeadersHList = buildHeadersTo hdrs

193 , getHeadersHList = buildHeadersTo hdrs

198 }

194 }

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

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

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

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

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

253 clientWithRoute Proxy req baseurl manager =

249 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

255

251

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

257−-- HTTP header.

258instance

252instance

259#if MIN_VERSION_base(4,8,0)

253#if MIN_VERSION_base(4,8,0)

260 {-# OVERLAPPING #-}

254 {-# OVERLAPPING #-}

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

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

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

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

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

264 clientWithRoute Proxy req baseurl manager =

258 clientWithRoute Proxy req baseurl manager =

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

259+ void $ performRequestNoBody H.methodPost req baseurl manager

266

260

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

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

268-- corresponding headers.

262-- corresponding headers.

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

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

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

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

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

276 clientWithRoute Proxy req baseurl manager = do

270 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

278 return $ Headers { getResponse = resp

272 return $ Headers { getResponse = resp

279 , getHeadersHList = buildHeadersTo hdrs

273 , getHeadersHList = buildHeadersTo hdrs

280 }

274 }

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

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

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

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

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

292 clientWithRoute Proxy req baseurl manager =

286 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

294

288

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

296−-- HTTP header.

297instance

289instance

298#if MIN_VERSION_base(4,8,0)

290#if MIN_VERSION_base(4,8,0)

299 {-# OVERLAPPING #-}

291 {-# OVERLAPPING #-}

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

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

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

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

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

303 clientWithRoute Proxy req baseurl manager =

295 clientWithRoute Proxy req baseurl manager =

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

296+ void $ performRequestNoBody H.methodPut req baseurl manager

305

297

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

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

307-- corresponding headers.

299-- corresponding headers.

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

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

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

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

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

315 clientWithRoute Proxy req baseurl manager= do

307 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

317 return $ Headers { getResponse = resp

309 return $ Headers { getResponse = resp

318 , getHeadersHList = buildHeadersTo hdrs

310 , getHeadersHList = buildHeadersTo hdrs

319 }

311 }

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

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

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

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

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

331 clientWithRoute Proxy req baseurl manager =

323 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

333

325

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

335−-- HTTP header.

336instance

326instance

337#if MIN_VERSION_base(4,8,0)

327#if MIN_VERSION_base(4,8,0)

338 {-# OVERLAPPING #-}

328 {-# OVERLAPPING #-}

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

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

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

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

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

342 clientWithRoute Proxy req baseurl manager =

332 clientWithRoute Proxy req baseurl manager =

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

333+ void $ performRequestNoBody H.methodPatch req baseurl manager

344

334

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

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

346-- corresponding headers.

336-- corresponding headers.

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

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

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

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

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

354 clientWithRoute Proxy req baseurl manager = do

344 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

356 return $ Headers { getResponse = resp

346 return $ Headers { getResponse = resp

357 , getHeadersHList = buildHeadersTo hdrs

347 , getHeadersHList = buildHeadersTo hdrs

358 }

348 }

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

623

613

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

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

625 clientWithRoute Proxy req baseurl manager httpMethod = do

615 clientWithRoute Proxy req baseurl manager httpMethod = do

626− performRequest httpMethod req (const True) baseurl manager

616+ performRequest httpMethod req baseurl manager

627

617

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

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

629-- the corresponding querying function will automatically take

619-- the corresponding querying function will automatically take

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

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

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

132

133

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

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

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

136 , [HTTP.Header], Response ByteString)

137−performRequest reqMethod req isWantedStatus reqHost manager = do

137+performRequest reqMethod req reqHost manager = do

138 partialRequest <- liftIO $ reqToRequest req reqHost

139

140 let request = partialRequest { Client.method = reqMethod

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

156 Just t -> case parseAccept t of

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

158 Just t' -> pure t'

159− unless (isWantedStatus status_code) $

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

160 throwE $ FailureResponse status ct body

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

162

163

164performRequestCT :: MimeUnrender ct result =>

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

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

166−performRequestCT ct reqMethod req wantedStatus reqHost manager = do

166+performRequestCT ct reqMethod req reqHost manager = do

167 let acceptCT = contentType ct

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

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

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

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

171 case mimeUnrender ct respBody of

172 Left err -> throwE $ DecodeFailure err respCT respBody

173 Right val -> return (hrds, val)

174

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

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

176−performRequestNoBody reqMethod req wantedStatus reqHost manager =

176+performRequestNoBody reqMethod req reqHost manager =

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

177+ void $ performRequest reqMethod req reqHost manager

178

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

180catchConnectionError action =

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

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

226 C.responseBody response `shouldBe` body

227 C.responseStatus response `shouldBe` ok200

228

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

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

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

231 res <- runExceptT (getRawFailure methodGet)

232 case res of

233− Left e -> assertFailure $ show e

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

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

234+ Left e -> do

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

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

236− C.responseBody response `shouldBe` body

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

237− C.responseStatus response `shouldBe` badRequest400

238

237

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

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

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

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

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

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

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

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

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

351

350

352−instance

351+instance

353#if MIN_VERSION_base(4,8,0)

352#if MIN_VERSION_base(4,8,0)

354 {-# OVERLAPPING #-}

353 {-# OVERLAPPING #-}

355#endif

354#endif

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

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

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

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

358

357

359−instance

358+instance

360#if MIN_VERSION_base(4,8,0)

359#if MIN_VERSION_base(4,8,0)

361 {-# OVERLAPPING #-}

360 {-# OVERLAPPING #-}

362#endif

361#endif

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

366class GetLast a b | a -> b where

365class GetLast a b | a -> b where

367 getLast :: a -> b

366 getLast :: a -> b

368

367

369−instance

368+instance

370#if MIN_VERSION_base(4,8,0)

369#if MIN_VERSION_base(4,8,0)

371 {-# OVERLAPPING #-}

370 {-# OVERLAPPING #-}

372#endif

371#endif

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

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

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

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

375

374

376−instance

375+instance

377#if MIN_VERSION_base(4,8,0)

376#if MIN_VERSION_base(4,8,0)

378 {-# OVERLAPPING #-}

377 {-# OVERLAPPING #-}

379#endif

378#endif