0f9cc7e · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Add response header support to UVerb (#1420)

0f9cc7ePaolo Capriotti5 years ago

servant-client-core/src/Servant/Client/Core/HasClient.hs+28−7

compare with master

unifiedsplit

@@ -75,7 +75,7 @@ import Servant.API

75 NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

76 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

77 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

78− Verb, WithNamedContext, contentType, getHeadersHList,

78+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,

79 getResponse, toQueryParam, toUrlPiece)

80import Servant.API.ContentTypes

81 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

@@ -318,6 +318,25 @@ instance {-# OVERLAPPING #-}

318data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus

319 deriving (Eq, Show)

320

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+

321instance {-# OVERLAPPING #-}

340instance {-# OVERLAPPING #-}

322 ( RunClient m,

341 ( RunClient m,

323 contentTypes ~ (contentType ': otherContentTypes),

342 contentTypes ~ (contentType ': otherContentTypes),

@@ -326,7 +345,7 @@ instance {-# OVERLAPPING #-}

326 as ~ (a ': as'),

345 as ~ (a ': as'),

327 AllMime contentTypes,

346 AllMime contentTypes,

328 ReflectMethod method,

347 ReflectMethod method,

329− All (AllMimeUnrender contentTypes) as,

348+ All (UnrenderResponse contentTypes) as,

330 All HasStatus as, HasStatuses as',

349 All HasStatus as, HasStatuses as',

331 Unique (Statuses as)

350 Unique (Statuses as)

332 ) =>

351 ) =>

@@ -349,7 +368,8 @@ instance {-# OVERLAPPING #-}

349

368

350 let status = responseStatusCode response

369 let status = responseStatusCode response

351 body = responseBody response

370 body = responseBody response

371+ headers = responseHeaders response

352− res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body

372+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body

353 case res of

373 case res of

354 Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response

374 Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response

355 Right x -> return x

375 Right x -> return x

@@ -370,13 +390,14 @@ instance {-# OVERLAPPING #-}

370 -- | Given a list of types, parses the given response body as each type

390 -- | Given a list of types, parses the given response body as each type

371 mimeUnrenders ::

391 mimeUnrenders ::

372 forall cts xs.

392 forall cts xs.

373− All (AllMimeUnrender cts) xs =>

393+ All (UnrenderResponse cts) xs =>

374 Proxy cts ->

394 Proxy cts ->

395+ Seq.Seq H.Header ->

375 BL.ByteString ->

396 BL.ByteString ->

376 NP ([] :.: Either (MediaType, String)) xs

397 NP ([] :.: Either (MediaType, String)) xs

377− mimeUnrenders ctp body = cpure_NP

398+ mimeUnrenders ctp headers body = cpure_NP

378− (Proxy @(AllMimeUnrender cts))

399+ (Proxy @(UnrenderResponse cts))

379− (Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)

400+ (Comp . unrenderResponse headers body $ ctp)

380

401

381 hoistClientMonad _ _ nt s = nt s

402 hoistClientMonad _ _ nt s = nt s

382

403

servant-client/test/Servant/ClientTestUtils.hs+5

@@ -32,6 +32,7 @@ import Data.Char

32 (chr, isPrint)

33import Data.Monoid ()

34import Data.Proxy

35+import Data.SOP

35import Data.Text

36import Data.Text

36 (Text)

37 (Text)

37import qualified Data.Text as Text

38import qualified Data.Text as Text

@@ -121,6 +122,7 @@ type Api =

121 ReqBody '[JSON] [(String, [Rational])] :>

122 ReqBody '[JSON] [(String, [Rational])] :>

122 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

123 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

123 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

124 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

125+ :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]

124 :<|> "deleteContentType" :> DeleteNoContent

126 :<|> "deleteContentType" :> DeleteNoContent

125 :<|> "redirectWithCookie" :> Raw

127 :<|> "redirectWithCookie" :> Raw

126 :<|> "empty" :> EmptyAPI

128 :<|> "empty" :> EmptyAPI

@@ -150,6 +152,7 @@ getRawFailure :: HTTP.Method -> ClientM Response

150getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

152getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

151 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

153 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

152getRespHeaders :: ClientM (Headers TestHeaders Bool)

154getRespHeaders :: ClientM (Headers TestHeaders Bool)

155+getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])

153getDeleteContentType :: ClientM NoContent

156getDeleteContentType :: ClientM NoContent

154getRedirectWithCookie :: HTTP.Method -> ClientM Response

157getRedirectWithCookie :: HTTP.Method -> ClientM Response

155uverbGetSuccessOrRedirect :: Bool

158uverbGetSuccessOrRedirect :: Bool

@@ -172,6 +175,7 @@ getRoot

172 :<|> getRawFailure

175 :<|> getRawFailure

173 :<|> getMultiple

176 :<|> getMultiple

174 :<|> getRespHeaders

177 :<|> getRespHeaders

178+ :<|> getUVerbRespHeaders

175 :<|> getDeleteContentType

179 :<|> getDeleteContentType

176 :<|> getRedirectWithCookie

180 :<|> getRedirectWithCookie

177 :<|> EmptyClient

181 :<|> EmptyClient

@@ -198,6 +202,7 @@ server = serve api (

198 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

202 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

199 :<|> (\ a b c d -> return (a, b, c, d))

203 :<|> (\ a b c d -> return (a, b, c, d))

200 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

204 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

205+ :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)

201 :<|> return NoContent

206 :<|> return NoContent

202 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")

207 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")

203 :<|> emptyServer

208 :<|> emptyServer

servant-client/test/Servant/SuccessSpec.hs+9

@@ -32,6 +32,7 @@ import Data.Foldable

32import Data.Maybe

33 (listToMaybe)

34import Data.Monoid ()

35+import Data.SOP (NS (..), I (..))

35import Data.Text

36import Data.Text

36 (Text)

37 (Text)

37import qualified Network.HTTP.Client as C

38import qualified Network.HTTP.Client as C

@@ -129,6 +130,14 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

129 Left e -> assertFailure $ show e

130 Left e -> assertFailure $ show e

130 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

131 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

131

132

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+

132 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do

141 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do

133 mgr <- C.newManager C.defaultManagerSettings

142 mgr <- C.newManager C.defaultManagerSettings

134 cj <- atomically . newTVar $ C.createCookieJar []

143 cj <- atomically . newTVar $ C.createCookieJar []

servant-server/servant-server.cabal+1

@@ -147,6 +147,7 @@ test-suite spec

147 , safe

148 , servant

149 , servant-server

150+ , sop-core

150 , string-conversions

151 , string-conversions

151 , text

152 , text

152 , transformers

153 , transformers

servant-server/src/Servant/Server/UVerb.hs+39−19

@@ -22,15 +22,17 @@ module Servant.Server.UVerb

22 )

23where

25+import qualified Data.ByteString as B

25import Data.Proxy (Proxy (Proxy))

26import Data.Proxy (Proxy (Proxy))

26import Data.SOP (I (I))

27import Data.SOP (I (I))

27import Data.SOP.Constraint (All, And)

28import Data.SOP.Constraint (All, And)

28import Data.String.Conversions (LBS, cs)

29import Data.String.Conversions (LBS, cs)

29−import Network.HTTP.Types (Status, hContentType)

30+import Network.HTTP.Types (Status, HeaderName, hContentType)

30−import Network.Wai (responseLBS)

31+import Network.Wai (responseLBS, Request)

31import Servant.API (ReflectMethod, reflectMethod)

32import Servant.API (ReflectMethod, reflectMethod)

32import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)

33import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)

34+import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))

33−import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)

35+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)

34import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)

36import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)

@@ -43,13 +45,38 @@ respond ::

43 f (Union xs)

45 f (Union xs)

44respond = pure . inject . I

46respond = pure . inject . I

46−-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.

48+class IsServerResource (cts :: [*]) a where

47−type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus

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

49instance

76instance

50 ( ReflectMethod method,

77 ( ReflectMethod method,

51 AllMime contentTypes,

78 AllMime contentTypes,

52− All (IsServerResource contentTypes) as,

79+ All (IsServerResourceWithStatus contentTypes) as,

53 Unique (Statuses as) -- for consistency with servant-swagger (server would work fine

80 Unique (Statuses as) -- for consistency with servant-swagger (server would work fine

54 -- without; client is a bit of a corner case, because it dispatches

81 -- without; client is a bit of a corner case, because it dispatches

55 -- the parser based on the status code. with this uniqueness

82 -- the parser based on the status code. with this uniqueness

@@ -77,20 +104,13 @@ instance

77 action

104 action

78 `addMethodCheck` methodCheck method request

105 `addMethodCheck` methodCheck method request

79 `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)

106 `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)

80− mkProxy :: a -> Proxy a

81− mkProxy _ = Proxy

107

83 runAction action' env request cont $ \(output :: Union as) -> do

108 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

109+ let cts = Proxy @contentTypes

88− )

89− pickResource :: Union as -> (Status, Maybe (LBS, LBS))

110+ pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

90− pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource

111+ pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)

91−

92 case pickResource output of

112 case pickResource output of

93− (_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

113+ (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

94− (status, Just (contentT, body)) ->

114+ (status, Just (contentT, body), headers) ->

95 let bdy = if allowedMethodHead method request then "" else body

115 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

28 (fromMaybe)

29import Data.Proxy

30 (Proxy (Proxy))

31+import Data.SOP

32+ (I (..), NS (..))

31import Data.String

33import Data.String

32 (fromString)

34 (fromString)

33import Data.String.Conversions

35import Data.String.Conversions

@@ -53,7 +55,7 @@ import Servant.API

53 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

55 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

54 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

56 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

55 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

57 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

56− UVerb, Union, Verb, addHeader)

58+ UVerb, Union, Verb, WithStatus (..), addHeader)

57import Servant.Server

59import Servant.Server

58 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

60 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

59 emptyServer, err401, err403, err404, respond, serve,

61 emptyServer, err401, err403, err404, respond, serve,

@@ -98,6 +100,7 @@ spec = do

98 rawSpec

100 rawSpec

99 alternativeSpec

101 alternativeSpec

100 responseHeadersSpec

102 responseHeadersSpec

103+ uverbResponseHeadersSpec

101 miscCombinatorSpec

104 miscCombinatorSpec

102 basicAuthSpec

105 basicAuthSpec

103 genAuthSpec

106 genAuthSpec

@@ -684,6 +687,31 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

684 THW.request method "" [(hAccept, "crazy/mime")] ""

687 THW.request method "" [(hAccept, "crazy/mime")] ""

685 `shouldRespondWith` 406

688 `shouldRespondWith` 406

686

689

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+

687-- }}}

715-- }}}

688------------------------------------------------------------------------------

716------------------------------------------------------------------------------

689-- * miscCombinatorSpec {{{

717-- * miscCombinatorSpec {{{

servant/src/Servant/API/ResponseHeaders.hs+3

@@ -51,6 +51,9 @@ import Web.HttpApiData

52import Prelude ()

53import Prelude.Compat

54+import Servant.API.ContentTypes

55+ (JSON, PlainText, FormUrlEncoded, OctetStream,

56+ MimeRender(..))

54import Servant.API.Header

57import Servant.API.Header

55 (Header)

58 (Header)