git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1432 from GambolingPangolin/fixes-1418

Addresses problem with URL encodings

commit26b01f03f2f77b0e416c707c5f7192056affcf1d authorCaroline GAUDREAU <caroline.gaudreau@gmail.com> dateSun 24 Oct 2021, 09:24 (5 years ago) parentabc53b5d5e439e
6 files changed+69−12
compare with master
unifiedsplit
changelog.d/1432+9 servant-client-core/src/Servant/Client/Core/HasClient.hs+9−3 servant-client-core/src/Servant/Client/Core/Request.hs+3−3 servant-client/src/Servant/Client/Internal/HttpClient.hs+10−3 servant-client/test/Servant/ClientTestUtils.hs+30−2 servant-client/test/Servant/SuccessSpec.hs+8−1
changelog.d/1432new file+9
@@ -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
3333 (left, (+++))
3434import Control.Monad
3535 (unless)
36+import qualified Data.ByteString as BS
37+import Data.ByteString.Builder
38+ (toLazyByteString)
3639import qualified Data.ByteString.Lazy as BL
3740import Data.Either
3841 (partitionEithers)
@@ -76,7 +79,7 @@ import Servant.API
7679 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
7780 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
7881 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
79− getResponse, toQueryParam, toUrlPiece)
82+ getResponse, toEncodedUrlPiece, toUrlPiece)
8083import Servant.API.ContentTypes
8184 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
8285import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
@@ -554,7 +557,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
554557 (Proxy :: Proxy mods) add (maybe req add) mparam
555558 where
556559 add :: a -> Request
557− add param = appendToQueryString pname (Just $ toQueryParam param) req
560+ add param = appendToQueryString pname (Just $ encodeQueryParam param) req
558561
559562 pname :: Text
560563 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -562,6 +565,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
562565 hoistClientMonad pm _ f cl = \arg ->
563566 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
564567
568+encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString
569+encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece
570+
565571-- | If you use a 'QueryParams' in one of your endpoints in your API,
566572-- the corresponding querying function will automatically take
567573-- an additional argument, a list of values of the type specified
@@ -603,7 +609,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
603609 )
604610
605611 where pname = pack $ symbolVal (Proxy :: Proxy sym)
606− paramlist' = map (Just . toQueryParam) paramlist
612+ paramlist' = map (Just . encodeQueryParam) paramlist
607613
608614 hoistClientMonad pm _ f cl = \as ->
609615 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
145145appendToPath p req
146146 = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
147147
148−appendToQueryString :: Text -- ^ param name
149− -> Maybe Text -- ^ param value
148+appendToQueryString :: Text -- ^ param name
149+ -> Maybe BS.ByteString -- ^ param value
150150 -> Request
151151 -> Request
152152appendToQueryString pname pvalue req
153153 = req { requestQueryString = requestQueryString req
154− Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
154+ Seq.|> (encodeUtf8 pname, pvalue)}
155155
156156addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
157157addHeader name val req
servant-client/src/Servant/Client/Internal/HttpClient.hs+10−3
@@ -46,7 +46,7 @@ import qualified Data.ByteString.Lazy as BSL
4646import Data.Either
4747 (either)
4848import Data.Foldable
49− (toList)
49+ (foldl',toList)
5050import Data.Functor.Alt
5151 (Alt (..))
5252import Data.Maybe
@@ -63,7 +63,7 @@ import GHC.Generics
6363import Network.HTTP.Media
6464 (renderHeader)
6565import Network.HTTP.Types
66− (hContentType, renderQuery, statusCode, Status)
66+ (hContentType, renderQuery, statusCode, urlEncode, Status)
6767import Servant.Client.Core
6868
6969import qualified Network.HTTP.Client as Client
@@ -238,7 +238,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest
238238 , Client.path = BSL.toStrict
239239 $ fromString (baseUrlPath burl)
240240 <> toLazyByteString (requestPath r)
241− , Client.queryString = renderQuery True . toList $ requestQueryString r
241+ , Client.queryString = buildQueryString . toList $ requestQueryString r
242242 , Client.requestHeaders =
243243 maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
244244 , Client.requestBody = body
@@ -289,6 +289,13 @@ defaultMakeClientRequest burl r = Client.defaultRequest
289289 Http -> False
290290 Https -> True
291291
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+
292299catchConnectionError :: IO a -> IO (Either ClientError a)
293300catchConnectionError action =
294301 catch (Right <$> action) $ \e ->
servant-client/test/Servant/ClientTestUtils.hs+30−2
@@ -24,9 +24,15 @@ import Prelude.Compat
2424
2525import Control.Concurrent
2626 (ThreadId, forkIO, killThread)
27+import Control.Monad
28+ (join)
2729import Control.Monad.Error.Class
2830 (throwError)
2931import Data.Aeson
32+import Data.ByteString
33+ (ByteString)
34+import Data.ByteString.Builder
35+ (byteString)
3036import qualified Data.ByteString.Lazy as LazyByteString
3137import Data.Char
3238 (chr, isPrint)
@@ -54,10 +60,10 @@ import Web.FormUrlEncoded
5460import Servant.API
5561 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
5662 BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
57− EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers,
63+ EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers,
5864 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
5965 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
60− QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union,
66+ QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
6167 WithStatus (WithStatus), addHeader)
6268import Servant.Client
6369import qualified Servant.Client.Core.Auth as Auth
@@ -109,6 +115,10 @@ type Api =
109115 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
110116 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
111117 :<|> "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
112122 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
113123 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
114124 :<|> "fragment" :> Fragment String :> Get '[JSON] Person
@@ -143,6 +153,7 @@ getCapture :: String -> ClientM Person
143153getCaptureAll :: [String] -> ClientM [Person]
144154getBody :: Person -> ClientM Person
145155getQueryParam :: Maybe String -> ClientM Person
156+getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response
146157getQueryParams :: [String] -> ClientM [Person]
147158getQueryFlag :: Bool -> ClientM Bool
148159getFragment :: ClientM Person
@@ -167,6 +178,7 @@ getRoot
167178 :<|> getCaptureAll
168179 :<|> getBody
169180 :<|> getQueryParam
181+ :<|> getQueryParamBinary
170182 :<|> getQueryParams
171183 :<|> getQueryFlag
172184 :<|> getFragment
@@ -194,6 +206,13 @@ server = serve api (
194206 Just "alice" -> return alice
195207 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
196208 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+ )
197216 :<|> (\ names -> return (zipWith Person names [0..]))
198217 :<|> return
199218 :<|> return alice
@@ -310,3 +329,12 @@ pathGen = fmap NonEmpty path
310329 filter (not . (`elem` ("?%[]/#;" :: String))) $
311330 filter isPrint $
312331 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 ()
2222import Prelude.Compat
2323
2424import Control.Arrow
25− (left)
25+ ((+++), left)
2626import Control.Concurrent.STM
2727 (atomically)
2828import Control.Concurrent.STM.TVar
2929 (newTVar, readTVar)
30+import qualified Data.ByteString as BS
31+import qualified Data.ByteString.Lazy as BL
3032import Data.Foldable
3133 (forM_, toList)
3234import Data.Maybe
@@ -93,6 +95,11 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
9395 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
9496 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
9597
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+
96103 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
97104 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
98105 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl