@@ -1,5 +1,6 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
5{-# OPTIONS_GHC -fno-warn-orphans #-}
6{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -23,7 +24,8 @@ import Data.Text.Encoding qualified as T
23import Data.Text.IO qualified as TIO
24import Data.Text.IO qualified as TIO
24import Network.HTTP.Client qualified as L
25import Network.HTTP.Client qualified as L
25import Network.HTTP.Client.MultipartFormData qualified as LM
26import 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
27import Network.HTTP.Types qualified as Y
29import Network.HTTP.Types qualified as Y
28import Test.Hspec
30import Test.Hspec
29import Test.QuickCheck
31import Test.QuickCheck
@@ -32,25 +34,25 @@ spec :: Spec
33 describe "exception throwing on non-2xx status codes" $
35 describe "exception throwing on non-2xx status codes" $
34 it "throws indeed for non-2xx" $
36 it "throws indeed for non-2xx" $
35− req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
37+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
36 `shouldThrow` selector404
38 `shouldThrow` selector404
38 describe "exception throwing on non-2xx status codes (Req monad)" $
40 describe "exception throwing on non-2xx status codes (Req monad)" $
39 it "throws indeed for non-2xx" $
41 it "throws indeed for non-2xx" $
40 asIO . runReq defaultHttpConfig $
42 asIO . runReq defaultHttpConfig $
41 liftBaseWith $ \run ->
43 liftBaseWith $ \run ->
42− run (req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty)
44+ run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty)
43 `shouldThrow` selector404
45 `shouldThrow` selector404
45 describe "response check via httpConfigCheckResponse" $
47 describe "response check via httpConfigCheckResponse" $
46 context "if it's set to always throw" $
48 context "if it's set to always throw" $
47 it "throws indeed" $
49 it "throws indeed" $
48− blindlyThrowing (req GET httpbun NoReqBody ignoreResponse mempty)
50+ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty)
49 `shouldThrow` anyException
51 `shouldThrow` anyException
51 describe "isStatusCodeException" $
53 describe "isStatusCodeException" $
52 it "extracts non-2xx response" $
54 it "extracts non-2xx response" $
53− req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty
55+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
54 `shouldThrow` selector404ByStatusCodeException
56 `shouldThrow` selector404ByStatusCodeException
56 describe "receiving user-agent header back" $
58 describe "receiving user-agent header back" $
@@ -58,7 +60,7 @@ spec = do
61− (httpbun /: "user-agent")
63+ (httpbin /: "user-agent")
63 jsonResponse
65 jsonResponse
64 (header "user-agent" "Req")
66 (header "user-agent" "Req")
@@ -73,7 +75,7 @@ spec = do
76− (httpbun /: "headers")
78+ (httpbin /: "headers")
78 jsonResponse
80 jsonResponse
79 (header "Foo" "bar" <> header "Baz" "quux")
81 (header "Foo" "bar" <> header "Baz" "quux")
@@ -91,12 +93,11 @@ spec = do
92 describe "receiving GET data back" $
94 describe "receiving GET data back" $
93 it "works" $ do
95 it "works" $ do
94− r <- req GET (httpbun /: "get") NoReqBody jsonResponse mempty
96+ r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
95 (stripFunnyHeaders . stripOrigin) (responseBody r)
97 (stripFunnyHeaders . stripOrigin) (responseBody r)
96 `shouldBe` object
98 `shouldBe` object
97 [ "args" .= emptyObject,
99 [ "args" .= emptyObject,
98− "url" .= ("https://httpbun.org/get" :: Text),
100+ "url" .= ("http://localhost:1234/get" :: Text),
99− "method" .= ("GET" :: Text),
100 "headers"
101 "headers"
101 .= object
102 .= object
102 [ "Accept-Encoding" .= ("gzip" :: Text)
103 [ "Accept-Encoding" .= ("gzip" :: Text)
@@ -110,14 +111,13 @@ spec = do
110 it "works" $ do
111 it "works" $ do
111 let text = "foo" :: Text
112 let text = "foo" :: Text
112 reflected = reflectJSON text
113 reflected = reflectJSON text
113− r <- req POST (httpbun /: "post") (ReqBodyJson text) jsonResponse mempty
114+ r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty
114 (stripFunnyHeaders . stripOrigin) (responseBody r)
115 (stripFunnyHeaders . stripOrigin) (responseBody r)
115 `shouldBe` object
116 `shouldBe` object
116 [ "args" .= emptyObject,
117 [ "args" .= emptyObject,
117 "json" .= text,
118 "json" .= text,
118 "data" .= reflected,
119 "data" .= reflected,
119− "url" .= ("https://httpbun.org/post" :: Text),
120+ "url" .= ("http://localhost:1234/post" :: Text),
120− "method" .= ("POST" :: Text),
121 "headers"
121 "headers"
122 .= object
122 .= object
123 [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),
123 [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),
@@ -138,15 +138,14 @@ spec = do
138 [ LM.partBS "foo" "foo data!",
138 [ LM.partBS "foo" "foo data!",
139 LM.partBS "bar" "bar data!"
139 LM.partBS "bar" "bar data!"
141− r <- req POST (httpbun /: "post") body jsonResponse mempty
141+ r <- req POST (httpbin /: "post") body jsonResponse mempty
142 let contentType = fromJust (getRequestContentType body)
142 let contentType = fromJust (getRequestContentType body)
143 (stripFunnyHeaders . stripOrigin) (responseBody r)
143 (stripFunnyHeaders . stripOrigin) (responseBody r)
144 `shouldBe` object
144 `shouldBe` object
145 [ "args" .= emptyObject,
145 [ "args" .= emptyObject,
146 "json" .= Null,
146 "json" .= Null,
147 "data" .= ("" :: Text),
147 "data" .= ("" :: Text),
148− "url" .= ("https://httpbun.org/post" :: Text),
148+ "url" .= ("http://localhost:1234/post" :: Text),
149− "method" .= ("POST" :: Text),
150 "headers"
149 "headers"
151 .= object
150 .= object
152 [ "Content-Type" .= T.decodeUtf8 contentType,
151 [ "Content-Type" .= T.decodeUtf8 contentType,
@@ -167,16 +166,15 @@ spec = do
167 describe "receiving PATCHed file back" $
166 describe "receiving PATCHed file back" $
168 it "works" $ do
167 it "works" $ do
169 let file :: FilePath
168 let file :: FilePath
170− file = "httpbun-data/robots.txt"
169+ file = "httpbin-data/robots.txt"
171 contents <- TIO.readFile file
170 contents <- TIO.readFile file
172− r <- req PATCH (httpbun /: "patch") (ReqBodyFile file) jsonResponse mempty
171+ r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty
173 (stripFunnyHeaders . stripOrigin) (responseBody r)
172 (stripFunnyHeaders . stripOrigin) (responseBody r)
174 `shouldBe` object
173 `shouldBe` object
175 [ "args" .= emptyObject,
174 [ "args" .= emptyObject,
176 "json" .= Null,
175 "json" .= Null,
177 "data" .= contents,
176 "data" .= contents,
178− "url" .= ("https://httpbun.org/patch" :: Text),
177+ "url" .= ("http://localhost:1234/patch" :: Text),
179− "method" .= ("PATCH" :: Text),
180 "headers"
178 "headers"
181 .= object
179 .= object
182 [ "Accept-Encoding" .= ("gzip" :: Text),
180 [ "Accept-Encoding" .= ("gzip" :: Text),
@@ -195,14 +193,13 @@ spec = do
195 "foo" =: ("bar" :: Text)
193 "foo" =: ("bar" :: Text)
196 <> "baz" =: (5 :: Int)
194 <> "baz" =: (5 :: Int)
197 <> queryFlag "quux"
195 <> queryFlag "quux"
198− r <- req PUT (httpbun /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
196+ r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
199 (stripFunnyHeaders . stripOrigin) (responseBody r)
197 (stripFunnyHeaders . stripOrigin) (responseBody r)
200 `shouldBe` object
198 `shouldBe` object
201 [ "args" .= emptyObject,
199 [ "args" .= emptyObject,
202 "json" .= Null,
200 "json" .= Null,
203 "data" .= ("" :: Text),
201 "data" .= ("" :: Text),
204− "url" .= ("https://httpbun.org/put" :: Text),
202+ "url" .= ("http://localhost:1234/put" :: Text),
205− "method" .= ("PUT" :: Text),
206 "headers"
203 "headers"
207 .= object
204 .= object
208 [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),
205 [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),
@@ -221,19 +218,24 @@ spec = do
221 responseStatusCode r `shouldBe` 200
218 responseStatusCode r `shouldBe` 200
222 responseStatusMessage r `shouldBe` "OK"
219 responseStatusMessage r `shouldBe` "OK"
224− -- describe "receiving UTF-8 encoded Unicode data" $
223+ describe "receiving UTF-8 encoded Unicode data" $
225− -- it "works" $ do
224+ it "works" $ do
229− -- (httpbun /: "encoding" /: "utf8")
228+ (httpbin /: "encoding" /: "utf8")
230− -- NoReqBody
229+ NoReqBody
231− -- bsResponse
230+ bsResponse
232− -- mempty
231+ mempty
233− -- utf8data <- B.readFile "httpbun-data/utf8.html"
232+ utf8data <- B.readFile "httpbin-data/utf8.html"
234− -- responseBody r `shouldBe` utf8data
233+ responseBody r `shouldBe` utf8data
235− -- responseStatusCode r `shouldBe` 200
234+ responseStatusCode r `shouldBe` 200
236− -- responseStatusMessage r `shouldBe` "OK"
235+ responseStatusMessage r `shouldBe` "OK"
238 describe "retrying" $
240 describe "retrying" $
239 it "retries as many times as specified" $ do
241 it "retries as many times as specified" $ do
@@ -244,7 +246,7 @@ spec = do
244 prepareForShit $
246 prepareForShit $
247− (httpbun /: "status" /~ status)
249+ (httpbin /: "status" /~ status)
248 NoReqBody
250 NoReqBody
249 ignoreResponse
251 ignoreResponse
@@ -256,18 +258,25 @@ spec = do
256 forM_ [400 .. 431] checkStatusCode
258 forM_ [400 .. 431] checkStatusCode
257 forM_ [500 .. 511] checkStatusCode
259 forM_ [500 .. 511] checkStatusCode
261+ -- TODO /response-headers
259 describe "redirects" $
264 describe "redirects" $
260 it "follows redirects" $ do
265 it "follows redirects" $ do
264− (httpbun /: "redirect-to")
269+ (httpbin /: "redirect-to")
265 NoReqBody
270 NoReqBody
266 ignoreResponse
271 ignoreResponse
267− ("url" =: ("https://httpbun.org" :: Text))
272+ ("url" =: ("https://httpbin.org" :: Text))
268 responseStatusCode r `shouldBe` 200
273 responseStatusCode r `shouldBe` 200
269 responseStatusMessage r `shouldBe` "OK"
274 responseStatusMessage r `shouldBe` "OK"
276+ -- TODO /relative-redicet
277+ -- TODO /absolute-redirect
271 describe "basicAuth" $ do
280 describe "basicAuth" $ do
272 let user, password :: Text
281 let user, password :: Text
273 user = "Scooby"
282 user = "Scooby"
@@ -278,32 +287,43 @@ spec = do
278 prepareForShit $
287 prepareForShit $
281− (httpbun /: "basic-auth" /~ user /~ password)
290+ (httpbin /: "basic-auth" /~ user /~ password)
282 NoReqBody
291 NoReqBody
283 ignoreResponse
292 ignoreResponse
285 responseStatusCode r `shouldBe` 401
294 responseStatusCode r `shouldBe` 401
286− responseStatusMessage r `shouldBe` "Unauthorized"
295+ responseStatusMessage r `shouldBe` "UNAUTHORIZED"
287 context "when we provide appropriate basic auth data" $
296 context "when we provide appropriate basic auth data" $
288 it "succeeds" $ do
297 it "succeeds" $ do
292− (httpbun /: "basic-auth" /~ user /~ password)
301+ (httpbin /: "basic-auth" /~ user /~ password)
293 NoReqBody
302 NoReqBody
294 ignoreResponse
303 ignoreResponse
295− (basicAuth (T.encodeUtf8 user) (T.encodeUtf8 password))
304+ (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password))
296 responseStatusCode r `shouldBe` 200
305 responseStatusCode r `shouldBe` 200
297 responseStatusMessage r `shouldBe` "OK"
306 responseStatusMessage r `shouldBe` "OK"
308+ -- TODO /hidden-basic-auth
309+ -- TODO /digest-auth
299 describe "robots.txt" $
316 describe "robots.txt" $
300 it "works" $ do
317 it "works" $ do
301− r <- req GET (httpbun /: "robots.txt") NoReqBody bsResponse mempty
318+ r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty
302− robots <- B.readFile "httpbun-data/robots.txt"
319+ robots <- B.readFile "httpbin-data/robots.txt"
303 responseBody r `shouldBe` robots
320 responseBody r `shouldBe` robots
304 responseStatusCode r `shouldBe` 200
321 responseStatusCode r `shouldBe` 200
305 responseStatusMessage r `shouldBe` "OK"
322 responseStatusMessage r `shouldBe` "OK"
307 describe "getting random bytes" $ do
327 describe "getting random bytes" $ do
308 it "works" $
328 it "works" $
309 property $ \n' -> do
329 property $ \n' -> do
@@ -312,7 +332,7 @@ spec = do
315− (httpbun /: "bytes" /~ n)
335+ (httpbin /: "bytes" /~ n)
316 NoReqBody
336 NoReqBody
317 lbsResponse
337 lbsResponse
@@ -328,27 +348,36 @@ spec = do
331− (httpbun /: "bytes" /~ n)
351+ (httpbin /: "bytes" /~ n)
332 NoReqBody
352 NoReqBody
333 (Proxy :: Proxy (JsonResponse Value))
353 (Proxy :: Proxy (JsonResponse Value))
335 `shouldThrow` selector
355 `shouldThrow` selector
337−-- describe "streaming random bytes" $
357+ describe "streaming random bytes" $
338−-- it "works" $
358+ it "works" $
339−-- property $ \n' -> do
359+ property $ \n' -> do
340−-- let n :: Word
360+ let n :: Word
341−-- n = getSmall n'
361+ n = getSmall n'
345−-- (httpbun /: "stream-bytes" /~ n)
365+ (httpbin /: "stream-bytes" /~ n)
346−-- NoReqBody
366+ NoReqBody
347−-- bsResponse
367+ bsResponse
349−-- responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)
369+ responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)
350−-- responseStatusCode r `shouldBe` 200
370+ responseStatusCode r `shouldBe` 200
351−-- responseStatusMessage r `shouldBe` "OK"
371+ responseStatusMessage r `shouldBe` "OK"
353----------------------------------------------------------------------------
382----------------------------------------------------------------------------
354-- Instances
383-- Instances
@@ -371,9 +400,29 @@ blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}
372 doit _ _ = error "Oops!"
401 doit _ _ = error "Oops!"
374−-- | 'Url' representing <https://httpbun.org>.
403+-- | 'Url' representing <https://httpbin.org>.
375−httpbun :: Url 'Https
404+httpbin :: Url 'Http
376−httpbun = https "httpbun.org"
405+httpbin = http "localhost"
411+ HttpResponse response,
412+ HttpBodyAllowed (AllowsBody method) (ProvidesBody body)
420+req method url body responseProxy options =
421+ Req.req method url body responseProxy (options <> defaultOptions)
423+-- | Options to apply by default.
424+defaultOptions :: Option scheme
425+defaultOptions = port 1234
378-- | Remove “origin” field from JSON value. Origin may change, we don't want
427-- | Remove “origin” field from JSON value. Origin may change, we don't want
379-- to depend on that.
428-- to depend on that.
@@ -383,21 +432,38 @@ stripOrigin value = value
384-- | Remove funny headers that might break the tests.
433-- | Remove funny headers that might break the tests.
385stripFunnyHeaders :: Value -> Value
434stripFunnyHeaders :: Value -> Value
386−stripFunnyHeaders (Object m) =
435+stripFunnyHeaders = \case
439+ ( Aeson.KeyMap.alterF
440+ (pure . fmap stripFunnyHeaders')
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
387− let f (Object p) = Object $ Aeson.KeyMap.filterWithKey (\k _ -> k `elem` hs) p
453+ Aeson.KeyMap.filterWithKey
454+ (\k _ -> k `elem` whitelistedHeaders)
388− f value = value
456+ value -> value
458+ whitelistedHeaders =
390− [ "Content-Type",
459+ [ "Content-Type",
391− "Accept-Encoding",
460+ "Accept-Encoding",
393− "Content-Length",
461+ "Content-Length",
397− in Object (runIdentity (Aeson.KeyMap.alterF (pure . fmap f) "headers" m))
465+
398−stripFunnyHeaders value = value
400−-- | 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
401-- get various response status codes.
467-- get various response status codes.
402checkStatusCode :: Int -> SpecWith ()
468checkStatusCode :: Int -> SpecWith ()
403checkStatusCode code =
469checkStatusCode code =
@@ -407,7 +473,7 @@ checkStatusCode code =
407 prepareForShit $
473 prepareForShit $
410− (httpbun /: "status" /~ code)
476+ (httpbin /: "status" /~ code)
411 NoReqBody
477 NoReqBody
412 ignoreResponse
478 ignoreResponse