git.iko.soy/typeable/servant
on master help sign in
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.

commit0f9cc7eeec52f65b90a4bd55811f114ab368b90d authorPaolo Capriotti <paolo@capriotti.io> dateThu 10 Jun 2021, 17:10 (5 years ago) parent0cb2d60
7 files changed+114−27
compare with master
unifiedsplit
servant-client-core/src/Servant/Client/Core/HasClient.hs+28−7 servant-client/test/Servant/ClientTestUtils.hs+5 servant-client/test/Servant/SuccessSpec.hs+9 servant-server/servant-server.cabal+1 servant-server/src/Servant/Server/UVerb.hs+39−19 servant-server/test/Servant/ServerSpec.hs+29−1 servant/src/Servant/API/ResponseHeaders.hs+3
servant-client-core/src/Servant/Client/Core/HasClient.hs+28−7
@@ -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)
8080import Servant.API.ContentTypes
8181 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
@@ -318,6 +318,25 @@ instance {-# OVERLAPPING #-}
318318data 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+
321340instance {-# 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+5
@@ -32,6 +32,7 @@ import Data.Char
3232 (chr, isPrint)
3333import Data.Monoid ()
3434import Data.Proxy
35+import Data.SOP
3536import Data.Text
3637 (Text)
3738import 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
150152getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
151153 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
152154getRespHeaders :: ClientM (Headers TestHeaders Bool)
155+getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])
153156getDeleteContentType :: ClientM NoContent
154157getRedirectWithCookie :: HTTP.Method -> ClientM Response
155158uverbGetSuccessOrRedirect :: 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+9
@@ -32,6 +32,7 @@ import Data.Foldable
3232import Data.Maybe
3333 (listToMaybe)
3434import Data.Monoid ()
35+import Data.SOP (NS (..), I (..))
3536import Data.Text
3637 (Text)
3738import 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+1
@@ -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+39−19
@@ -22,15 +22,17 @@ module Servant.Server.UVerb
2222 )
2323where
2424
25+import qualified Data.ByteString as B
2526import Data.Proxy (Proxy (Proxy))
2627import Data.SOP (I (I))
2728import Data.SOP.Constraint (All, And)
2829import 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)
3132import Servant.API (ReflectMethod, reflectMethod)
3233import 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)
3436import 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)
4446respond = 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
4976instance
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+29−1
@@ -28,6 +28,8 @@ import Data.Maybe
2828 (fromMaybe)
2929import Data.Proxy
3030 (Proxy (Proxy))
31+import Data.SOP
32+ (I (..), NS (..))
3133import Data.String
3234 (fromString)
3335import 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)
5759import 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+3
@@ -51,6 +51,9 @@ import Web.HttpApiData
5151
5252import Prelude ()
5353import Prelude.Compat
54+import Servant.API.ContentTypes
55+ (JSON, PlainText, FormUrlEncoded, OctetStream,
56+ MimeRender(..))
5457import Servant.API.Header
5558 (Header)
5659