diff --git a/changelog.d/1569 b/changelog.d/1569 new file mode 100644 index 00000000..47585f6c --- /dev/null +++ b/changelog.d/1569 @@ -0,0 +1,13 @@ +synopsis: Encode captures using toEncodedUrlPiece +prs: #1569 +issues: #1511 + +description: { +The `servant-client` library now makes direct use of `toEncodedUrlPiece` from `ToHttpApiData` +to encode captured values when building the request path. It gives user freedom to implement +URL-encoding however they need. + +Previous behavior was to use `toUrlPiece` and URL-encode its output using `toEncodedUrlPiece` +from the `Text` instance of `ToHttpApiData`. The issue with this approach is that +`ToHttpApiData Text` is overly zealous and also encodes characters, such as `*`, which are perfectly valid in a URL. +} diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 351c87b9..fe2a15f8 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -208,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = (toUrlPiece val) + where p = toEncodedUrlPiece val hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm (Proxy :: Proxy api) f (cl a) @@ -243,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) clientWithRoute pm (Proxy :: Proxy sublayout) (foldl' (flip appendToPath) req ps) - where ps = map (toUrlPiece) vals + where ps = map toEncodedUrlPiece vals hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) @@ -740,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = pack $ symbolVal (Proxy :: Proxy path) + where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index babe878b..431b1f07 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Request.hs @@ -34,6 +34,8 @@ import Data.Bifunctor import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault) import qualified Data.ByteString as BS +import Data.ByteString.Builder + (Builder) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import qualified Data.Sequence as Seq @@ -112,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where rnfB Nothing = () rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt -type Request = RequestF RequestBody Builder.Builder +type Request = RequestF RequestBody Builder -- | The request body. R replica of the @http-client@ @RequestBody@. data RequestBody @@ -145,9 +147,10 @@ defaultRequest = Request -- | Append extra path to the request being constructed. -- -appendToPath :: Text -> Request -> Request +-- Warning: This function assumes that the path fragment is already URL-encoded. +appendToPath :: Builder -> Request -> Request appendToPath p req - = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } + = req { requestPath = requestPath req <> "/" <> p } -- | Append a query parameter to the request being constructed. -- diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index e8f8424a..b548c40f 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -160,6 +160,7 @@ type Api = WithStatus 301 Text] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] :<|> NamedRoutes RecordRoutes + :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text api :: Proxy Api api = Proxy @@ -214,7 +215,8 @@ getRoot :<|> EmptyClient :<|> uverbGetSuccessOrRedirect :<|> uverbGetCreated - :<|> recordRoutes = client api + :<|> recordRoutes + :<|> captureVerbatim = client api server :: Application server = serve api ( @@ -259,6 +261,7 @@ server = serve api ( { something = pure ["foo", "bar", "pweet"] } } + :<|> pure . decodeUtf8 . unVerbatim ) -- * api for testing failures @@ -370,3 +373,12 @@ instance ToHttpApiData UrlEncodedByteString where instance FromHttpApiData UrlEncodedByteString where parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8 + +newtype Verbatim = Verbatim { unVerbatim :: ByteString } + +instance ToHttpApiData Verbatim where + toEncodedUrlPiece = byteString . unVerbatim + toUrlPiece = decodeUtf8 . unVerbatim + +instance FromHttpApiData Verbatim where + parseUrlPiece = pure . Verbatim . encodeUtf8 diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index 4b5e00df..b5e25bb9 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -36,6 +36,8 @@ import Data.Maybe import Data.Monoid () import Data.Text (Text) +import Data.Text.Encoding + (encodeUtf8) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Test.Hspec @@ -196,3 +198,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do case eitherResponse of Left clientError -> fail $ show clientError Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol) + + it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do + let textOrig = "*" + eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right textBack -> textBack `shouldBe` textOrig