59b5fe6...master · typeable/servant

git.iko.soy/typeable/servant

10 files changed+32−18

since splitsnapshots

unifiedsplit

changelog.d/1589+2 changelog.d/1595+2 doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1 servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+1−5 servant-client-core/src/Servant/Client/Core/Request.hs+4−3 servant-client/src/Servant/Client/Internal/HttpClient.hs+6−5 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+2−2 servant-client/test/Servant/SuccessSpec.hs+2−1 servant/src/Servant/API/ContentTypes.hs+1−1 servant/test/Servant/API/ContentTypesSpec.hs+11

changelog.d/1589new file+2

@@ -0,0 +1,2 @@

1+synopsis: Only include question mark for nonempty query strings

2+prs: 1589

changelog.d/1595new file+2

@@ -0,0 +1,2 @@

1+synopsis: Run ClientEnv's makeClientRequest in IO.

2+prs: #1595

doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1

@@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`

119119to http-client's `Request`, and we can inspect it:

120120

121121```haskell

122− let req' = I.defaultMakeClientRequest burl req

122+ req' <- I.defaultMakeClientRequest burl req

123123 putStrLn $ "Making request: " ++ show req'

124124```

125125

servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+1−5

@@ -31,15 +31,13 @@ library

3131 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

3232 ghc-options: -Wall

3333 build-depends:

34− base >= 4.10 && < 4.16

34+ base >= 4.10 && < 4.17

3535 , text >= 1.2.3.0 && < 2.1

3636 , servant-swagger >= 1.1.5 && < 2

3737 , swagger2 >= 2.2.2 && < 3

3838 , servant >= 0.13 && < 0.20

3939 , servant-auth == 0.4.*

4040 , lens >= 4.16.1 && < 5.2

41− if impl(ghc >= 9)

42− buildable: False

4341 exposed-modules:

4442 Servant.Auth.Swagger

4543 default-language: Haskell2010

@@ -61,8 +59,6 @@ test-suite spec

6159 , servant

6260 , servant-auth

6361 , lens

64− if impl(ghc >= 9)

65− buildable: False

6662

6763 -- test dependencies

6864 build-depends:

servant-client-core/src/Servant/Client/Core/Request.hs+4−3

@@ -51,9 +51,9 @@ import Network.HTTP.Media

5151 (MediaType)

5252import Network.HTTP.Types

5353 (Header, HeaderName, HttpVersion (..), Method, QueryItem,

54− http11, methodGet)

54+ http11, methodGet, urlEncodeBuilder)

5555import Servant.API

56− (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)

56+ (ToHttpApiData, toEncodedUrlPiece, toQueryParam, toHeader, SourceIO)

5757

5858import Servant.Client.Core.Internal (mediaTypeRnf)

5959

@@ -165,7 +165,8 @@ appendToQueryString pname pvalue req

165165-- | Encode a query parameter value.

166166--

167167encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString

168−encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString

169+ . urlEncodeBuilder True . encodeUtf8 . toQueryParam

169170

170171-- | Add header to the request being constructed.

171172--

servant-client/src/Servant/Client/Internal/HttpClient.hs+6−5

@@ -80,7 +80,7 @@ data ClientEnv

8080 { manager :: Client.Manager

8181 , baseUrl :: BaseUrl

8282 , cookieJar :: Maybe (TVar Client.CookieJar)

83− , makeClientRequest :: BaseUrl -> Request -> Client.Request

83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request

8484 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'

8585 -- Note that:

8686 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,

@@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

162162performRequest :: Maybe [Status] -> Request -> ClientM Response

163163performRequest acceptStatus req = do

164164 ClientEnv m burl cookieJar' createClientRequest <- ask

165− let clientRequest = createClientRequest burl req

165+ clientRequest <- liftIO $ createClientRequest burl req

166166 request <- case cookieJar' of

167167 Nothing -> pure clientRequest

168168 Just cj -> liftIO $ do

@@ -229,8 +229,8 @@ clientResponseToResponse f r = Response

229229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'

230230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'

231231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'

232−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request

233−defaultMakeClientRequest burl r = Client.defaultRequest

232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request

233+defaultMakeClientRequest burl r = return Client.defaultRequest

234234 { Client.method = requestMethod r

235235 , Client.host = fromString $ baseUrlHost burl

236236 , Client.port = baseUrlPort burl

@@ -289,7 +289,8 @@ defaultMakeClientRequest burl r = Client.defaultRequest

289289 Https -> True

290290

291291 -- Query string builder which does not do any encoding

292− buildQueryString = ("?" <>) . foldl' addQueryParam mempty

292+ buildQueryString [] = mempty

293+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps

293294

294295 addQueryParam qs (k, v) =

295296 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+2−2

@@ -140,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response

140140performRequest acceptStatus req = do

141141 -- TODO: should use Client.withResponse here too

142142 ClientEnv m burl cookieJar' createClientRequest <- ask

143− let clientRequest = createClientRequest burl req

143+ clientRequest <- liftIO $ createClientRequest burl req

144144 request <- case cookieJar' of

145145 Nothing -> pure clientRequest

146146 Just cj -> liftIO $ do

@@ -177,7 +177,7 @@ performWithStreamingRequest req k = do

177177 m <- asks manager

178178 burl <- asks baseUrl

179179 createClientRequest <- asks makeClientRequest

180− let request = createClientRequest burl req

180+ request <- liftIO $ createClientRequest burl req

181181 ClientM $ lift $ lift $ Codensity $ \k1 ->

182182 Client.withResponse request m $ \res -> do

183183 let status = Client.responseStatus res

servant-client/test/Servant/SuccessSpec.hs+2−1

@@ -162,7 +162,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

162162 mgr <- C.newManager C.defaultManagerSettings

163163 -- In proper situation, extra headers should probably be visible in API type.

164164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe

165− let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }

165+ let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })

166+ (defaultMakeClientRequest url r)

166167 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

167168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

168169 case res of

servant/src/Servant/API/ContentTypes.hs+1−1

@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}

295295-- then this would be taken care of. However there is no more specific instance

296296-- between that and 'MimeRender JSON a', so we do this instead

297297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

298− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp

299299 where

300300 pctyp = Proxy :: Proxy ctyp

301301

servant/test/Servant/API/ContentTypesSpec.hs+11

@@ -33,6 +33,8 @@ import Data.String.Conversions

3333import qualified Data.Text as TextS

3434import qualified Data.Text.Encoding as TextSE

3535import qualified Data.Text.Lazy as TextL

36+import Control.Exception

37+ (evaluate)

3638import GHC.Generics

3739import Test.Hspec

3840import Test.QuickCheck

@@ -78,6 +80,15 @@ spec = describe "Servant.API.ContentTypes" $ do

7880 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

7981 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

8082

83+ describe "The NoContent Content-Type type" $ do

84+ let p = Proxy :: Proxy '[JSON]

85+

86+ it "does not render any content" $

87+ allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))

88+

89+ it "evaluates the NoContent value" $

90+ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall

91+

8192 describe "The PlainText Content-Type type" $ do

8293 let p = Proxy :: Proxy PlainText

8394