@@ -1,5 +1,6 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE OverloadedStrings #-}
45{-# LANGUAGE RankNTypes #-}
56{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -23,7 +24,8 @@ import Data.Text.Encoding qualified as T
2324import Data.Text.IO qualified as TIO
2425import Network.HTTP.Client qualified as L
2526import Network.HTTP.Client.MultipartFormData qualified as LM
26−import Network.HTTP.Req
27+import Network.HTTP.Req hiding (req)
28+import Network.HTTP.Req qualified as Req
2729import Network.HTTP.Types qualified as Y
2830import Test.Hspec
2931import Test.QuickCheck
@@ -32,25 +34,25 @@ spec :: Spec
3234spec = do
3335 describe "exception throwing on non-2xx status codes" $
3436 it "throws indeed for non-2xx" $
35− req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
37+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
3638 `shouldThrow` selector404
3739
3840 describe "exception throwing on non-2xx status codes (Req monad)" $
3941 it "throws indeed for non-2xx" $
4042 asIO . runReq defaultHttpConfig $
4143 liftBaseWith $ \run ->
42− run (req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty)
44+ run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty)
4345 `shouldThrow` selector404
4446
4547 describe "response check via httpConfigCheckResponse" $
4648 context "if it's set to always throw" $
4749 it "throws indeed" $
48− blindlyThrowing (req GET httpbun NoReqBody ignoreResponse mempty)
50+ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty)
4951 `shouldThrow` anyException
5052
5153 describe "isStatusCodeException" $
5254 it "extracts non-2xx response" $
53− req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
55+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
5456 `shouldThrow` selector404ByStatusCodeException
5557
5658 describe "receiving user-agent header back" $
@@ -58,7 +60,7 @@ spec = do
5860 r <-
5961 req
6062 GET
61− (httpbun /: "user-agent")
63+ (httpbin /: "user-agent")
6264 NoReqBody
6365 jsonResponse
6466 (header "user-agent" "Req")
@@ -73,7 +75,7 @@ spec = do
7375 r <-
7476 req
7577 GET
76− (httpbun /: "headers")
78+ (httpbin /: "headers")
7779 NoReqBody
7880 jsonResponse
7981 (header "Foo" "bar" <> header "Baz" "quux")
@@ -91,12 +93,11 @@ spec = do
9193
9294 describe "receiving GET data back" $
9395 it "works" $ do
94− r <- req GET (httpbun /: "get") NoReqBody jsonResponse mempty
96+ r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
9597 (stripFunnyHeaders . stripOrigin) (responseBody r)
9698 `shouldBe` object
9799 [ "args" .= emptyObject,
98− "url" .= ("https://httpbun.org/get" :: Text),
99− "method" .= ("GET" :: Text),
100+ "url" .= ("http://localhost:1234/get" :: Text),
100101 "headers"
101102 .= object
102103 [ "Accept-Encoding" .= ("gzip" :: Text)
@@ -110,14 +111,13 @@ spec = do
110111 it "works" $ do
111112 let text = "foo" :: Text
112113 reflected = reflectJSON text
113− r <- req POST (httpbun /: "post") (ReqBodyJson text) jsonResponse mempty
114+ r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty
114115 (stripFunnyHeaders . stripOrigin) (responseBody r)
115116 `shouldBe` object
116117 [ "args" .= emptyObject,
117118 "json" .= text,
118119 "data" .= reflected,
119− "url" .= ("https://httpbun.org/post" :: Text),
120− "method" .= ("POST" :: Text),
120+ "url" .= ("http://localhost:1234/post" :: Text),
121121 "headers"
122122 .= object
123123 [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),
@@ -138,15 +138,14 @@ spec = do
138138 [ LM.partBS "foo" "foo data!",
139139 LM.partBS "bar" "bar data!"
140140 ]
141− r <- req POST (httpbun /: "post") body jsonResponse mempty
141+ r <- req POST (httpbin /: "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" .= ("https://httpbun.org/post" :: Text),
149− "method" .= ("POST" :: Text),
148+ "url" .= ("http://localhost:1234/post" :: Text),
150149 "headers"
151150 .= object
152151 [ "Content-Type" .= T.decodeUtf8 contentType,
@@ -167,16 +166,15 @@ spec = do
167166 describe "receiving PATCHed file back" $
168167 it "works" $ do
169168 let file :: FilePath
170− file = "httpbun-data/robots.txt"
169+ file = "httpbin-data/robots.txt"
171170 contents <- TIO.readFile file
172− r <- req PATCH (httpbun /: "patch") (ReqBodyFile file) jsonResponse mempty
171+ r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty
173172 (stripFunnyHeaders . stripOrigin) (responseBody r)
174173 `shouldBe` object
175174 [ "args" .= emptyObject,
176175 "json" .= Null,
177176 "data" .= contents,
178− "url" .= ("https://httpbun.org/patch" :: Text),
179− "method" .= ("PATCH" :: Text),
177+ "url" .= ("http://localhost:1234/patch" :: Text),
180178 "headers"
181179 .= object
182180 [ "Accept-Encoding" .= ("gzip" :: Text),
@@ -195,14 +193,13 @@ spec = do
195193 "foo" =: ("bar" :: Text)
196194 <> "baz" =: (5 :: Int)
197195 <> queryFlag "quux"
198− r <- req PUT (httpbun /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
196+ r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
199197 (stripFunnyHeaders . stripOrigin) (responseBody r)
200198 `shouldBe` object
201199 [ "args" .= emptyObject,
202200 "json" .= Null,
203201 "data" .= ("" :: Text),
204− "url" .= ("https://httpbun.org/put" :: Text),
205− "method" .= ("PUT" :: Text),
202+ "url" .= ("http://localhost:1234/put" :: Text),
206203 "headers"
207204 .= object
208205 [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),
@@ -221,19 +218,24 @@ spec = do
221218 responseStatusCode r `shouldBe` 200
222219 responseStatusMessage r `shouldBe` "OK"
223220
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"
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
237239
238240 describe "retrying" $
239241 it "retries as many times as specified" $ do
@@ -244,7 +246,7 @@ spec = do
244246 prepareForShit $
245247 req
246248 GET
247− (httpbun /: "status" /~ status)
249+ (httpbin /: "status" /~ status)
248250 NoReqBody
249251 ignoreResponse
250252 mempty
@@ -256,18 +258,25 @@ spec = do
256258 forM_ [400 .. 431] checkStatusCode
257259 forM_ [500 .. 511] checkStatusCode
258260
261+ -- TODO /response-headers
262+ -- TODO /redirect
263+
259264 describe "redirects" $
260265 it "follows redirects" $ do
261266 r <-
262267 req
263268 GET
264− (httpbun /: "redirect-to")
269+ (httpbin /: "redirect-to")
265270 NoReqBody
266271 ignoreResponse
267− ("url" =: ("https://httpbun.org" :: Text))
272+ ("url" =: ("https://httpbin.org" :: Text))
268273 responseStatusCode r `shouldBe` 200
269274 responseStatusMessage r `shouldBe` "OK"
270275
276+ -- TODO /relative-redicet
277+ -- TODO /absolute-redirect
278+ -- TODO /cookies
279+
271280 describe "basicAuth" $ do
272281 let user, password :: Text
273282 user = "Scooby"
@@ -278,32 +287,43 @@ spec = do
278287 prepareForShit $
279288 req
280289 GET
281− (httpbun /: "basic-auth" /~ user /~ password)
290+ (httpbin /: "basic-auth" /~ user /~ password)
282291 NoReqBody
283292 ignoreResponse
284293 mempty
285294 responseStatusCode r `shouldBe` 401
286− responseStatusMessage r `shouldBe` "Unauthorized"
295+ responseStatusMessage r `shouldBe` "UNAUTHORIZED"
287296 context "when we provide appropriate basic auth data" $
288297 it "succeeds" $ do
289298 r <-
290299 req
291300 GET
292− (httpbun /: "basic-auth" /~ user /~ password)
301+ (httpbin /: "basic-auth" /~ user /~ password)
293302 NoReqBody
294303 ignoreResponse
295− (basicAuth (T.encodeUtf8 user) (T.encodeUtf8 password))
304+ (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password))
296305 responseStatusCode r `shouldBe` 200
297306 responseStatusMessage r `shouldBe` "OK"
298307
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+
299316 describe "robots.txt" $
300317 it "works" $ do
301− r <- req GET (httpbun /: "robots.txt") NoReqBody bsResponse mempty
302− 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"
303320 responseBody r `shouldBe` robots
304321 responseStatusCode r `shouldBe` 200
305322 responseStatusMessage r `shouldBe` "OK"
306323
324+ -- TODO /deny
325+ -- TODO /cache
326+
307327 describe "getting random bytes" $ do
308328 it "works" $
309329 property $ \n' -> do
@@ -312,7 +332,7 @@ spec = do
312332 r <-
313333 req
314334 GET
315− (httpbun /: "bytes" /~ n)
335+ (httpbin /: "bytes" /~ n)
316336 NoReqBody
317337 lbsResponse
318338 mempty
@@ -328,27 +348,36 @@ spec = do
328348 n = 1000
329349 req
330350 GET
331− (httpbun /: "bytes" /~ n)
351+ (httpbin /: "bytes" /~ n)
332352 NoReqBody
333353 (Proxy :: Proxy (JsonResponse Value))
334354 mempty
335355 `shouldThrow` selector
336356
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"
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
352381
353382----------------------------------------------------------------------------
354383-- Instances
@@ -371,9 +400,29 @@ blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}
371400 where
372401 doit _ _ = error "Oops!"
373402
374−-- | 'Url' representing <https://httpbun.org>.
375−httpbun :: Url 'Https
376−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
377426
378427-- | Remove “origin” field from JSON value. Origin may change, we don't want
379428-- to depend on that.
@@ -383,21 +432,38 @@ stripOrigin value = value
383432
384433-- | Remove funny headers that might break the tests.
385434stripFunnyHeaders :: Value -> Value
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
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
401467-- get various response status codes.
402468checkStatusCode :: Int -> SpecWith ()
403469checkStatusCode code =
@@ -407,7 +473,7 @@ checkStatusCode code =
407473 prepareForShit $
408474 req
409475 GET
410− (httpbun /: "status" /~ code)
476+ (httpbin /: "status" /~ code)
411477 NoReqBody
412478 ignoreResponse
413479 mempty