26b01f0 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #1432 from GambolingPangolin/fixes-1418

26b01f0Caroline GAUDREAU5 years ago

changelog.d/1432new file+9

compare with master

unifiedsplit

@@ -0,0 +1,9 @@

1+synopsis: Fixes encoding of URL parameters in servant-client

2+prs: #1432

3+issues: #1418

4+description: {

5+Some applications use query parameters to pass arbitrary (non-unicode) binary

6+data. This change modifies how servant-client handles query parameters, so

7+that application developers can use `ToHttpApiData` to marshal binary data into

8+query parameters.

9+}

servant-client-core/src/Servant/Client/Core/HasClient.hs+9−3

@@ -33,6 +33,9 @@ import Control.Arrow

33 (left, (+++))

34import Control.Monad

35 (unless)

36+import qualified Data.ByteString as BS

37+import Data.ByteString.Builder

38+ (toLazyByteString)

36import qualified Data.ByteString.Lazy as BL

39import qualified Data.ByteString.Lazy as BL

37import Data.Either

40import Data.Either

38 (partitionEithers)

41 (partitionEithers)

@@ -76,7 +79,7 @@ import Servant.API

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

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

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

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

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

81 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,

79− getResponse, toQueryParam, toUrlPiece)

82+ getResponse, toEncodedUrlPiece, toUrlPiece)

80import Servant.API.ContentTypes

83import Servant.API.ContentTypes

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

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

82import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

85import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

@@ -554,7 +557,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

554 (Proxy :: Proxy mods) add (maybe req add) mparam

557 (Proxy :: Proxy mods) add (maybe req add) mparam

555 where

558 where

556 add :: a -> Request

559 add :: a -> Request

557− add param = appendToQueryString pname (Just $ toQueryParam param) req

560+ add param = appendToQueryString pname (Just $ encodeQueryParam param) req

558

561

559 pname :: Text

562 pname :: Text

560 pname = pack $ symbolVal (Proxy :: Proxy sym)

563 pname = pack $ symbolVal (Proxy :: Proxy sym)

@@ -562,6 +565,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

562 hoistClientMonad pm _ f cl = \arg ->

565 hoistClientMonad pm _ f cl = \arg ->

563 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

566 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

564

567

568+encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString

569+encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece

570+

565-- | If you use a 'QueryParams' in one of your endpoints in your API,

571-- | If you use a 'QueryParams' in one of your endpoints in your API,

566-- the corresponding querying function will automatically take

572-- the corresponding querying function will automatically take

567-- an additional argument, a list of values of the type specified

573-- an additional argument, a list of values of the type specified

@@ -603,7 +609,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

603 )

609 )

604

610

605 where pname = pack $ symbolVal (Proxy :: Proxy sym)

611 where pname = pack $ symbolVal (Proxy :: Proxy sym)

606− paramlist' = map (Just . toQueryParam) paramlist

612+ paramlist' = map (Just . encodeQueryParam) paramlist

607

613

608 hoistClientMonad pm _ f cl = \as ->

614 hoistClientMonad pm _ f cl = \as ->

609 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

615 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

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

@@ -145,13 +145,13 @@ appendToPath :: Text -> Request -> Request

145appendToPath p req

146 = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

147

148−appendToQueryString :: Text -- ^ param name

148+appendToQueryString :: Text -- ^ param name

149− -> Maybe Text -- ^ param value

149+ -> Maybe BS.ByteString -- ^ param value

150 -> Request

151 -> Request

152appendToQueryString pname pvalue req

153 = req { requestQueryString = requestQueryString req

154− Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}

154+ Seq.|> (encodeUtf8 pname, pvalue)}

155

156addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

157addHeader name val req

servant-client/src/Servant/Client/Internal/HttpClient.hs+10−3

@@ -46,7 +46,7 @@ import qualified Data.ByteString.Lazy as BSL

46import Data.Either

47 (either)

48import Data.Foldable

49− (toList)

49+ (foldl',toList)

50import Data.Functor.Alt

51 (Alt (..))

52import Data.Maybe

@@ -63,7 +63,7 @@ import GHC.Generics

63import Network.HTTP.Media

64 (renderHeader)

65import Network.HTTP.Types

66− (hContentType, renderQuery, statusCode, Status)

66+ (hContentType, renderQuery, statusCode, urlEncode, Status)

67import Servant.Client.Core

69import qualified Network.HTTP.Client as Client

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

238 , Client.path = BSL.toStrict

239 $ fromString (baseUrlPath burl)

240 <> toLazyByteString (requestPath r)

241− , Client.queryString = renderQuery True . toList $ requestQueryString r

241+ , Client.queryString = buildQueryString . toList $ requestQueryString r

242 , Client.requestHeaders =

243 maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

244 , Client.requestBody = body

@@ -289,6 +289,13 @@ defaultMakeClientRequest burl r = Client.defaultRequest

289 Http -> False

290 Https -> True

291

292+ -- Query string builder which does not do any encoding

293+ buildQueryString = ("?" <>) . foldl' addQueryParam mempty

294+

295+ addQueryParam qs (k, v) =

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

297+

298+

292catchConnectionError :: IO a -> IO (Either ClientError a)

299catchConnectionError :: IO a -> IO (Either ClientError a)

293catchConnectionError action =

300catchConnectionError action =

294 catch (Right <$> action) $ \e ->

301 catch (Right <$> action) $ \e ->

servant-client/test/Servant/ClientTestUtils.hs+30−2

@@ -24,9 +24,15 @@ import Prelude.Compat

25import Control.Concurrent

26 (ThreadId, forkIO, killThread)

27+import Control.Monad

28+ (join)

27import Control.Monad.Error.Class

29import Control.Monad.Error.Class

28 (throwError)

30 (throwError)

29import Data.Aeson

31import Data.Aeson

32+import Data.ByteString

33+ (ByteString)

34+import Data.ByteString.Builder

35+ (byteString)

30import qualified Data.ByteString.Lazy as LazyByteString

36import qualified Data.ByteString.Lazy as LazyByteString

31import Data.Char

37import Data.Char

32 (chr, isPrint)

38 (chr, isPrint)

@@ -54,10 +60,10 @@ import Web.FormUrlEncoded

54import Servant.API

60import Servant.API

55 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,

61 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,

56 BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,

62 BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,

57− EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers,

63+ EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers,

58 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),

64 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),

59 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,

65 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,

60− QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union,

66+ QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,

61 WithStatus (WithStatus), addHeader)

67 WithStatus (WithStatus), addHeader)

62import Servant.Client

68import Servant.Client

63import qualified Servant.Client.Core.Auth as Auth

69import qualified Servant.Client.Core.Auth as Auth

@@ -109,6 +115,10 @@ type Api =

109 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

115 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

110 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

116 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

111 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

117 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

118+ -- This endpoint makes use of a 'Raw' server because it is not currently

119+ -- possible to handle arbitrary binary query param values with

120+ -- @servant-server@

121+ :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw

112 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

122 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

113 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool

123 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool

114 :<|> "fragment" :> Fragment String :> Get '[JSON] Person

124 :<|> "fragment" :> Fragment String :> Get '[JSON] Person

@@ -143,6 +153,7 @@ getCapture :: String -> ClientM Person

143getCaptureAll :: [String] -> ClientM [Person]

153getCaptureAll :: [String] -> ClientM [Person]

144getBody :: Person -> ClientM Person

154getBody :: Person -> ClientM Person

145getQueryParam :: Maybe String -> ClientM Person

155getQueryParam :: Maybe String -> ClientM Person

156+getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response

146getQueryParams :: [String] -> ClientM [Person]

157getQueryParams :: [String] -> ClientM [Person]

147getQueryFlag :: Bool -> ClientM Bool

158getQueryFlag :: Bool -> ClientM Bool

148getFragment :: ClientM Person

159getFragment :: ClientM Person

@@ -167,6 +178,7 @@ getRoot

167 :<|> getCaptureAll

178 :<|> getCaptureAll

168 :<|> getBody

179 :<|> getBody

169 :<|> getQueryParam

180 :<|> getQueryParam

181+ :<|> getQueryParamBinary

170 :<|> getQueryParams

182 :<|> getQueryParams

171 :<|> getQueryFlag

183 :<|> getQueryFlag

172 :<|> getFragment

184 :<|> getFragment

@@ -194,6 +206,13 @@ server = serve api (

194 Just "alice" -> return alice

206 Just "alice" -> return alice

195 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []

207 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []

196 Nothing -> throwError $ ServerError 400 "missing parameter" "" [])

208 Nothing -> throwError $ ServerError 400 "missing parameter" "" [])

209+ :<|> const (Tagged $ \request respond ->

210+ respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload")

211+ (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict)

212+ . join

213+ . lookup "payload"

214+ $ Wai.queryString request

215+ )

197 :<|> (\ names -> return (zipWith Person names [0..]))

216 :<|> (\ names -> return (zipWith Person names [0..]))

198 :<|> return

217 :<|> return

199 :<|> return alice

218 :<|> return alice

@@ -310,3 +329,12 @@ pathGen = fmap NonEmpty path

310 filter (not . (`elem` ("?%[]/#;" :: String))) $

329 filter (not . (`elem` ("?%[]/#;" :: String))) $

311 filter isPrint $

330 filter isPrint $

312 map chr [0..127]

331 map chr [0..127]

332+

333+newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString }

334+

335+instance ToHttpApiData UrlEncodedByteString where

336+ toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString

337+ toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString

338+

339+instance FromHttpApiData UrlEncodedByteString where

340+ parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8

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

@@ -22,11 +22,13 @@ import Prelude ()

22import Prelude.Compat

24import Control.Arrow

25− (left)

25+ ((+++), left)

26import Control.Concurrent.STM

27 (atomically)

28import Control.Concurrent.STM.TVar

29 (newTVar, readTVar)

30+import qualified Data.ByteString as BS

31+import qualified Data.ByteString.Lazy as BL

30import Data.Foldable

32import Data.Foldable

31 (forM_, toList)

33 (forM_, toList)

32import Data.Maybe

34import Data.Maybe

@@ -93,6 +95,11 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

93 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl

95 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl

94 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

96 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

98+ it "Servant.API.QueryParam binary data" $ \(_, baseUrl) -> do

99+ let payload = BS.pack [0, 1, 2, 4, 8, 16, 32, 64, 128]

100+ apiCall = getQueryParamBinary (Just $ UrlEncodedByteString payload) HTTP.methodGet

101+ (show +++ responseBody) <$> runClient apiCall baseUrl `shouldReturn` Right (BL.fromStrict payload)

102+

96 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

103 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

97 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []

104 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []

98 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl

105 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl