Use toEncodedUrlPiece directly when encoding captures

Current implementation of captures uses the `toUrlPiece` method from the
`ToHttpApiData` typeclass, and encodes the resulting `Text` using `toEncodedUrlPiece`
when appending to the request path.

The problem with this approach is that the instance for `Text` percent-encodes
characters that are perfectly valid in URLs, such as `*`.

This patch makes direct use of `toEncodedUrlPiece`, which lets users implement
encoding according to their needs.

Closes #1511
This commit is contained in:
Gaël Deest 2022-03-21 17:29:23 +01:00
parent af3dde1b1d
commit 658217b021
4 changed files with 31 additions and 7 deletions

View file

@ -208,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req) (appendToPath p req)
where p = (toUrlPiece val) where p = toEncodedUrlPiece val
hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm _ f cl = \a ->
hoistClientMonad pm (Proxy :: Proxy api) 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) clientWithRoute pm (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps) (foldl' (flip appendToPath) req ps)
where ps = map (toUrlPiece) vals where ps = map toEncodedUrlPiece vals
hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm _ f cl = \as ->
hoistClientMonad pm (Proxy :: Proxy sublayout) 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) clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req) (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 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

View file

@ -34,6 +34,8 @@ import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
(Bitraversable (..), bifoldMapDefault, bimapDefault) (Bitraversable (..), bifoldMapDefault, bimapDefault)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.ByteString.Builder
(Builder)
import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -112,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
rnfB Nothing = () rnfB Nothing = ()
rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt 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@. -- | The request body. R replica of the @http-client@ @RequestBody@.
data RequestBody data RequestBody
@ -145,9 +147,10 @@ defaultRequest = Request
-- | Append extra path to the request being constructed. -- | 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 appendToPath p req
= req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } = req { requestPath = requestPath req <> "/" <> p }
-- | Append a query parameter to the request being constructed. -- | Append a query parameter to the request being constructed.
-- --

View file

@ -160,6 +160,7 @@ type Api =
WithStatus 301 Text] WithStatus 301 Text]
:<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
:<|> NamedRoutes RecordRoutes :<|> NamedRoutes RecordRoutes
:<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
@ -214,7 +215,8 @@ getRoot
:<|> EmptyClient :<|> EmptyClient
:<|> uverbGetSuccessOrRedirect :<|> uverbGetSuccessOrRedirect
:<|> uverbGetCreated :<|> uverbGetCreated
:<|> recordRoutes = client api :<|> recordRoutes
:<|> captureVerbatim = client api
server :: Application server :: Application
server = serve api ( server = serve api (
@ -259,6 +261,7 @@ server = serve api (
{ something = pure ["foo", "bar", "pweet"] { something = pure ["foo", "bar", "pweet"]
} }
} }
:<|> pure . decodeUtf8 . unVerbatim
) )
-- * api for testing failures -- * api for testing failures
@ -370,3 +373,12 @@ instance ToHttpApiData UrlEncodedByteString where
instance FromHttpApiData UrlEncodedByteString where instance FromHttpApiData UrlEncodedByteString where
parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8 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

View file

@ -36,6 +36,8 @@ import Data.Maybe
import Data.Monoid () import Data.Monoid ()
import Data.Text import Data.Text
(Text) (Text)
import Data.Text.Encoding
(encodeUtf8)
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import Test.Hspec import Test.Hspec
@ -196,3 +198,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
case eitherResponse of case eitherResponse of
Left clientError -> fail $ show clientError Left clientError -> fail $ show clientError
Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol) 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