eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

More generous acceptable status codes for servant-client

Browse source
This commit is contained in:
Julian K. Arni 2015-10-07 15:24:52 +02:00
parent ad39feb01e
commit c2a06bc090
3 changed files with 34 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
servant-client/src/Servant/Client.hs
View file

@ -130,10 +130,8 @@ instance
(MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
type Client (Delete cts' a) = ExceptT ServantError IO a type Client (Delete cts' a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = 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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
@ -141,7 +139,7 @@ instance
HasClient (Delete cts ()) where HasClient (Delete cts ()) where
type Client (Delete cts ()) = ExceptT ServantError IO () type Client (Delete cts ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = 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 -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -153,7 +151,7 @@ instance
) => HasClient (Delete cts' (Headers ls a)) where ) => HasClient (Delete cts' (Headers ls a)) where
type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -169,10 +167,8 @@ instance
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client (Get (ct ': cts) result) = ExceptT ServantError IO result type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
clientWithRoute Proxy req baseurl manager = 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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
@ -180,7 +176,7 @@ instance
HasClient (Get (ct ': cts) ()) where HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = 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 -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -192,7 +188,7 @@ instance
) => HasClient (Get (ct ': cts) (Headers ls a)) where ) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -251,10 +247,8 @@ instance
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client (Post (ct ': cts) a) = ExceptT ServantError IO a type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = 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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
@ -262,7 +256,7 @@ instance
HasClient (Post (ct ': cts) ()) where HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = 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 -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -274,7 +268,7 @@ instance
) => HasClient (Post (ct ': cts) (Headers ls a)) where ) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -290,10 +284,8 @@ instance
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client (Put (ct ': cts) a) = ExceptT ServantError IO a type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = 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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
@ -301,7 +293,7 @@ instance
HasClient (Put (ct ': cts) ()) where HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = 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 -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -313,7 +305,7 @@ instance
) => HasClient (Put (ct ': cts) (Headers ls a)) where ) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager= do 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -329,10 +321,8 @@ instance
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager = 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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
@ -340,7 +330,7 @@ instance
HasClient (Patch (ct ': cts) ()) where HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = 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 -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -352,7 +342,7 @@ instance
) => HasClient (Patch (ct ': cts) (Headers ls a)) where ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -623,7 +613,7 @@ instance HasClient Raw where
clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
clientWithRoute Proxy req baseurl manager httpMethod = do 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, -- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take

18
servant-client/src/Servant/Common/Req.hs
View file

@ -131,10 +131,10 @@ displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> Manager performRequest :: Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO ( Int, ByteString, MediaType -> ExceptT ServantError IO ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString) , [HTTP.Header], Response ByteString)
performRequest reqMethod req isWantedStatus reqHost manager = do performRequest reqMethod req reqHost manager = do
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod let request = partialRequest { Client.method = reqMethod
@ -156,25 +156,25 @@ performRequest reqMethod req isWantedStatus reqHost manager = do
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t' Just t' -> pure t'
unless (isWantedStatus status_code) $ unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body throwE $ FailureResponse status ct body
return (status_code, body, ct, hrds, response) return (status_code, body, ct, hrds, response)
performRequestCT :: MimeUnrender ct result => performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result) Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req wantedStatus reqHost manager = do performRequestCT ct reqMethod req reqHost manager = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hrds, _response) <- (_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 unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hrds, val) Right val -> return (hrds, val)
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO () performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost manager = performRequestNoBody reqMethod req reqHost manager =
void $ performRequest reqMethod req (`elem` wantedStatus) reqHost manager void $ performRequest reqMethod req reqHost manager
catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action = catchConnectionError action =

19
servant-client/test/Servant/ClientSpec.hs
View file

@ -226,15 +226,14 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
C.responseBody response `shouldBe` body C.responseBody response `shouldBe` body
C.responseStatus response `shouldBe` ok200 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 let getRawFailure = getNth (Proxy :: Proxy 11) $ client api baseUrl manager
res <- runExceptT (getRawFailure methodGet) res <- runExceptT (getRawFailure methodGet)
case res of case res of
Left e -> assertFailure $ show e Right _ -> assertFailure "expected Left, but got Right"
Right (code, body, ct, _, response) -> do Left e -> do
(code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") Servant.Client.responseStatus e `shouldBe` status400
C.responseBody response `shouldBe` body Servant.Client.responseBody e `shouldBe` "rawFailure"
C.responseStatus response `shouldBe` badRequest400
it "Returns headers appropriately" $ \(_, baseUrl) -> do it "Returns headers appropriately" $ \(_, baseUrl) -> do
let getRespHeaders = getNth (Proxy :: Proxy 13) $ client api baseUrl manager 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 class GetNth (n :: Nat) a b | n a -> b where
getNth :: Proxy n -> a -> b getNth :: Proxy n -> a -> b
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
GetNth 0 (x :<|> y) x where GetNth 0 (x :<|> y) x where
getNth _ (x :<|> _) = x getNth _ (x :<|> _) = x
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
@ -366,14 +365,14 @@ instance
class GetLast a b | a -> b where class GetLast a b | a -> b where
getLast :: a -> b getLast :: a -> b
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
(GetLast b c) => GetLast (a :<|> b) c where (GetLast b c) => GetLast (a :<|> b) c where
getLast (_ :<|> b) = getLast b getLast (_ :<|> b) = getLast b
instance instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif