From c2a06bc0902ef88baab66b8d229855f66e2a0f17 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 7 Oct 2015 15:24:52 +0200 Subject: [PATCH] More generous acceptable status codes for servant-client --- servant-client/src/Servant/Client.hs | 42 +++++++++-------------- servant-client/src/Servant/Common/Req.hs | 18 +++++----- servant-client/test/Servant/ClientSpec.hs | 19 +++++----- 3 files changed, 34 insertions(+), 45 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 94e9bd5e..6a7b89c2 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -130,10 +130,8 @@ instance (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where type Client (Delete cts' a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager --- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content --- HTTP header. instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} @@ -141,7 +139,7 @@ instance HasClient (Delete cts ()) where type Client (Delete cts ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodDelete req [204] baseurl manager + void $ performRequestNoBody H.methodDelete req baseurl manager -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. @@ -153,7 +151,7 @@ instance ) => HasClient (Delete cts' (Headers ls a)) where type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -169,10 +167,8 @@ instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where type Client (Get (ct ': cts) result) = ExceptT ServantError IO result clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager --- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content --- HTTP status. instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} @@ -180,7 +176,7 @@ instance HasClient (Get (ct ': cts) ()) where type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = - performRequestNoBody H.methodGet req [204] baseurl manager + performRequestNoBody H.methodGet req baseurl manager -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. @@ -192,7 +188,7 @@ instance ) => HasClient (Get (ct ': cts) (Headers ls a)) where type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -251,10 +247,8 @@ instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where type Client (Post (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager --- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content --- HTTP header. instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} @@ -262,7 +256,7 @@ instance HasClient (Post (ct ': cts) ()) where type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPost req [204] baseurl manager + void $ performRequestNoBody H.methodPost req baseurl manager -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. @@ -274,7 +268,7 @@ instance ) => HasClient (Post (ct ': cts) (Headers ls a)) where type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -290,10 +284,8 @@ instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where type Client (Put (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager --- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content --- HTTP header. instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} @@ -301,7 +293,7 @@ instance HasClient (Put (ct ': cts) ()) where type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPut req [204] baseurl manager + void $ performRequestNoBody H.methodPut req baseurl manager -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. @@ -313,7 +305,7 @@ instance ) => HasClient (Put (ct ': cts) (Headers ls a)) where type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager= do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -329,10 +321,8 @@ instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager --- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content --- HTTP header. instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} @@ -340,7 +330,7 @@ instance HasClient (Patch (ct ': cts) ()) where type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPatch req [204] baseurl manager + void $ performRequestNoBody H.methodPatch req baseurl manager -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. @@ -352,7 +342,7 @@ instance ) => HasClient (Patch (ct ': cts) (Headers ls a)) where type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -623,7 +613,7 @@ instance HasClient Raw where clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw clientWithRoute Proxy req baseurl manager httpMethod = do - performRequest httpMethod req (const True) baseurl manager + performRequest httpMethod req baseurl manager -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 592043be..4a7c1cba 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -131,10 +131,10 @@ displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> Manager +performRequest :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) -performRequest reqMethod req isWantedStatus reqHost manager = do +performRequest reqMethod req reqHost manager = do partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod @@ -156,25 +156,25 @@ performRequest reqMethod req isWantedStatus reqHost manager = do Just t -> case parseAccept t of Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' - unless (isWantedStatus status_code) $ + unless (status_code >= 200 && status_code < 300) $ throwE $ FailureResponse status ct body return (status_code, body, ct, hrds, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result) -performRequestCT ct reqMethod req wantedStatus reqHost manager = do + Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result) +performRequestCT ct reqMethod req reqHost manager = do let acceptCT = contentType ct (_status, respBody, respCT, hrds, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost manager + performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwE $ DecodeFailure err respCT respBody Right val -> return (hrds, val) -performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO () -performRequestNoBody reqMethod req wantedStatus reqHost manager = - void $ performRequest reqMethod req (`elem` wantedStatus) reqHost manager +performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO () +performRequestNoBody reqMethod req reqHost manager = + void $ performRequest reqMethod req reqHost manager catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 344f42ef..3441cea6 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -226,15 +226,14 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` ok200 - it "Servant.API.Raw on failure" $ \(_, baseUrl) -> do + it "Servant.API.Raw should return a Left in case of failure" $ do let getRawFailure = getNth (Proxy :: Proxy 11) $ client api baseUrl manager res <- runExceptT (getRawFailure methodGet) case res of - Left e -> assertFailure $ show e - Right (code, body, ct, _, response) -> do - (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") - C.responseBody response `shouldBe` body - C.responseStatus response `shouldBe` badRequest400 + Right _ -> assertFailure "expected Left, but got Right" + Left e -> do + Servant.Client.responseStatus e `shouldBe` status400 + Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \(_, baseUrl) -> do let getRespHeaders = getNth (Proxy :: Proxy 13) $ client api baseUrl manager @@ -349,14 +348,14 @@ pathGen = fmap NonEmpty path class GetNth (n :: Nat) a b | n a -> b where getNth :: Proxy n -> a -> b -instance +instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif GetNth 0 (x :<|> y) x where getNth _ (x :<|> _) = x -instance +instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif @@ -366,14 +365,14 @@ instance class GetLast a b | a -> b where getLast :: a -> b -instance +instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif (GetLast b c) => GetLast (a :<|> b) c where getLast (_ :<|> b) = getLast b -instance +instance #if MIN_VERSION_base(4,8,0) {-# OVERLAPPING #-} #endif