git.iko.soy/servant
on master help sign in
Addresses problems with URL encodings

This changes the way URL encoding for query parameters is handled, making it possible to correctly encode arbitrary binary data into query parameter values. Closes #1418

commit9666f1956b95e23d65276909e1f06353828cb4c0 authorIan Shipman <ics@gambolingpangolin.com> dateFri 27 Aug 2021, 17:57 (5 years ago) parent48bc247
5 files changed+60−12
compare with master
unifiedsplit
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
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