From 507f0219191ba220bb8c1f5256f2322502f6a12d Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Tue, 7 Feb 2017 16:51:56 +0100
Subject: [PATCH] Make sure path components get escaped

The derived client for an API containing `Capture` has a bug: it does not
escape characters, so that if the string is "a/b", the URL becomes
`".../a/b/..."` instead of `".../a%2Fb/..."`, causing the corresponding servant
server to return a 404.

This relies on https://github.com/fizruk/http-api-data/pull/47
---
 servant-client/src/Servant/Common/Req.hs | 12 +++++++-----
 1 file changed, 7 insertions(+), 5 deletions(-)

diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs
index f3de9687..d4795eb5 100644
--- a/servant-client/src/Servant/Common/Req.hs
+++ b/servant-client/src/Servant/Common/Req.hs
@@ -27,6 +27,7 @@ import Control.Monad.Base (MonadBase (..))
 import Control.Monad.IO.Class ()
 import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl (..))
+import qualified Data.ByteString.Builder as BS
 import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
 import Data.String
 import Data.String.Conversions (cs)
@@ -86,7 +87,7 @@ instance Eq ServantError where
 instance Exception ServantError
 
 data Req = Req
-  { reqPath   :: String
+  { reqPath   :: BS.Builder
   , qs        :: QueryText
   , reqBody   :: Maybe (RequestBody, MediaType)
   , reqAccept :: [MediaType]
@@ -98,7 +99,7 @@ defReq = Req "" [] Nothing [] []
 
 appendToPath :: String -> Req -> Req
 appendToPath p req =
-  req { reqPath = reqPath req ++ "/" ++ p }
+  req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p }
 
 appendToQueryString :: Text       -- ^ param name
                     -> Maybe Text -- ^ param value
@@ -151,8 +152,9 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
                                          , uriRegName = reqHost
                                          , uriPort = ":" ++ show reqPort
                                          }
-                             , uriPath = path ++ reqPath req
+                             , uriPath = fullPath
                              }
+        fullPath = path ++ cs (BS.toLazyByteString (reqPath req))
 
         setrqb r = case reqBody req of
                      Nothing -> r
@@ -224,7 +226,7 @@ runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
 runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
 
 
-performRequest :: Method -> Req 
+performRequest :: Method -> Req
                -> ClientM ( Int, ByteString, MediaType
                           , [HTTP.Header], Response ByteString)
 performRequest reqMethod req = do
@@ -253,7 +255,7 @@ performRequest reqMethod req = do
         throwError $ FailureResponse status ct body
       return (status_code, body, ct, hdrs, response)
 
-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req 
+performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
     -> ClientM ([HTTP.Header], result)
 performRequestCT ct reqMethod req = do
   let acceptCTS = contentTypes ct