Skip to content

Commit 0f9cc7e

Browse files
pcapriottipcapriotti
authored
Add response header support to UVerb (#1420)
* Use type wrapped in Headers h to generate response This avoids having to define MimeRender instances for Headers.
1 parent 0cb2d60 commit 0f9cc7e

File tree

7 files changed

+114
-27
lines changed

7 files changed

+114
-27
lines changed

‎servant-client-core/src/Servant/Client/Core/HasClient.hs

Lines changed: 28 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -75,7 +75,7 @@ import Servant.API
7575
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
7676
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
7777
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
78-
Verb, WithNamedContext, contentType, getHeadersHList,
78+
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
7979
getResponse, toQueryParam, toUrlPiece)
8080
import Servant.API.ContentTypes
8181
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
@@ -318,6 +318,25 @@ instance {-# OVERLAPPING #-}
318318
data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
319319
deriving (Eq, Show)
320320

321+
class UnrenderResponse (cts :: [*]) (a :: *) where
322+
unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
323+
-> [Either (MediaType, String) a]
324+
325+
instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
326+
unrenderResponse _ body = map parse . allMimeUnrender
327+
where parse (mediaType, parser) = left ((,) mediaType) (parser body)
328+
329+
instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
330+
=> UnrenderResponse cts (Headers h a) where
331+
unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
332+
where
333+
setHeaders :: a -> Headers h a
334+
setHeaders x = Headers x (buildHeadersTo (toList hs))
335+
336+
instance {-# OVERLAPPING #-} UnrenderResponse cts a
337+
=> UnrenderResponse cts (WithStatus n a) where
338+
unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
339+
321340
instance {-# OVERLAPPING #-}
322341
( RunClient m,
323342
contentTypes ~ (contentType ': otherContentTypes),
@@ -326,7 +345,7 @@ instance {-# OVERLAPPING #-}
326345
as ~ (a ': as'),
327346
AllMime contentTypes,
328347
ReflectMethod method,
329-
All (AllMimeUnrender contentTypes) as,
348+
All (UnrenderResponse contentTypes) as,
330349
All HasStatus as, HasStatuses as',
331350
Unique (Statuses as)
332351
) =>
@@ -349,7 +368,8 @@ instance {-# OVERLAPPING #-}
349368

350369
let status = responseStatusCode response
351370
body = responseBody response
352-
res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body
371+
headers = responseHeaders response
372+
res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
353373
case res of
354374
Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
355375
Right x -> return x
@@ -370,13 +390,14 @@ instance {-# OVERLAPPING #-}
370390
-- | Given a list of types, parses the given response body as each type
371391
mimeUnrenders ::
372392
forall cts xs.
373-
All (AllMimeUnrender cts) xs =>
393+
All (UnrenderResponse cts) xs =>
374394
Proxy cts ->
395+
Seq.Seq H.Header ->
375396
BL.ByteString ->
376397
NP ([] :.: Either (MediaType, String)) xs
377-
mimeUnrenders ctp body = cpure_NP
378-
(Proxy @(AllMimeUnrender cts))
379-
(Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)
398+
mimeUnrenders ctp headers body = cpure_NP
399+
(Proxy @(UnrenderResponse cts))
400+
(Comp . unrenderResponse headers body $ ctp)
380401

381402
hoistClientMonad _ _ nt s = nt s
382403

‎servant-client/test/Servant/ClientTestUtils.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Data.Char
3232
(chr, isPrint)
3333
import Data.Monoid ()
3434
import Data.Proxy
35+
import Data.SOP
3536
import Data.Text
3637
(Text)
3738
import qualified Data.Text as Text
@@ -121,6 +122,7 @@ type Api =
121122
ReqBody '[JSON] [(String, [Rational])] :>
122123
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
123124
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
125+
:<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]
124126
:<|> "deleteContentType" :> DeleteNoContent
125127
:<|> "redirectWithCookie" :> Raw
126128
:<|> "empty" :> EmptyAPI
@@ -150,6 +152,7 @@ getRawFailure :: HTTP.Method -> ClientM Response
150152
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
151153
-> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
152154
getRespHeaders :: ClientM (Headers TestHeaders Bool)
155+
getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])
153156
getDeleteContentType :: ClientM NoContent
154157
getRedirectWithCookie :: HTTP.Method -> ClientM Response
155158
uverbGetSuccessOrRedirect :: Bool
@@ -172,6 +175,7 @@ getRoot
172175
:<|> getRawFailure
173176
:<|> getMultiple
174177
:<|> getRespHeaders
178+
:<|> getUVerbRespHeaders
175179
:<|> getDeleteContentType
176180
:<|> getRedirectWithCookie
177181
:<|> EmptyClient
@@ -198,6 +202,7 @@ server = serve api (
198202
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
199203
:<|> (\ a b c d -> return (a, b, c, d))
200204
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
205+
:<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)
201206
:<|> return NoContent
202207
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
203208
:<|> emptyServer

‎servant-client/test/Servant/SuccessSpec.hs

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Data.Foldable
3232
import Data.Maybe
3333
(listToMaybe)
3434
import Data.Monoid ()
35+
import Data.SOP (NS (..), I (..))
3536
import Data.Text
3637
(Text)
3738
import qualified Network.HTTP.Client as C
@@ -129,6 +130,14 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
129130
Left e -> assertFailure $ show e
130131
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
131132

133+
it "Returns headers on UVerb requests" $ \(_, baseUrl) -> do
134+
res <- runClient getUVerbRespHeaders baseUrl
135+
case res of
136+
Left e -> assertFailure $ show e
137+
Right (Z (I (WithStatus val))) ->
138+
getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
139+
Right (S _) -> assertFailure "expected first alternative of union"
140+
132141
it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
133142
mgr <- C.newManager C.defaultManagerSettings
134143
cj <- atomically . newTVar $ C.createCookieJar []

‎servant-server/servant-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -147,6 +147,7 @@ test-suite spec
147147
, safe
148148
, servant
149149
, servant-server
150+
, sop-core
150151
, string-conversions
151152
, text
152153
, transformers

‎servant-server/src/Servant/Server/UVerb.hs

Lines changed: 39 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -22,15 +22,17 @@ module Servant.Server.UVerb
2222
)
2323
where
2424

25+
import qualified Data.ByteString as B
2526
import Data.Proxy (Proxy (Proxy))
2627
import Data.SOP (I (I))
2728
import Data.SOP.Constraint (All, And)
2829
import Data.String.Conversions (LBS, cs)
29-
import Network.HTTP.Types (Status, hContentType)
30-
import Network.Wai (responseLBS)
30+
import Network.HTTP.Types (Status, HeaderName, hContentType)
31+
import Network.Wai (responseLBS, Request)
3132
import Servant.API (ReflectMethod, reflectMethod)
3233
import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
33-
import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)
34+
import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
35+
import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
3436
import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
3537

3638

@@ -43,13 +45,38 @@ respond ::
4345
f (Union xs)
4446
respond = pure . inject . I
4547

46-
-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.
47-
type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus
48+
class IsServerResource (cts :: [*]) a where
49+
resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
50+
resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
51+
52+
instance {-# OVERLAPPABLE #-} AllCTRender cts a
53+
=> IsServerResource cts a where
54+
resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
55+
resourceHeaders _ _ = []
56+
57+
instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
58+
=> IsServerResource cts (Headers h a) where
59+
resourceResponse request p res = resourceResponse request p (getResponse res)
60+
resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
61+
62+
instance {-# OVERLAPPING #-} IsServerResource cts a
63+
=> IsServerResource cts (WithStatus n a) where
64+
resourceResponse request p (WithStatus x) = resourceResponse request p x
65+
resourceHeaders cts (WithStatus x) = resourceHeaders cts x
66+
67+
encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
68+
=> Request -> Proxy cts -> a
69+
-> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
70+
encodeResource request cts res = (statusOf (Proxy @a),
71+
resourceResponse request cts res,
72+
resourceHeaders cts res)
73+
74+
type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
4875

4976
instance
5077
( ReflectMethod method,
5178
AllMime contentTypes,
52-
All (IsServerResource contentTypes) as,
79+
All (IsServerResourceWithStatus contentTypes) as,
5380
Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
5481
-- without; client is a bit of a corner case, because it dispatches
5582
-- the parser based on the status code. with this uniqueness
@@ -77,20 +104,13 @@ instance
77104
action
78105
`addMethodCheck` methodCheck method request
79106
`addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
80-
mkProxy :: a -> Proxy a
81-
mkProxy _ = Proxy
82107

83108
runAction action' env request cont $ \(output :: Union as) -> do
84-
let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))
85-
encodeResource res =
86-
( statusOf $ mkProxy res,
87-
handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res
88-
)
89-
pickResource :: Union as -> (Status, Maybe (LBS, LBS))
90-
pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource
91-
109+
let cts = Proxy @contentTypes
110+
pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
111+
pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
92112
case pickResource output of
93-
(_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
94-
(status, Just (contentT, body)) ->
113+
(_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
114+
(status, Just (contentT, body), headers) ->
95115
let bdy = if allowedMethodHead method request then "" else body
96-
in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy
116+
in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

‎servant-server/test/Servant/ServerSpec.hs

Lines changed: 29 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,8 @@ import Data.Maybe
2828
(fromMaybe)
2929
import Data.Proxy
3030
(Proxy (Proxy))
31+
import Data.SOP
32+
(I (..), NS (..))
3133
import Data.String
3234
(fromString)
3335
import Data.String.Conversions
@@ -53,7 +55,7 @@ import Servant.API
5355
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
5456
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
5557
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
56-
UVerb, Union, Verb, addHeader)
58+
UVerb, Union, Verb, WithStatus (..), addHeader)
5759
import Servant.Server
5860
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
5961
emptyServer, err401, err403, err404, respond, serve,
@@ -98,6 +100,7 @@ spec = do
98100
rawSpec
99101
alternativeSpec
100102
responseHeadersSpec
103+
uverbResponseHeadersSpec
101104
miscCombinatorSpec
102105
basicAuthSpec
103106
genAuthSpec
@@ -684,6 +687,31 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
684687
THW.request method "" [(hAccept, "crazy/mime")] ""
685688
`shouldRespondWith` 406
686689

690+
-- }}}
691+
------------------------------------------------------------------------------
692+
-- * uverbResponseHeaderSpec {{{
693+
------------------------------------------------------------------------------
694+
type UVerbHeaderResponse = '[
695+
WithStatus 200 (Headers '[Header "H1" Int] String),
696+
WithStatus 404 String ]
697+
698+
type UVerbResponseHeadersApi =
699+
Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
700+
701+
uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
702+
uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"
703+
uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"
704+
705+
uverbResponseHeadersSpec :: Spec
706+
uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
707+
with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do
708+
709+
it "includes the headers in the response" $
710+
THW.request methodGet "/true" [] ""
711+
`shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]
712+
, matchStatus = 200
713+
}
714+
687715
-- }}}
688716
------------------------------------------------------------------------------
689717
-- * miscCombinatorSpec {{{

‎servant/src/Servant/API/ResponseHeaders.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,9 @@ import Web.HttpApiData
5151

5252
import Prelude ()
5353
import Prelude.Compat
54+
import Servant.API.ContentTypes
55+
(JSON, PlainText, FormUrlEncoded, OctetStream,
56+
MimeRender(..))
5457
import Servant.API.Header
5558
(Header)
5659

0 commit comments

Comments
 (0)