eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Make sure path components get escaped

Browse source 
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
1 changed files with 7 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
servant-client/src/Servant/Common/Req.hs
View file

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