@@ -11,21 +11,22 @@ import Control.Exception
1111import Control.Monad (forM_)
1212import Control.Monad.Trans.Control
1313import Data.Aeson (ToJSON (..), Value (..), object, (.=))
14−import qualified Data.Aeson as A
15−import qualified Data.Aeson.KeyMap as Aeson.KeyMap
16−import qualified Data.ByteString as B
17−import qualified Data.ByteString.Lazy as BL
14+import Data.Aeson qualified as A
15+import Data.Aeson.KeyMap qualified as Aeson.KeyMap
16+import Data.ByteString qualified as B
17+import Data.ByteString.Lazy qualified as BL
1818import Data.Functor.Identity (runIdentity)
1919import Data.Maybe (fromJust)
2020import Data.Proxy
2121import Data.Text (Text)
22−import qualified Data.Text as T
23−import qualified Data.Text.Encoding as T
24−import qualified Data.Text.IO as TIO
25−import qualified Network.HTTP.Client as L
26−import qualified Network.HTTP.Client.MultipartFormData as LM
27−import Network.HTTP.Req
28−import qualified Network.HTTP.Types as Y
22+import Data.Text qualified as T
23+import Data.Text.Encoding qualified as T
24+import Data.Text.IO qualified as TIO
25+import Network.HTTP.Client qualified as L
26+import Network.HTTP.Client.MultipartFormData qualified as LM
27+import Network.HTTP.Req hiding (req)
28+import Network.HTTP.Req qualified as Req
29+import Network.HTTP.Types qualified as Y
2930import Test.Hspec
3031import Test.QuickCheck
3132
@@ -33,25 +34,25 @@ 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
5758 describe "receiving user-agent header back" $
@@ -59,7 +60,7 @@ spec = do
5960 r <-
6061 req
6162 GET
62− (httpbun /: "user-agent")
63+ (httpbin /: "user-agent")
6364 NoReqBody
6465 jsonResponse
6566 (header "user-agent" "Req")
@@ -74,7 +75,7 @@ spec = do
7475 r <-
7576 req
7677 GET
77− (httpbun /: "headers")
78+ (httpbin /: "headers")
7879 NoReqBody
7980 jsonResponse
8081 (header "Foo" "bar" <> header "Baz" "quux")
@@ -92,12 +93,11 @@ spec = do
9293
9394 describe "receiving GET data back" $
9495 it "works" $ do
95− r <- req GET (httpbun /: "get") NoReqBody jsonResponse mempty
96+ r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
9697 (stripFunnyHeaders . stripOrigin) (responseBody r)
9798 `shouldBe` object
9899 [ "args" .= emptyObject,
99− "url" .= ("https://httpbun.org/get" :: Text),
100− "method" .= ("GET" :: Text),
100+ "url" .= ("http://localhost:1234/get" :: Text),
101101 "headers"
102102 .= object
103103 [ "Accept-Encoding" .= ("gzip" :: Text)
@@ -111,14 +111,13 @@ spec = do
111111 it "works" $ do
112112 let text = "foo" :: Text
113113 reflected = reflectJSON text
114− r <- req POST (httpbun /: "post") (ReqBodyJson text) jsonResponse mempty
114+ r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty
115115 (stripFunnyHeaders . stripOrigin) (responseBody r)
116116 `shouldBe` object
117117 [ "args" .= emptyObject,
118118 "json" .= text,
119119 "data" .= reflected,
120− "url" .= ("https://httpbun.org/post" :: Text),
121− "method" .= ("POST" :: Text),
120+ "url" .= ("http://localhost:1234/post" :: Text),
122121 "headers"
123122 .= object
124123 [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),
@@ -139,15 +138,14 @@ spec = do
139138 [ LM.partBS "foo" "foo data!",
140139 LM.partBS "bar" "bar data!"
141140 ]
142− r <- req POST (httpbun /: "post") body jsonResponse mempty
141+ r <- req POST (httpbin /: "post") body jsonResponse mempty
143142 let contentType = fromJust (getRequestContentType body)
144143 (stripFunnyHeaders . stripOrigin) (responseBody r)
145144 `shouldBe` object
146145 [ "args" .= emptyObject,
147146 "json" .= Null,
148147 "data" .= ("" :: Text),
149− "url" .= ("https://httpbun.org/post" :: Text),
150− "method" .= ("POST" :: Text),
148+ "url" .= ("http://localhost:1234/post" :: Text),
151149 "headers"
152150 .= object
153151 [ "Content-Type" .= T.decodeUtf8 contentType,
@@ -168,16 +166,15 @@ spec = do
168166 describe "receiving PATCHed file back" $
169167 it "works" $ do
170168 let file :: FilePath
171− file = "httpbun-data/robots.txt"
169+ file = "httpbin-data/robots.txt"
172170 contents <- TIO.readFile file
173− r <- req PATCH (httpbun /: "patch") (ReqBodyFile file) jsonResponse mempty
171+ r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty
174172 (stripFunnyHeaders . stripOrigin) (responseBody r)
175173 `shouldBe` object
176174 [ "args" .= emptyObject,
177175 "json" .= Null,
178176 "data" .= contents,
179− "url" .= ("https://httpbun.org/patch" :: Text),
180− "method" .= ("PATCH" :: Text),
177+ "url" .= ("http://localhost:1234/patch" :: Text),
181178 "headers"
182179 .= object
183180 [ "Accept-Encoding" .= ("gzip" :: Text),
@@ -196,14 +193,13 @@ spec = do
196193 "foo" =: ("bar" :: Text)
197194 <> "baz" =: (5 :: Int)
198195 <> queryFlag "quux"
199− r <- req PUT (httpbun /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
196+ r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
200197 (stripFunnyHeaders . stripOrigin) (responseBody r)
201198 `shouldBe` object
202199 [ "args" .= emptyObject,
203200 "json" .= Null,
204201 "data" .= ("" :: Text),
205− "url" .= ("https://httpbun.org/put" :: Text),
206− "method" .= ("PUT" :: Text),
202+ "url" .= ("http://localhost:1234/put" :: Text),
207203 "headers"
208204 .= object
209205 [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),
@@ -222,19 +218,24 @@ spec = do
222218 responseStatusCode r `shouldBe` 200
223219 responseStatusMessage r `shouldBe` "OK"
224220
225− -- describe "receiving UTF-8 encoded Unicode data" $
226− -- it "works" $ do
227− -- r <-
228− -- req
229− -- GET
230− -- (httpbun /: "encoding" /: "utf8")
231− -- NoReqBody
232− -- bsResponse
233− -- mempty
234− -- utf8data <- B.readFile "httpbun-data/utf8.html"
235− -- responseBody r `shouldBe` utf8data
236− -- responseStatusCode r `shouldBe` 200
237− -- 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
238239
239240 describe "retrying" $
240241 it "retries as many times as specified" $ do
@@ -245,7 +246,7 @@ spec = do
245246 prepareForShit $
246247 req
247248 GET
248− (httpbun /: "status" /~ status)
249+ (httpbin /: "status" /~ status)
249250 NoReqBody
250251 ignoreResponse
251252 mempty
@@ -257,18 +258,25 @@ spec = do
257258 forM_ [400 .. 431] checkStatusCode
258259 forM_ [500 .. 511] checkStatusCode
259260
261+ -- TODO /response-headers
262+ -- TODO /redirect
263+
260264 describe "redirects" $
261265 it "follows redirects" $ do
262266 r <-
263267 req
264268 GET
265− (httpbun /: "redirect-to")
269+ (httpbin /: "redirect-to")
266270 NoReqBody
267271 ignoreResponse
268− ("url" =: ("https://httpbun.org" :: Text))
272+ ("url" =: ("https://httpbin.org" :: Text))
269273 responseStatusCode r `shouldBe` 200
270274 responseStatusMessage r `shouldBe` "OK"
271275
276+ -- TODO /relative-redicet
277+ -- TODO /absolute-redirect
278+ -- TODO /cookies
279+
272280 describe "basicAuth" $ do
273281 let user, password :: Text
274282 user = "Scooby"
@@ -279,32 +287,43 @@ spec = do
279287 prepareForShit $
280288 req
281289 GET
282− (httpbun /: "basic-auth" /~ user /~ password)
290+ (httpbin /: "basic-auth" /~ user /~ password)
283291 NoReqBody
284292 ignoreResponse
285293 mempty
286294 responseStatusCode r `shouldBe` 401
287− responseStatusMessage r `shouldBe` "Unauthorized"
295+ responseStatusMessage r `shouldBe` "UNAUTHORIZED"
288296 context "when we provide appropriate basic auth data" $
289297 it "succeeds" $ do
290298 r <-
291299 req
292300 GET
293− (httpbun /: "basic-auth" /~ user /~ password)
301+ (httpbin /: "basic-auth" /~ user /~ password)
294302 NoReqBody
295303 ignoreResponse
296− (basicAuth (T.encodeUtf8 user) (T.encodeUtf8 password))
304+ (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password))
297305 responseStatusCode r `shouldBe` 200
298306 responseStatusMessage r `shouldBe` "OK"
299307
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+
300316 describe "robots.txt" $
301317 it "works" $ do
302− r <- req GET (httpbun /: "robots.txt") NoReqBody bsResponse mempty
303− 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"
304320 responseBody r `shouldBe` robots
305321 responseStatusCode r `shouldBe` 200
306322 responseStatusMessage r `shouldBe` "OK"
307323
324+ -- TODO /deny
325+ -- TODO /cache
326+
308327 describe "getting random bytes" $ do
309328 it "works" $
310329 property $ \n' -> do
@@ -313,7 +332,7 @@ spec = do
313332 r <-
314333 req
315334 GET
316− (httpbun /: "bytes" /~ n)
335+ (httpbin /: "bytes" /~ n)
317336 NoReqBody
318337 lbsResponse
319338 mempty
@@ -329,27 +348,36 @@ spec = do
329348 n = 1000
330349 req
331350 GET
332− (httpbun /: "bytes" /~ n)
351+ (httpbin /: "bytes" /~ n)
333352 NoReqBody
334353 (Proxy :: Proxy (JsonResponse Value))
335354 mempty
336355 `shouldThrow` selector
337356
338−-- describe "streaming random bytes" $
339−-- it "works" $
340−-- property $ \n' -> do
341−-- let n :: Word
342−-- n = getSmall n'
343−-- r <-
344−-- req
345−-- GET
346−-- (httpbun /: "stream-bytes" /~ n)
347−-- NoReqBody
348−-- bsResponse
349−-- mempty
350−-- responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)
351−-- responseStatusCode r `shouldBe` 200
352−-- 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
353381
354382----------------------------------------------------------------------------
355383-- Instances
@@ -372,9 +400,29 @@ blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}
372400 where
373401 doit _ _ = error "Oops!"
374402
375−-- | 'Url' representing <https://httpbun.org>.
376−httpbun :: Url 'Https
377−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
378426
379427-- | Remove “origin” field from JSON value. Origin may change, we don't want
380428-- to depend on that.
@@ -384,21 +432,38 @@ stripOrigin value = value
384432
385433-- | Remove funny headers that might break the tests.
386434stripFunnyHeaders :: Value -> Value
387−stripFunnyHeaders (Object m) =
388− let f (Object p) = Object $ Aeson.KeyMap.filterWithKey (\k _ -> k `elem` hs) p
389− f value = value
390− hs =
391− [ "Content-Type",
392− "Accept-Encoding",
393− "Host",
394− "Content-Length",
395− "Foo",
396− "Baz"
397− ]
398− in Object (runIdentity (Aeson.KeyMap.alterF (pure . fmap f) "headers" m))
399−stripFunnyHeaders value = value
400−
401−-- | This is a complete test case that makes use of <https://httpbun.org> to
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
402467-- get various response status codes.
403468checkStatusCode :: Int -> SpecWith ()
404469checkStatusCode code =
@@ -408,7 +473,7 @@ checkStatusCode code =
408473 prepareForShit $
409474 req
410475 GET
411− (httpbun /: "status" /~ code)
476+ (httpbin /: "status" /~ code)
412477 NoReqBody
413478 ignoreResponse
414479 mempty