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:
parent
8a3ecb2ebc
commit
507f021919
1 changed files with 7 additions and 5 deletions
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue