@@ -1,6 +1,5 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE LambdaCase #-}
43{-# LANGUAGE OverloadedStrings #-}
54{-# LANGUAGE RankNTypes #-}
65{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -24,8 +23,7 @@ import Data.Text.Encoding qualified as T
2423import Data.Text.IO qualified as TIO
2524import Network.HTTP.Client qualified as L
2625import Network.HTTP.Client.MultipartFormData qualified as LM
27−import Network.HTTP.Req hiding (req)
28−import Network.HTTP.Req qualified as Req
26+import Network.HTTP.Req
2927import Network.HTTP.Types qualified as Y
3028import Test.Hspec
3129import Test.QuickCheck
@@ -34,25 +32,25 @@ spec :: Spec
3432spec = do
3533 describe "exception throwing on non-2xx status codes" $
3634 it "throws indeed for non-2xx" $
37− req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
35+ req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
3836 `shouldThrow` selector404
3937
4038 describe "exception throwing on non-2xx status codes (Req monad)" $
4139 it "throws indeed for non-2xx" $
4240 asIO . runReq defaultHttpConfig $
4341 liftBaseWith $ \run ->
44− run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty)
42+ run (req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty)
4543 `shouldThrow` selector404
4644
4745 describe "response check via httpConfigCheckResponse" $
4846 context "if it's set to always throw" $
4947 it "throws indeed" $
50− blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty)
48+ blindlyThrowing (req GET httpbun NoReqBody ignoreResponse mempty)
5149 `shouldThrow` anyException
5250
5351 describe "isStatusCodeException" $
5452 it "extracts non-2xx response" $
55− req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
53+ req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
5654 `shouldThrow` selector404ByStatusCodeException
5755
5856 describe "receiving user-agent header back" $
@@ -60,7 +58,7 @@ spec = do
6058 r <-
6159 req
6260 GET
63− (httpbin /: "user-agent")
61+ (httpbun /: "user-agent")
6462 NoReqBody
6563 jsonResponse
6664 (header "user-agent" "Req")
@@ -75,7 +73,7 @@ spec = do
7573 r <-
7674 req
7775 GET
78− (httpbin /: "headers")
76+ (httpbun /: "headers")
7977 NoReqBody
8078 jsonResponse
8179 (header "Foo" "bar" <> header "Baz" "quux")
@@ -93,11 +91,12 @@ spec = do
9391
9492 describe "receiving GET data back" $
9593 it "works" $ do
96− r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
94+ r <- req GET (httpbun /: "get") NoReqBody jsonResponse mempty
9795 (stripFunnyHeaders . stripOrigin) (responseBody r)
9896 `shouldBe` object
9997 [ "args" .= emptyObject,
100− "url" .= ("http://localhost:1234/get" :: Text),
98+ "url" .= ("https://httpbun.org/get" :: Text),
99+ "method" .= ("GET" :: Text),
101100 "headers"
102101 .= object
103102 [ "Accept-Encoding" .= ("gzip" :: Text)
@@ -111,13 +110,14 @@ spec = do
111110 it "works" $ do
112111 let text = "foo" :: Text
113112 reflected = reflectJSON text
114− r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty
113+ r <- req POST (httpbun /: "post") (ReqBodyJson text) jsonResponse mempty
115114 (stripFunnyHeaders . stripOrigin) (responseBody r)
116115 `shouldBe` object
117116 [ "args" .= emptyObject,
118117 "json" .= text,
119118 "data" .= reflected,
120− "url" .= ("http://localhost:1234/post" :: Text),
119+ "url" .= ("https://httpbun.org/post" :: Text),
120+ "method" .= ("POST" :: Text),
121121 "headers"
122122 .= object
123123 [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),
@@ -138,14 +138,15 @@ spec = do
138138 [ LM.partBS "foo" "foo data!",
139139 LM.partBS "bar" "bar data!"
140140 ]
141− r <- req POST (httpbin /: "post") body jsonResponse mempty
141+ r <- req POST (httpbun /: "post") body jsonResponse mempty
142142 let contentType = fromJust (getRequestContentType body)
143143 (stripFunnyHeaders . stripOrigin) (responseBody r)
144144 `shouldBe` object
145145 [ "args" .= emptyObject,
146146 "json" .= Null,
147147 "data" .= ("" :: Text),
148− "url" .= ("http://localhost:1234/post" :: Text),
148+ "url" .= ("https://httpbun.org/post" :: Text),
149+ "method" .= ("POST" :: Text),
149150 "headers"
150151 .= object
151152 [ "Content-Type" .= T.decodeUtf8 contentType,
@@ -166,15 +167,16 @@ spec = do
166167 describe "receiving PATCHed file back" $
167168 it "works" $ do
168169 let file :: FilePath
169− file = "httpbin-data/robots.txt"
170+ file = "httpbun-data/robots.txt"
170171 contents <- TIO.readFile file
171− r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty
172+ r <- req PATCH (httpbun /: "patch") (ReqBodyFile file) jsonResponse mempty
172173 (stripFunnyHeaders . stripOrigin) (responseBody r)
173174 `shouldBe` object
174175 [ "args" .= emptyObject,
175176 "json" .= Null,
176177 "data" .= contents,
177− "url" .= ("http://localhost:1234/patch" :: Text),
178+ "url" .= ("https://httpbun.org/patch" :: Text),
179+ "method" .= ("PATCH" :: Text),
178180 "headers"
179181 .= object
180182 [ "Accept-Encoding" .= ("gzip" :: Text),
@@ -193,13 +195,14 @@ spec = do
193195 "foo" =: ("bar" :: Text)
194196 <> "baz" =: (5 :: Int)
195197 <> queryFlag "quux"
196− r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
198+ r <- req PUT (httpbun /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
197199 (stripFunnyHeaders . stripOrigin) (responseBody r)
198200 `shouldBe` object
199201 [ "args" .= emptyObject,
200202 "json" .= Null,
201203 "data" .= ("" :: Text),
202− "url" .= ("http://localhost:1234/put" :: Text),
204+ "url" .= ("https://httpbun.org/put" :: Text),
205+ "method" .= ("PUT" :: Text),
203206 "headers"
204207 .= object
205208 [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),
@@ -218,24 +221,19 @@ spec = do
218221 responseStatusCode r `shouldBe` 200
219222 responseStatusMessage r `shouldBe` "OK"
220223
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
224+ -- describe "receiving UTF-8 encoded Unicode data" $
225+ -- it "works" $ do
226+ -- r <-
227+ -- req
228+ -- GET
229+ -- (httpbun /: "encoding" /: "utf8")
230+ -- NoReqBody
231+ -- bsResponse
232+ -- mempty
233+ -- utf8data <- B.readFile "httpbun-data/utf8.html"
234+ -- responseBody r `shouldBe` utf8data
235+ -- responseStatusCode r `shouldBe` 200
236+ -- responseStatusMessage r `shouldBe` "OK"
239237
240238 describe "retrying" $
241239 it "retries as many times as specified" $ do
@@ -246,7 +244,7 @@ spec = do
246244 prepareForShit $
247245 req
248246 GET
249− (httpbin /: "status" /~ status)
247+ (httpbun /: "status" /~ status)
250248 NoReqBody
251249 ignoreResponse
252250 mempty
@@ -258,25 +256,18 @@ spec = do
258256 forM_ [400 .. 431] checkStatusCode
259257 forM_ [500 .. 511] checkStatusCode
260258
261− -- TODO /response-headers
262− -- TODO /redirect
263−
264259 describe "redirects" $
265260 it "follows redirects" $ do
266261 r <-
267262 req
268263 GET
269− (httpbin /: "redirect-to")
264+ (httpbun /: "redirect-to")
270265 NoReqBody
271266 ignoreResponse
272− ("url" =: ("https://httpbin.org" :: Text))
267+ ("url" =: ("https://httpbun.org" :: Text))
273268 responseStatusCode r `shouldBe` 200
274269 responseStatusMessage r `shouldBe` "OK"
275270
276− -- TODO /relative-redicet
277− -- TODO /absolute-redirect
278− -- TODO /cookies
279−
280271 describe "basicAuth" $ do
281272 let user, password :: Text
282273 user = "Scooby"
@@ -287,43 +278,32 @@ spec = do
287278 prepareForShit $
288279 req
289280 GET
290− (httpbin /: "basic-auth" /~ user /~ password)
281+ (httpbun /: "basic-auth" /~ user /~ password)
291282 NoReqBody
292283 ignoreResponse
293284 mempty
294285 responseStatusCode r `shouldBe` 401
295− responseStatusMessage r `shouldBe` "UNAUTHORIZED"
286+ responseStatusMessage r `shouldBe` "Unauthorized"
296287 context "when we provide appropriate basic auth data" $
297288 it "succeeds" $ do
298289 r <-
299290 req
300291 GET
301− (httpbin /: "basic-auth" /~ user /~ password)
292+ (httpbun /: "basic-auth" /~ user /~ password)
302293 NoReqBody
303294 ignoreResponse
304− (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password))
295+ (basicAuth (T.encodeUtf8 user) (T.encodeUtf8 password))
305296 responseStatusCode r `shouldBe` 200
306297 responseStatusMessage r `shouldBe` "OK"
307298
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−
316299 describe "robots.txt" $
317300 it "works" $ do
318− r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty
319− robots <- B.readFile "httpbin-data/robots.txt"
301+ r <- req GET (httpbun /: "robots.txt") NoReqBody bsResponse mempty
302+ robots <- B.readFile "httpbun-data/robots.txt"
320303 responseBody r `shouldBe` robots
321304 responseStatusCode r `shouldBe` 200
322305 responseStatusMessage r `shouldBe` "OK"
323306
324− -- TODO /deny
325− -- TODO /cache
326−
327307 describe "getting random bytes" $ do
328308 it "works" $
329309 property $ \n' -> do
@@ -332,7 +312,7 @@ spec = do
332312 r <-
333313 req
334314 GET
335− (httpbin /: "bytes" /~ n)
315+ (httpbun /: "bytes" /~ n)
336316 NoReqBody
337317 lbsResponse
338318 mempty
@@ -348,36 +328,27 @@ spec = do
348328 n = 1000
349329 req
350330 GET
351− (httpbin /: "bytes" /~ n)
331+ (httpbun /: "bytes" /~ n)
352332 NoReqBody
353333 (Proxy :: Proxy (JsonResponse Value))
354334 mempty
355335 `shouldThrow` selector
356336
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
337+-- describe "streaming random bytes" $
338+-- it "works" $
339+-- property $ \n' -> do
340+-- let n :: Word
341+-- n = getSmall n'
342+-- r <-
343+-- req
344+-- GET
345+-- (httpbun /: "stream-bytes" /~ n)
346+-- NoReqBody
347+-- bsResponse
348+-- mempty
349+-- responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)
350+-- responseStatusCode r `shouldBe` 200
351+-- responseStatusMessage r `shouldBe` "OK"
381352
382353----------------------------------------------------------------------------
383354-- Instances
@@ -400,29 +371,9 @@ blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}
400371 where
401372 doit _ _ = error "Oops!"
402373
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
374+-- | 'Url' representing <https://httpbun.org>.
375+httpbun :: Url 'Https
376+httpbun = https "httpbun.org"
426377
427378-- | Remove “origin” field from JSON value. Origin may change, we don't want
428379-- to depend on that.
@@ -432,38 +383,21 @@ stripOrigin value = value
432383
433384-- | Remove funny headers that might break the tests.
434385stripFunnyHeaders :: Value -> Value
435−stripFunnyHeaders = \case
436− Object m ->
437− Object
438− ( runIdentity
439− ( Aeson.KeyMap.alterF
440− (pure . fmap stripFunnyHeaders')
441− "headers"
442− m
443− )
444− )
445− value -> value
446−
447−-- | Similar to 'stripFunnyHeaders', but acts directly on the argument
448−-- without trying to access its "headers" field.
449−stripFunnyHeaders' :: Value -> Value
450−stripFunnyHeaders' = \case
451− Object p ->
452− Object $
453− Aeson.KeyMap.filterWithKey
454− (\k _ -> k `elem` whitelistedHeaders)
455− p
456− value -> value
457− where
458− whitelistedHeaders =
459− [ "Content-Type",
460− "Accept-Encoding",
461− "Content-Length",
462− "Foo",
463− "Baz"
464− ]
465−
466−-- | This is a complete test case that makes use of <https://httpbin.org> to
386+stripFunnyHeaders (Object m) =
387+ let f (Object p) = Object $ Aeson.KeyMap.filterWithKey (\k _ -> k `elem` hs) p
388+ f value = value
389+ hs =
390+ [ "Content-Type",
391+ "Accept-Encoding",
392+ "Host",
393+ "Content-Length",
394+ "Foo",
395+ "Baz"
396+ ]
397+ in Object (runIdentity (Aeson.KeyMap.alterF (pure . fmap f) "headers" m))
398+stripFunnyHeaders value = value
399+
400+-- | This is a complete test case that makes use of <https://httpbun.org> to
467401-- get various response status codes.
468402checkStatusCode :: Int -> SpecWith ()
469403checkStatusCode code =
@@ -473,7 +407,7 @@ checkStatusCode code =
473407 prepareForShit $
474408 req
475409 GET
476− (httpbin /: "status" /~ code)
410+ (httpbun /: "status" /~ code)
477411 NoReqBody
478412 ignoreResponse
479413 mempty