Merge pull request #1569 from haskell-servant/url-encoding

Use toEncodedUrlPiece directly when encoding captures

Author: Gaël Deest

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.
+}

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
 

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.
 --

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

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