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

Implement header support for UVerb client

Browse Source
This commit is contained in:
Paolo Capriotti 2021-05-07 16:13:01 +02:00
parent 2027831ccf
commit a4e15fe75f
3 changed files with 42 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
servant-client-core/src/Servant/Client/Core/HasClient.hs
View File

@ -75,7 +75,7 @@ import Servant.API
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
Verb, WithNamedContext, contentType, getHeadersHList,
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
getResponse, toQueryParam, toUrlPiece)
import Servant.API.ContentTypes
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
@ -318,6 +318,25 @@ instance {-# OVERLAPPING #-}
data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
deriving (Eq, Show)
class UnrenderResponse (cts :: [*]) (a :: *) where
unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
-> [Either (MediaType, String) a]
instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
unrenderResponse _ body = map parse . allMimeUnrender
where parse (mediaType, parser) = left ((,) mediaType) (parser body)
instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
=> UnrenderResponse cts (Headers h a) where
unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
where
setHeaders :: a -> Headers h a
setHeaders x = Headers x (buildHeadersTo (toList hs))
instance {-# OVERLAPPING #-} UnrenderResponse cts a
=> UnrenderResponse cts (WithStatus n a) where
unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
instance {-# OVERLAPPING #-}
( RunClient m,
contentTypes ~ (contentType ': otherContentTypes),
@ -326,7 +345,7 @@ instance {-# OVERLAPPING #-}
as ~ (a ': as'),
AllMime contentTypes,
ReflectMethod method,
All (AllMimeUnrender contentTypes) as,
All (UnrenderResponse contentTypes) as,
All HasStatus as, HasStatuses as',
Unique (Statuses as)
) =>
@ -349,7 +368,8 @@ instance {-# OVERLAPPING #-}
let status = responseStatusCode response
body = responseBody response
res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body
headers = responseHeaders response
res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
case res of
Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
Right x -> return x
@ -370,13 +390,14 @@ instance {-# OVERLAPPING #-}
-- | Given a list of types, parses the given response body as each type
mimeUnrenders ::
forall cts xs.
All (AllMimeUnrender cts) xs =>
All (UnrenderResponse cts) xs =>
Proxy cts ->
Seq.Seq H.Header ->
BL.ByteString ->
NP ([] :.: Either (MediaType, String)) xs
mimeUnrenders ctp body = cpure_NP
(Proxy @(AllMimeUnrender cts))
(Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)
mimeUnrenders ctp headers body = cpure_NP
(Proxy @(UnrenderResponse cts))
(Comp . unrenderResponse headers body $ ctp)
hoistClientMonad _ _ nt s = nt s

5
servant-client/test/Servant/ClientTestUtils.hs
View File

@ -32,6 +32,7 @@ import Data.Char
(chr, isPrint)
import Data.Monoid ()
import Data.Proxy
import Data.SOP
import Data.Text
(Text)
import qualified Data.Text as Text
@ -121,6 +122,7 @@ type Api =
ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
:<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]
:<|> "deleteContentType" :> DeleteNoContent
:<|> "redirectWithCookie" :> Raw
:<|> "empty" :> EmptyAPI
@ -150,6 +152,7 @@ getRawFailure :: HTTP.Method -> ClientM Response
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: ClientM (Headers TestHeaders Bool)
getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])
getDeleteContentType :: ClientM NoContent
getRedirectWithCookie :: HTTP.Method -> ClientM Response
uverbGetSuccessOrRedirect :: Bool
@ -172,6 +175,7 @@ getRoot
:<|> getRawFailure
:<|> getMultiple
:<|> getRespHeaders
:<|> getUVerbRespHeaders
:<|> getDeleteContentType
:<|> getRedirectWithCookie
:<|> EmptyClient
@ -198,6 +202,7 @@ server = serve api (
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
:<|> emptyServer

9
servant-client/test/Servant/SuccessSpec.hs
View File

@ -32,6 +32,7 @@ import Data.Foldable
import Data.Maybe
(listToMaybe)
import Data.Monoid ()
import Data.SOP (NS (..), I (..))
import Data.Text
(Text)
import qualified Network.HTTP.Client as C
@ -129,6 +130,14 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
it "Returns headers on UVerb requests" $ \(_, baseUrl) -> do
res <- runClient getUVerbRespHeaders baseUrl
case res of
Left e -> assertFailure $ show e
Right (Z (I (WithStatus val))) ->
getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
Right (S _) -> assertFailure "expected first alternative of union"
it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
mgr <- C.newManager C.defaultManagerSettings
cj <- atomically . newTVar $ C.createCookieJar []