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
This commit is contained in:
Edsko de Vries 2017-02-07 16:51:56 +01:00
parent 8a3ecb2ebc
commit 507f021919

View file

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