@@ -24,7 +24,8 @@ import Data.Text.Encoding qualified as T
2424import Data.Text.IO qualified as TIO
2525import Network.HTTP.Client qualified as L
2626import Network.HTTP.Client.MultipartFormData qualified as LM
27−import Network.HTTP.Req
27+import Network.HTTP.Req hiding (req)
28+import Network.HTTP.Req qualified as Req
2829import Network.HTTP.Types qualified as Y
2930import Test.Hspec
3031import Test.QuickCheck
@@ -33,61 +34,74 @@ spec :: Spec
3334spec = do
3435 describe "exception throwing on non-2xx status codes" $
3536 it "throws indeed for non-2xx" $
36− req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
37+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
3738 `shouldThrow` selector404
3839
3940 describe "exception throwing on non-2xx status codes (Req monad)" $
4041 it "throws indeed for non-2xx" $
4142 asIO . runReq defaultHttpConfig $
4243 liftBaseWith $ \run ->
43− run (req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty)
44+ run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty)
4445 `shouldThrow` selector404
4546
4647 describe "response check via httpConfigCheckResponse" $
4748 context "if it's set to always throw" $
4849 it "throws indeed" $
49− blindlyThrowing (req GET httpbun NoReqBody ignoreResponse mempty)
50+ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty)
5051 `shouldThrow` anyException
5152
5253 describe "isStatusCodeException" $
5354 it "extracts non-2xx response" $
54− req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
55+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
5556 `shouldThrow` selector404ByStatusCodeException
5657
58+ describe "receiving user-agent header back" $
59+ it "works" $ do
60+ r <-
61+ req
62+ GET
63+ (httpbin /: "user-agent")
64+ NoReqBody
65+ jsonResponse
66+ (header "user-agent" "Req")
67+ responseBody r
68+ `shouldBe` object
69+ ["user-agent" .= ("Req" :: Text)]
70+ responseStatusCode r `shouldBe` 200
71+ responseStatusMessage r `shouldBe` "OK"
72+
5773 describe "receiving request headers back" $
5874 it "works" $ do
5975 r <-
6076 req
6177 GET
62− (httpbun /: "headers")
78+ (httpbin /: "headers")
6379 NoReqBody
6480 jsonResponse
6581 (header "Foo" "bar" <> header "Baz" "quux")
66− stripFunnyHeaders' (responseBody r)
82+ stripFunnyHeaders (responseBody r)
6783 `shouldBe` object
68− [ "Accept-Encoding" .= ("gzip" :: Text),
69− "Foo" .= ("bar" :: Text),
70− "Baz" .= ("quux" :: Text)
84+ [ "headers"
85+ .= object
86+ [ "Accept-Encoding" .= ("gzip" :: Text),
87+ "Foo" .= ("bar" :: Text),
88+ "Baz" .= ("quux" :: Text)
89+ ]
7190 ]
7291 responseStatusCode r `shouldBe` 200
7392 responseStatusMessage r `shouldBe` "OK"
7493
7594 describe "receiving GET data back" $
7695 it "works" $ do
77− r <- req GET (httpbun /: "get") NoReqBody jsonResponse mempty
96+ r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
7897 (stripFunnyHeaders . stripOrigin) (responseBody r)
7998 `shouldBe` object
8099 [ "args" .= emptyObject,
81− "url" .= ("https://httpbun.org/get" :: Text),
82− "method" .= ("GET" :: Text),
100+ "url" .= ("http://localhost:1234/get" :: Text),
83101 "headers"
84102 .= object
85103 [ "Accept-Encoding" .= ("gzip" :: Text)
86− ],
87− "form" .= emptyObject,
88− "files" .= emptyObject,
89− "data" .= ("" :: Text),
90− "json" .= Null
104+ ]
91105 ]
92106 responseHeader r "Content-Type" `shouldBe` return "application/json"
93107 responseStatusCode r `shouldBe` 200
@@ -97,14 +111,13 @@ spec = do
97111 it "works" $ do
98112 let text = "foo" :: Text
99113 reflected = reflectJSON text
100− r <- req POST (httpbun /: "post") (ReqBodyJson text) jsonResponse mempty
114+ r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty
101115 (stripFunnyHeaders . stripOrigin) (responseBody r)
102116 `shouldBe` object
103117 [ "args" .= emptyObject,
104118 "json" .= text,
105119 "data" .= reflected,
106− "url" .= ("https://httpbun.org/post" :: Text),
107− "method" .= ("POST" :: Text),
120+ "url" .= ("http://localhost:1234/post" :: Text),
108121 "headers"
109122 .= object
110123 [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),
@@ -125,15 +138,14 @@ spec = do
125138 [ LM.partBS "foo" "foo data!",
126139 LM.partBS "bar" "bar data!"
127140 ]
128− r <- req POST (httpbun /: "post") body jsonResponse mempty
141+ r <- req POST (httpbin /: "post") body jsonResponse mempty
129142 let contentType = fromJust (getRequestContentType body)
130143 (stripFunnyHeaders . stripOrigin) (responseBody r)
131144 `shouldBe` object
132145 [ "args" .= emptyObject,
133146 "json" .= Null,
134147 "data" .= ("" :: Text),
135− "url" .= ("https://httpbun.org/post" :: Text),
136− "method" .= ("POST" :: Text),
148+ "url" .= ("http://localhost:1234/post" :: Text),
137149 "headers"
138150 .= object
139151 [ "Content-Type" .= T.decodeUtf8 contentType,
@@ -154,16 +166,15 @@ spec = do
154166 describe "receiving PATCHed file back" $
155167 it "works" $ do
156168 let file :: FilePath
157− file = "httpbun-data/robots.txt"
169+ file = "httpbin-data/robots.txt"
158170 contents <- TIO.readFile file
159− r <- req PATCH (httpbun /: "patch") (ReqBodyFile file) jsonResponse mempty
171+ r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty
160172 (stripFunnyHeaders . stripOrigin) (responseBody r)
161173 `shouldBe` object
162174 [ "args" .= emptyObject,
163175 "json" .= Null,
164176 "data" .= contents,
165− "url" .= ("https://httpbun.org/patch" :: Text),
166− "method" .= ("PATCH" :: Text),
177+ "url" .= ("http://localhost:1234/patch" :: Text),
167178 "headers"
168179 .= object
169180 [ "Accept-Encoding" .= ("gzip" :: Text),
@@ -182,14 +193,13 @@ spec = do
182193 "foo" =: ("bar" :: Text)
183194 <> "baz" =: (5 :: Int)
184195 <> queryFlag "quux"
185− r <- req PUT (httpbun /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
196+ r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
186197 (stripFunnyHeaders . stripOrigin) (responseBody r)
187198 `shouldBe` object
188199 [ "args" .= emptyObject,
189200 "json" .= Null,
190201 "data" .= ("" :: Text),
191− "url" .= ("https://httpbun.org/put" :: Text),
192− "method" .= ("PUT" :: Text),
202+ "url" .= ("http://localhost:1234/put" :: Text),
193203 "headers"
194204 .= object
195205 [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),
@@ -208,19 +218,24 @@ spec = do
208218 responseStatusCode r `shouldBe` 200
209219 responseStatusMessage r `shouldBe` "OK"
210220
211− -- describe "receiving UTF-8 encoded Unicode data" $
212− -- it "works" $ do
213− -- r <-
214− -- req
215− -- GET
216− -- (httpbun /: "encoding" /: "utf8")
217− -- NoReqBody
218− -- bsResponse
219− -- mempty
220− -- utf8data <- B.readFile "httpbun-data/utf8.html"
221− -- responseBody r `shouldBe` utf8data
222− -- responseStatusCode r `shouldBe` 200
223− -- responseStatusMessage r `shouldBe` "OK"
221+ -- TODO /delete
222+
223+ describe "receiving UTF-8 encoded Unicode data" $
224+ it "works" $ do
225+ r <-
226+ req
227+ GET
228+ (httpbin /: "encoding" /: "utf8")
229+ NoReqBody
230+ bsResponse
231+ mempty
232+ utf8data <- B.readFile "httpbin-data/utf8.html"
233+ responseBody r `shouldBe` utf8data
234+ responseStatusCode r `shouldBe` 200
235+ responseStatusMessage r `shouldBe` "OK"
236+
237+ -- TODO /gzip
238+ -- TODO /deflate
224239
225240 describe "retrying" $
226241 it "retries as many times as specified" $ do
@@ -231,7 +246,7 @@ spec = do
231246 prepareForShit $
232247 req
233248 GET
234− (httpbun /: "status" /~ status)
249+ (httpbin /: "status" /~ status)
235250 NoReqBody
236251 ignoreResponse
237252 mempty
@@ -243,18 +258,25 @@ spec = do
243258 forM_ [400 .. 431] checkStatusCode
244259 forM_ [500 .. 511] checkStatusCode
245260
261+ -- TODO /response-headers
262+ -- TODO /redirect
263+
246264 describe "redirects" $
247265 it "follows redirects" $ do
248266 r <-
249267 req
250268 GET
251− (httpbun /: "redirect-to")
269+ (httpbin /: "redirect-to")
252270 NoReqBody
253271 ignoreResponse
254− ("url" =: ("https://httpbun.org" :: Text))
272+ ("url" =: ("https://httpbin.org" :: Text))
255273 responseStatusCode r `shouldBe` 200
256274 responseStatusMessage r `shouldBe` "OK"
257275
276+ -- TODO /relative-redicet
277+ -- TODO /absolute-redirect
278+ -- TODO /cookies
279+
258280 describe "basicAuth" $ do
259281 let user, password :: Text
260282 user = "Scooby"
@@ -265,32 +287,43 @@ spec = do
265287 prepareForShit $
266288 req
267289 GET
268− (httpbun /: "basic-auth" /~ user /~ password)
290+ (httpbin /: "basic-auth" /~ user /~ password)
269291 NoReqBody
270292 ignoreResponse
271293 mempty
272294 responseStatusCode r `shouldBe` 401
273− responseStatusMessage r `shouldBe` "Unauthorized"
295+ responseStatusMessage r `shouldBe` "UNAUTHORIZED"
274296 context "when we provide appropriate basic auth data" $
275297 it "succeeds" $ do
276298 r <-
277299 req
278300 GET
279− (httpbun /: "basic-auth" /~ user /~ password)
301+ (httpbin /: "basic-auth" /~ user /~ password)
280302 NoReqBody
281303 ignoreResponse
282− (basicAuth (T.encodeUtf8 user) (T.encodeUtf8 password))
304+ (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password))
283305 responseStatusCode r `shouldBe` 200
284306 responseStatusMessage r `shouldBe` "OK"
285307
308+ -- TODO /hidden-basic-auth
309+ -- TODO /digest-auth
310+ -- TODO /stream
311+ -- TODO /delay
312+ -- TODO /drip
313+ -- TODO /range
314+ -- TODO /html
315+
286316 describe "robots.txt" $
287317 it "works" $ do
288− r <- req GET (httpbun /: "robots.txt") NoReqBody bsResponse mempty
289− robots <- B.readFile "httpbun-data/robots.txt"
318+ r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty
319+ robots <- B.readFile "httpbin-data/robots.txt"
290320 responseBody r `shouldBe` robots
291321 responseStatusCode r `shouldBe` 200
292322 responseStatusMessage r `shouldBe` "OK"
293323
324+ -- TODO /deny
325+ -- TODO /cache
326+
294327 describe "getting random bytes" $ do
295328 it "works" $
296329 property $ \n' -> do
@@ -299,7 +332,7 @@ spec = do
299332 r <-
300333 req
301334 GET
302− (httpbun /: "bytes" /~ n)
335+ (httpbin /: "bytes" /~ n)
303336 NoReqBody
304337 lbsResponse
305338 mempty
@@ -315,27 +348,36 @@ spec = do
315348 n = 1000
316349 req
317350 GET
318− (httpbun /: "bytes" /~ n)
351+ (httpbin /: "bytes" /~ n)
319352 NoReqBody
320353 (Proxy :: Proxy (JsonResponse Value))
321354 mempty
322355 `shouldThrow` selector
323356
324−-- describe "streaming random bytes" $
325−-- it "works" $
326−-- property $ \n' -> do
327−-- let n :: Word
328−-- n = getSmall n'
329−-- r <-
330−-- req
331−-- GET
332−-- (httpbun /: "stream-bytes" /~ n)
333−-- NoReqBody
334−-- bsResponse
335−-- mempty
336−-- responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)
337−-- responseStatusCode r `shouldBe` 200
338−-- responseStatusMessage r `shouldBe` "OK"
357+ describe "streaming random bytes" $
358+ it "works" $
359+ property $ \n' -> do
360+ let n :: Word
361+ n = getSmall n'
362+ r <-
363+ req
364+ GET
365+ (httpbin /: "stream-bytes" /~ n)
366+ NoReqBody
367+ bsResponse
368+ mempty
369+ responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)
370+ responseStatusCode r `shouldBe` 200
371+ responseStatusMessage r `shouldBe` "OK"
372+
373+-- TODO /links
374+-- TODO /image
375+-- TODO /image/png
376+-- TODO /image/jpeg
377+-- TODO /image/webp
378+-- TODO /image/svg
379+-- TODO /forms/post
380+-- TODO /xml
339381
340382----------------------------------------------------------------------------
341383-- Instances
@@ -358,9 +400,29 @@ blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}
358400 where
359401 doit _ _ = error "Oops!"
360402
361−-- | 'Url' representing <https://httpbun.org>.
362−httpbun :: Url 'Https
363−httpbun = https "httpbun.org"
403+-- | 'Url' representing <https://httpbin.org>.
404+httpbin :: Url 'Http
405+httpbin = http "localhost"
406+
407+req ::
408+ ( MonadHttp m,
409+ HttpMethod method,
410+ HttpBody body,
411+ HttpResponse response,
412+ HttpBodyAllowed (AllowsBody method) (ProvidesBody body)
413+ ) =>
414+ method ->
415+ Url scheme ->
416+ body ->
417+ Proxy response ->
418+ Option scheme ->
419+ m response
420+req method url body responseProxy options =
421+ Req.req method url body responseProxy (options <> defaultOptions)
422+
423+-- | Options to apply by default.
424+defaultOptions :: Option scheme
425+defaultOptions = port 1234
364426
365427-- | Remove “origin” field from JSON value. Origin may change, we don't want
366428-- to depend on that.
@@ -401,7 +463,7 @@ stripFunnyHeaders' = \case
401463 "Baz"
402464 ]
403465
404−-- | This is a complete test case that makes use of <https://httpbun.org> to
466+-- | This is a complete test case that makes use of <https://httpbin.org> to
405467-- get various response status codes.
406468checkStatusCode :: Int -> SpecWith ()
407469checkStatusCode code =
@@ -411,7 +473,7 @@ checkStatusCode code =
411473 prepareForShit $
412474 req
413475 GET
414− (httpbun /: "status" /~ code)
476+ (httpbin /: "status" /~ code)
415477 NoReqBody
416478 ignoreResponse
417479 mempty