More generous acceptable status codes for servant-client
This commit is contained in:
parent
ad39feb01e
commit
c2a06bc090
3 changed files with 34 additions and 45 deletions
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue