@@ -105,16 +105,35 @@ appendQueryParameters newParams r = setQueryString (existing ++ newQuery) r wher
105
105
existing = NT. parseQuery $ queryString r
106
106
newQuery = NT. simpleQueryToQuery $ fmap (\ (KeyValuePair k v) -> (T. encodeUtf8 . A. toText $ k, T. encodeUtf8 v)) newParams
107
107
108
+ resetContentTypeIfOverridden :: Request -> Request -> Request
109
+ resetContentTypeIfOverridden old new =
110
+ if (not $ null (getRequestHeader " Content-Type" old))
111
+ then (setRequestHeader
112
+ " Content-Type"
113
+ (getRequestHeader " Content-Type" old)
114
+ new)
115
+ else new
116
+
117
+
118
+ -- | Sets the payload based on the provided payload type. If a custom
119
+ -- "Content-Type" header is provided, it will be preserved
108
120
setPayload :: Maybe Payload -> Request -> Request
109
121
-- TODO - for backwards compatability, empty requests will set an empty json
110
122
-- payload. Given that we support multiple content types, this funtionality
111
123
-- isn't exactly correct anymore. This behavior should be considered
112
124
-- deprecated and will be updated with the next major version release of
113
125
-- curl-runnings.
114
- setPayload Nothing = setRequestBodyJSON emptyObject
115
- setPayload (Just (JSON v)) = setRequestBodyJSON v
116
- setPayload (Just (URLEncoded (KeyValuePairs xs))) = setRequestBodyURLEncoded $ kvpairs xs where
117
- kvpairs = fmap (\ (KeyValuePair k v) -> (T. encodeUtf8 . A. toText $ k, T. encodeUtf8 v))
126
+ setPayload Nothing req =
127
+ resetContentTypeIfOverridden req . setRequestBodyJSON emptyObject $ req
128
+ setPayload (Just (JSON v)) req =
129
+ resetContentTypeIfOverridden req . (setRequestBodyJSON v) $ req
130
+ setPayload (Just (URLEncoded (KeyValuePairs xs))) req =
131
+ resetContentTypeIfOverridden req . (setRequestBodyURLEncoded $ kvpairs xs) $
132
+ req
133
+ where
134
+ kvpairs =
135
+ fmap
136
+ (\ (KeyValuePair k v) -> (T. encodeUtf8 . A. toText $ k, T. encodeUtf8 v))
118
137
119
138
-- | Run a single test case, and returns the result. IO is needed here since this method is responsible
120
139
-- for actually curling the test case endpoint and parsing the result.
@@ -140,8 +159,8 @@ runCase state@(CurlRunningsState _ _ _ tlsCheckType) curlCase = do
140
159
manager <- newManager noVerifyTlsManagerSettings
141
160
142
161
let ! request =
143
- setRequestHeaders (toHTTPHeaders interpolatedHeaders) .
144
162
setPayload interpolatedData .
163
+ setRequestHeaders (toHTTPHeaders interpolatedHeaders) .
145
164
appendQueryParameters interpolatedQueryParams .
146
165
(if tlsCheckType == DoTLSCheck then id else (setRequestManager manager)) $
147
166
initReq { method = B8S. pack . show $ requestMethod curlCase
0 commit comments