req 3.13.1 → 3.13.2
raw patch · 11 files changed
+775/−707 lines, 11 filesdep ~containersdep ~mtldep ~template-haskellsetup-changed
Dependency ranges changed: containers, mtl, template-haskell
Files
- CHANGELOG.md +6/−0
- Setup.hs +0/−6
- httpbin-data/robots.txt +2/−0
- httpbin-data/utf8.html +220/−0
- httpbin-tests/Network/HTTP/ReqSpec.hs +512/−0
- httpbin-tests/Spec.hs +1/−0
- httpbun-data/robots.txt +0/−2
- httpbun-data/utf8.html +0/−220
- httpbun-tests/Network/HTTP/ReqSpec.hs +0/−446
- httpbun-tests/Spec.hs +0/−1
- req.cabal +34/−32
CHANGELOG.md view
@@ -1,3 +1,9 @@+## Req 3.13.2++* Disable the problematic `httpbin-tests` test suite by default. Only enable+ it when the `dev` flag is enabled. In that case it is expected that an+ httpbin server is run locally at `localhost:1234`.+ ## Req 3.13.1 * Switched the non-pure test suite to use https://httpbun.org instead of
− Setup.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain
+ httpbin-data/robots.txt view
@@ -0,0 +1,2 @@+User-agent: *+Disallow: /deny
+ httpbin-data/utf8.html view
@@ -0,0 +1,220 @@+<h1>Unicode Demo</h1>++<p>Taken from <a+href="http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-demo.txt">http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-demo.txt</a></p>++<pre>++UTF-8 encoded sample plain-text file+‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾++Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25+++The ASCII compatible UTF-8 encoding used in this plain-text file+is defined in Unicode, ISO 10646-1, and RFC 2279.+++Using Unicode/UTF-8, you can write in emails and source code things such as++Mathematics and sciences:++ ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫+ ⎪⎢⎜│a²+b³ ⎟⎥⎪+ ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪+ ⎪⎢⎜⎷ c₈ ⎟⎥⎪+ ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬+ ⎪⎢⎜ ∞ ⎟⎥⎪+ ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪+ ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪+ 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭++Linguistics and dictionaries:++ ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn+ Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]++APL:++ ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈++Nicer typography in plain text files:++ ╔══════════════════════════════════════════╗+ ║ ║+ ║ • ‘single’ and “double” quotes ║+ ║ ║+ ║ • Curly apostrophes: “We’ve been here” ║+ ║ ║+ ║ • Latin-1 apostrophe and accents: '´` ║+ ║ ║+ ║ • ‚deutsche‘ „Anführungszeichen“ ║+ ║ ║+ ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║+ ║ ║+ ║ • ASCII safety test: 1lI|, 0OD, 8B ║+ ║ ╭─────────╮ ║+ ║ • the euro symbol: │ 14.95 € │ ║+ ║ ╰─────────╯ ║+ ╚══════════════════════════════════════════╝++Combining characters:++ STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑++Greek (in Polytonic):++ The Greek anthem:++ Σὲ γνωρίζω ἀπὸ τὴν κόψη+ τοῦ σπαθιοῦ τὴν τρομερή,+ σὲ γνωρίζω ἀπὸ τὴν ὄψη+ ποὺ μὲ βία μετράει τὴ γῆ.++ ᾿Απ᾿ τὰ κόκκαλα βγαλμένη+ τῶν ῾Ελλήνων τὰ ἱερά+ καὶ σὰν πρῶτα ἀνδρειωμένη+ χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!++ From a speech of Demosthenes in the 4th century BC:++ Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,+ ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς+ λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ+ τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿+ εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ+ πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν+ οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,+ οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν+ ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον+ τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι+ γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν+ προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους+ σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ+ τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ+ τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς+ τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.++ Δημοσθένους, Γ´ ᾿Ολυνθιακὸς++Georgian:++ From a Unicode conference invitation:++ გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო+ კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,+ ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს+ ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,+ ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება+ ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,+ ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.++Russian:++ From a Unicode conference invitation:++ Зарегистрируйтесь сейчас на Десятую Международную Конференцию по+ Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.+ Конференция соберет широкий круг экспертов по вопросам глобального+ Интернета и Unicode, локализации и интернационализации, воплощению и+ применению Unicode в различных операционных системах и программных+ приложениях, шрифтах, верстке и многоязычных компьютерных системах.++Thai (UCS Level 2):++ Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese+ classic 'San Gua'):++ [----------------------------|------------------------]+ ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่+ สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา+ ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา+ โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ+ เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ+ ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ+ พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้+ ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ++ (The above is a two-column text. If combining characters are handled+ correctly, the lines of the second column should be aligned with the+ | character above.)++Ethiopian:++ Proverbs in the Amharic language:++ ሰማይ አይታረስ ንጉሥ አይከሰስ።+ ብላ ካለኝ እንደአባቴ በቆመጠኝ።+ ጌጥ ያለቤቱ ቁምጥና ነው።+ ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።+ የአፍ ወለምታ በቅቤ አይታሽም።+ አይጥ በበላ ዳዋ ተመታ።+ ሲተረጉሙ ይደረግሙ።+ ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።+ ድር ቢያብር አንበሳ ያስር።+ ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።+ እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።+ የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።+ ሥራ ከመፍታት ልጄን ላፋታት።+ ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።+ የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።+ ተንጋሎ ቢተፉ ተመልሶ ባፉ።+ ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።+ እግርህን በፍራሽህ ልክ ዘርጋ።++Runes:++ ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ++ (Old English, which transcribed into Latin reads 'He cwaeth that he+ bude thaem lande northweardum with tha Westsae.' and means 'He said+ that he lived in the northern land near the Western Sea.')++Braille:++ ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌++ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞+ ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎+ ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂+ ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙+ ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑+ ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲++ ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲++ ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹+ ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞+ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕+ ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹+ ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎+ ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎+ ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳+ ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞+ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲++ (The first couple of paragraphs of "A Christmas Carol" by Dickens)++Compact font selection example text:++ ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789+ abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ+ –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд+ ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა++Greetings in various languages:++ Hello world, Καλημέρα κόσμε, コンニチハ++Box drawing alignment tests: █+ ▉+ ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳+ ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳+ ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳+ ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳+ ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎+ ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏+ ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█+ ▝▀▘▙▄▟++</pre>
+ httpbin-tests/Network/HTTP/ReqSpec.hs view
@@ -0,0 +1,512 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.HTTP.ReqSpec (spec) where++import Control.Exception+import Control.Monad (forM_)+import Control.Monad.Trans.Control+import Data.Aeson (ToJSON (..), Value (..), object, (.=))+import Data.Aeson qualified as A+import Data.Aeson.KeyMap qualified as Aeson.KeyMap+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as BL+import Data.Functor.Identity (runIdentity)+import Data.Maybe (fromJust)+import Data.Proxy+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.IO qualified as TIO+import Network.HTTP.Client qualified as L+import Network.HTTP.Client.MultipartFormData qualified as LM+import Network.HTTP.Req hiding (req)+import Network.HTTP.Req qualified as Req+import Network.HTTP.Types qualified as Y+import Test.Hspec+import Test.QuickCheck++spec :: Spec+spec = do+ describe "exception throwing on non-2xx status codes" $+ it "throws indeed for non-2xx" $+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty+ `shouldThrow` selector404++ describe "exception throwing on non-2xx status codes (Req monad)" $+ it "throws indeed for non-2xx" $+ asIO . runReq defaultHttpConfig $+ liftBaseWith $ \run ->+ run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty)+ `shouldThrow` selector404++ describe "response check via httpConfigCheckResponse" $+ context "if it's set to always throw" $+ it "throws indeed" $+ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty)+ `shouldThrow` anyException++ describe "isStatusCodeException" $+ it "extracts non-2xx response" $+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty+ `shouldThrow` selector404ByStatusCodeException++ describe "receiving user-agent header back" $+ it "works" $ do+ r <-+ req+ GET+ (httpbin /: "user-agent")+ NoReqBody+ jsonResponse+ (header "user-agent" "Req")+ responseBody r+ `shouldBe` object+ ["user-agent" .= ("Req" :: Text)]+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ describe "receiving request headers back" $+ it "works" $ do+ r <-+ req+ GET+ (httpbin /: "headers")+ NoReqBody+ jsonResponse+ (header "Foo" "bar" <> header "Baz" "quux")+ stripFunnyHeaders (responseBody r)+ `shouldBe` object+ [ "headers"+ .= object+ [ "Accept-Encoding" .= ("gzip" :: Text),+ "Foo" .= ("bar" :: Text),+ "Baz" .= ("quux" :: Text)+ ]+ ]+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ describe "receiving GET data back" $+ it "works" $ do+ r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty+ (stripFunnyHeaders . stripOrigin) (responseBody r)+ `shouldBe` object+ [ "args" .= emptyObject,+ "url" .= ("http://localhost:1234/get" :: Text),+ "headers"+ .= object+ [ "Accept-Encoding" .= ("gzip" :: Text)+ ]+ ]+ responseHeader r "Content-Type" `shouldBe` return "application/json"+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ describe "receiving POST JSON data back" $+ it "works" $ do+ let text = "foo" :: Text+ reflected = reflectJSON text+ r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty+ (stripFunnyHeaders . stripOrigin) (responseBody r)+ `shouldBe` object+ [ "args" .= emptyObject,+ "json" .= text,+ "data" .= reflected,+ "url" .= ("http://localhost:1234/post" :: Text),+ "headers"+ .= object+ [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),+ "Accept-Encoding" .= ("gzip" :: Text),+ "Content-Length" .= show (T.length reflected)+ ],+ "files" .= emptyObject,+ "form" .= emptyObject+ ]+ responseHeader r "Content-Type" `shouldBe` return "application/json"+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ describe "receiving POST data back (multipart form data)" $+ it "works" $ do+ body <-+ reqBodyMultipart+ [ LM.partBS "foo" "foo data!",+ LM.partBS "bar" "bar data!"+ ]+ r <- req POST (httpbin /: "post") body jsonResponse mempty+ let contentType = fromJust (getRequestContentType body)+ (stripFunnyHeaders . stripOrigin) (responseBody r)+ `shouldBe` object+ [ "args" .= emptyObject,+ "json" .= Null,+ "data" .= ("" :: Text),+ "url" .= ("http://localhost:1234/post" :: Text),+ "headers"+ .= object+ [ "Content-Type" .= T.decodeUtf8 contentType,+ "Accept-Encoding" .= ("gzip" :: Text),+ "Content-Length" .= ("242" :: Text)+ ],+ "files" .= emptyObject,+ "form"+ .= object+ [ "foo" .= ("foo data!" :: Text),+ "bar" .= ("bar data!" :: Text)+ ]+ ]+ responseHeader r "Content-Type" `shouldBe` return "application/json"+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ describe "receiving PATCHed file back" $+ it "works" $ do+ let file :: FilePath+ file = "httpbin-data/robots.txt"+ contents <- TIO.readFile file+ r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty+ (stripFunnyHeaders . stripOrigin) (responseBody r)+ `shouldBe` object+ [ "args" .= emptyObject,+ "json" .= Null,+ "data" .= contents,+ "url" .= ("http://localhost:1234/patch" :: Text),+ "headers"+ .= object+ [ "Accept-Encoding" .= ("gzip" :: Text),+ "Content-Length" .= show (T.length contents)+ ],+ "files" .= emptyObject,+ "form" .= emptyObject+ ]+ responseHeader r "Content-Type" `shouldBe` return "application/json"+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ describe "receiving PUT form URL-encoded data back" $+ it "works" $ do+ let params =+ "foo" =: ("bar" :: Text)+ <> "baz" =: (5 :: Int)+ <> queryFlag "quux"+ r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty+ (stripFunnyHeaders . stripOrigin) (responseBody r)+ `shouldBe` object+ [ "args" .= emptyObject,+ "json" .= Null,+ "data" .= ("" :: Text),+ "url" .= ("http://localhost:1234/put" :: Text),+ "headers"+ .= object+ [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),+ "Accept-Encoding" .= ("gzip" :: Text),+ "Content-Length" .= ("18" :: Text)+ ],+ "files" .= emptyObject,+ "form"+ .= object+ [ "foo" .= ("bar" :: Text),+ "baz" .= ("5" :: Text),+ "quux" .= ("" :: Text)+ ]+ ]+ responseHeader r "Content-Type" `shouldBe` return "application/json"+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ -- TODO /delete++ describe "receiving UTF-8 encoded Unicode data" $+ it "works" $ do+ r <-+ req+ GET+ (httpbin /: "encoding" /: "utf8")+ NoReqBody+ bsResponse+ mempty+ utf8data <- B.readFile "httpbin-data/utf8.html"+ responseBody r `shouldBe` utf8data+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ -- TODO /gzip+ -- TODO /deflate++ describe "retrying" $+ it "retries as many times as specified" $ do+ -- FIXME We no longer can count retries because all the functions+ -- responsible for controlling retrying are pure now.+ let status = 408 :: Int+ r <-+ prepareForShit $+ req+ GET+ (httpbin /: "status" /~ status)+ NoReqBody+ ignoreResponse+ mempty+ responseStatusCode r `shouldBe` status++ -- forM_ [101..102] checkStatusCode+ forM_ [200 .. 208] checkStatusCode+ -- forM_ [300..308] checkStatusCode+ forM_ [400 .. 431] checkStatusCode+ forM_ [500 .. 511] checkStatusCode++ -- TODO /response-headers+ -- TODO /redirect++ describe "redirects" $+ it "follows redirects" $ do+ r <-+ req+ GET+ (httpbin /: "redirect-to")+ NoReqBody+ ignoreResponse+ ("url" =: ("https://httpbin.org" :: Text))+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ -- TODO /relative-redicet+ -- TODO /absolute-redirect+ -- TODO /cookies++ describe "basicAuth" $ do+ let user, password :: Text+ user = "Scooby"+ password = "Doo"+ context "when we do not send appropriate basic auth data" $+ it "fails with 401" $ do+ r <-+ prepareForShit $+ req+ GET+ (httpbin /: "basic-auth" /~ user /~ password)+ NoReqBody+ ignoreResponse+ mempty+ responseStatusCode r `shouldBe` 401+ responseStatusMessage r `shouldBe` "UNAUTHORIZED"+ context "when we provide appropriate basic auth data" $+ it "succeeds" $ do+ r <-+ req+ GET+ (httpbin /: "basic-auth" /~ user /~ password)+ NoReqBody+ ignoreResponse+ (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password))+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ -- TODO /hidden-basic-auth+ -- TODO /digest-auth+ -- TODO /stream+ -- TODO /delay+ -- TODO /drip+ -- TODO /range+ -- TODO /html++ describe "robots.txt" $+ it "works" $ do+ r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty+ robots <- B.readFile "httpbin-data/robots.txt"+ responseBody r `shouldBe` robots+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++ -- TODO /deny+ -- TODO /cache++ describe "getting random bytes" $ do+ it "works" $+ property $ \n' -> do+ let n :: Word+ n = getSmall n'+ r <-+ req+ GET+ (httpbin /: "bytes" /~ n)+ NoReqBody+ lbsResponse+ mempty+ responseBody r `shouldSatisfy` ((== n) . fromIntegral . BL.length)+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"+ context "when we try to interpret 1000 random bytes as JSON" $+ it "throws correct exception" $ do+ let selector :: HttpException -> Bool+ selector (JsonHttpException _) = True+ selector _ = False+ n :: Int+ n = 1000+ req+ GET+ (httpbin /: "bytes" /~ n)+ NoReqBody+ (Proxy :: Proxy (JsonResponse Value))+ mempty+ `shouldThrow` selector++ describe "streaming random bytes" $+ it "works" $+ property $ \n' -> do+ let n :: Word+ n = getSmall n'+ r <-+ req+ GET+ (httpbin /: "stream-bytes" /~ n)+ NoReqBody+ bsResponse+ mempty+ responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)+ responseStatusCode r `shouldBe` 200+ responseStatusMessage r `shouldBe` "OK"++-- TODO /links+-- TODO /image+-- TODO /image/png+-- TODO /image/jpeg+-- TODO /image/webp+-- TODO /image/svg+-- TODO /forms/post+-- TODO /xml++----------------------------------------------------------------------------+-- Instances++instance MonadHttp IO where+ handleHttpException = throwIO++----------------------------------------------------------------------------+-- Helpers++-- | Run a request with such settings that it does not signal errors.+prepareForShit :: Req a -> IO a+prepareForShit = runReq defaultHttpConfig {httpConfigCheckResponse = noNoise}+ where+ noNoise _ _ _ = Nothing++-- | Run a request with such settings that it throws on any response.+blindlyThrowing :: Req a -> IO a+blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}+ where+ doit _ _ = error "Oops!"++-- | 'Url' representing <https://httpbin.org>.+httpbin :: Url 'Http+httpbin = http "localhost"++req ::+ ( MonadHttp m,+ HttpMethod method,+ HttpBody body,+ HttpResponse response,+ HttpBodyAllowed (AllowsBody method) (ProvidesBody body)+ ) =>+ method ->+ Url scheme ->+ body ->+ Proxy response ->+ Option scheme ->+ m response+req method url body responseProxy options =+ Req.req method url body responseProxy (options <> defaultOptions)++-- | Options to apply by default.+defaultOptions :: Option scheme+defaultOptions = port 1234++-- | Remove “origin” field from JSON value. Origin may change, we don't want+-- to depend on that.+stripOrigin :: Value -> Value+stripOrigin (Object m) = Object (Aeson.KeyMap.delete "origin" m)+stripOrigin value = value++-- | Remove funny headers that might break the tests.+stripFunnyHeaders :: Value -> Value+stripFunnyHeaders = \case+ Object m ->+ Object+ ( runIdentity+ ( Aeson.KeyMap.alterF+ (pure . fmap stripFunnyHeaders')+ "headers"+ m+ )+ )+ value -> value++-- | Similar to 'stripFunnyHeaders', but acts directly on the argument+-- without trying to access its "headers" field.+stripFunnyHeaders' :: Value -> Value+stripFunnyHeaders' = \case+ Object p ->+ Object $+ Aeson.KeyMap.filterWithKey+ (\k _ -> k `elem` whitelistedHeaders)+ p+ value -> value+ where+ whitelistedHeaders =+ [ "Content-Type",+ "Accept-Encoding",+ "Content-Length",+ "Foo",+ "Baz"+ ]++-- | This is a complete test case that makes use of <https://httpbin.org> to+-- get various response status codes.+checkStatusCode :: Int -> SpecWith ()+checkStatusCode code =+ describe ("receiving status code " ++ show code) $+ it "works" $ do+ r <-+ prepareForShit $+ req+ GET+ (httpbin /: "status" /~ code)+ NoReqBody+ ignoreResponse+ mempty+ responseStatusCode r `shouldBe` code++-- | Exception selector that selects only 404 “Not found” exceptions.+selector404 :: HttpException -> Bool+selector404+ ( VanillaHttpException+ ( L.HttpExceptionRequest+ _+ (L.StatusCodeException response chunk)+ )+ ) =+ L.responseStatus response == Y.status404 && not (B.null chunk)+selector404 _ = False++-- | Same as 'selector404' except that it uses 'isStatusCodeException'.+selector404ByStatusCodeException :: HttpException -> Bool+selector404ByStatusCodeException e =+ case isStatusCodeException e of+ Nothing -> False+ Just r -> responseStatusCode r == 404++-- | The empty JSON 'Object'.+emptyObject :: Value+emptyObject = Object Aeson.KeyMap.empty++-- | Get a rendered JSON value as 'Text'.+reflectJSON :: (ToJSON a) => a -> Text+reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode++-- | Clarify to the type checker that the inner computation is in the 'IO'+-- monad.+asIO :: IO a -> IO a+asIO = id
+ httpbin-tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− httpbun-data/robots.txt
@@ -1,2 +0,0 @@-User-agent: *-Disallow: /deny
− httpbun-data/utf8.html
@@ -1,220 +0,0 @@-<h1>Unicode Demo</h1>--<p>Taken from <a-href="http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-demo.txt">http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-demo.txt</a></p>--<pre>--UTF-8 encoded sample plain-text file-‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾--Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25---The ASCII compatible UTF-8 encoding used in this plain-text file-is defined in Unicode, ISO 10646-1, and RFC 2279.---Using Unicode/UTF-8, you can write in emails and source code things such as--Mathematics and sciences:-- ∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫- ⎪⎢⎜│a²+b³ ⎟⎥⎪- ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪- ⎪⎢⎜⎷ c₈ ⎟⎥⎪- ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬- ⎪⎢⎜ ∞ ⎟⎥⎪- ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪- ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪- 2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭--Linguistics and dictionaries:-- ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn- Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]--APL:-- ((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈--Nicer typography in plain text files:-- ╔══════════════════════════════════════════╗- ║ ║- ║ • ‘single’ and “double” quotes ║- ║ ║- ║ • Curly apostrophes: “We’ve been here” ║- ║ ║- ║ • Latin-1 apostrophe and accents: '´` ║- ║ ║- ║ • ‚deutsche‘ „Anführungszeichen“ ║- ║ ║- ║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║- ║ ║- ║ • ASCII safety test: 1lI|, 0OD, 8B ║- ║ ╭─────────╮ ║- ║ • the euro symbol: │ 14.95 € │ ║- ║ ╰─────────╯ ║- ╚══════════════════════════════════════════╝--Combining characters:-- STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑--Greek (in Polytonic):-- The Greek anthem:-- Σὲ γνωρίζω ἀπὸ τὴν κόψη- τοῦ σπαθιοῦ τὴν τρομερή,- σὲ γνωρίζω ἀπὸ τὴν ὄψη- ποὺ μὲ βία μετράει τὴ γῆ.-- ᾿Απ᾿ τὰ κόκκαλα βγαλμένη- τῶν ῾Ελλήνων τὰ ἱερά- καὶ σὰν πρῶτα ἀνδρειωμένη- χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!-- From a speech of Demosthenes in the 4th century BC:-- Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,- ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς- λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ- τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿- εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ- πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν- οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,- οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν- ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον- τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι- γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν- προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους- σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ- τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ- τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς- τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.-- Δημοσθένους, Γ´ ᾿Ολυνθιακὸς--Georgian:-- From a Unicode conference invitation:-- გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო- კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,- ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს- ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,- ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება- ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,- ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.--Russian:-- From a Unicode conference invitation:-- Зарегистрируйтесь сейчас на Десятую Международную Конференцию по- Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.- Конференция соберет широкий круг экспертов по вопросам глобального- Интернета и Unicode, локализации и интернационализации, воплощению и- применению Unicode в различных операционных системах и программных- приложениях, шрифтах, верстке и многоязычных компьютерных системах.--Thai (UCS Level 2):-- Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese- classic 'San Gua'):-- [----------------------------|------------------------]- ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่- สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา- ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา- โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ- เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ- ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ- พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้- ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ-- (The above is a two-column text. If combining characters are handled- correctly, the lines of the second column should be aligned with the- | character above.)--Ethiopian:-- Proverbs in the Amharic language:-- ሰማይ አይታረስ ንጉሥ አይከሰስ።- ብላ ካለኝ እንደአባቴ በቆመጠኝ።- ጌጥ ያለቤቱ ቁምጥና ነው።- ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።- የአፍ ወለምታ በቅቤ አይታሽም።- አይጥ በበላ ዳዋ ተመታ።- ሲተረጉሙ ይደረግሙ።- ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።- ድር ቢያብር አንበሳ ያስር።- ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።- እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።- የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።- ሥራ ከመፍታት ልጄን ላፋታት።- ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።- የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።- ተንጋሎ ቢተፉ ተመልሶ ባፉ።- ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።- እግርህን በፍራሽህ ልክ ዘርጋ።--Runes:-- ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ-- (Old English, which transcribed into Latin reads 'He cwaeth that he- bude thaem lande northweardum with tha Westsae.' and means 'He said- that he lived in the northern land near the Western Sea.')--Braille:-- ⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌-- ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞- ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎- ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂- ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙- ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑- ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲-- ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲-- ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹- ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞- ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕- ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹- ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎- ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎- ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳- ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞- ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲-- (The first couple of paragraphs of "A Christmas Carol" by Dickens)--Compact font selection example text:-- ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789- abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ- –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд- ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა--Greetings in various languages:-- Hello world, Καλημέρα κόσμε, コンニチハ--Box drawing alignment tests: █- ▉- ╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳- ║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳- ║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳- ╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳- ║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎- ║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏- ╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█- ▝▀▘▙▄▟--</pre>
− httpbun-tests/Network/HTTP/ReqSpec.hs
@@ -1,446 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.HTTP.ReqSpec (spec) where--import Control.Exception-import Control.Monad (forM_)-import Control.Monad.Trans.Control-import Data.Aeson (ToJSON (..), Value (..), object, (.=))-import Data.Aeson qualified as A-import Data.Aeson.KeyMap qualified as Aeson.KeyMap-import Data.ByteString qualified as B-import Data.ByteString.Lazy qualified as BL-import Data.Functor.Identity (runIdentity)-import Data.Maybe (fromJust)-import Data.Proxy-import Data.Text (Text)-import Data.Text qualified as T-import Data.Text.Encoding qualified as T-import Data.Text.IO qualified as TIO-import Network.HTTP.Client qualified as L-import Network.HTTP.Client.MultipartFormData qualified as LM-import Network.HTTP.Req-import Network.HTTP.Types qualified as Y-import Test.Hspec-import Test.QuickCheck--spec :: Spec-spec = do- describe "exception throwing on non-2xx status codes" $- it "throws indeed for non-2xx" $- req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty- `shouldThrow` selector404-- describe "exception throwing on non-2xx status codes (Req monad)" $- it "throws indeed for non-2xx" $- asIO . runReq defaultHttpConfig $- liftBaseWith $ \run ->- run (req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty)- `shouldThrow` selector404-- describe "response check via httpConfigCheckResponse" $- context "if it's set to always throw" $- it "throws indeed" $- blindlyThrowing (req GET httpbun NoReqBody ignoreResponse mempty)- `shouldThrow` anyException-- describe "isStatusCodeException" $- it "extracts non-2xx response" $- req GET (httpbun /: "foo") NoReqBody ignoreResponse mempty- `shouldThrow` selector404ByStatusCodeException-- describe "receiving user-agent header back" $- it "works" $ do- r <-- req- GET- (httpbun /: "user-agent")- NoReqBody- jsonResponse- (header "user-agent" "Req")- responseBody r- `shouldBe` object- ["user-agent" .= ("Req" :: Text)]- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "receiving request headers back" $- it "works" $ do- r <-- req- GET- (httpbun /: "headers")- NoReqBody- jsonResponse- (header "Foo" "bar" <> header "Baz" "quux")- stripFunnyHeaders (responseBody r)- `shouldBe` object- [ "headers"- .= object- [ "Accept-Encoding" .= ("gzip" :: Text),- "Foo" .= ("bar" :: Text),- "Baz" .= ("quux" :: Text)- ]- ]- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "receiving GET data back" $- it "works" $ do- r <- req GET (httpbun /: "get") NoReqBody jsonResponse mempty- (stripFunnyHeaders . stripOrigin) (responseBody r)- `shouldBe` object- [ "args" .= emptyObject,- "url" .= ("https://httpbun.org/get" :: Text),- "method" .= ("GET" :: Text),- "headers"- .= object- [ "Accept-Encoding" .= ("gzip" :: Text)- ]- ]- responseHeader r "Content-Type" `shouldBe` return "application/json"- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "receiving POST JSON data back" $- it "works" $ do- let text = "foo" :: Text- reflected = reflectJSON text- r <- req POST (httpbun /: "post") (ReqBodyJson text) jsonResponse mempty- (stripFunnyHeaders . stripOrigin) (responseBody r)- `shouldBe` object- [ "args" .= emptyObject,- "json" .= text,- "data" .= reflected,- "url" .= ("https://httpbun.org/post" :: Text),- "method" .= ("POST" :: Text),- "headers"- .= object- [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),- "Accept-Encoding" .= ("gzip" :: Text),- "Content-Length" .= show (T.length reflected)- ],- "files" .= emptyObject,- "form" .= emptyObject- ]- responseHeader r "Content-Type" `shouldBe` return "application/json"- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "receiving POST data back (multipart form data)" $- it "works" $ do- body <-- reqBodyMultipart- [ LM.partBS "foo" "foo data!",- LM.partBS "bar" "bar data!"- ]- r <- req POST (httpbun /: "post") body jsonResponse mempty- let contentType = fromJust (getRequestContentType body)- (stripFunnyHeaders . stripOrigin) (responseBody r)- `shouldBe` object- [ "args" .= emptyObject,- "json" .= Null,- "data" .= ("" :: Text),- "url" .= ("https://httpbun.org/post" :: Text),- "method" .= ("POST" :: Text),- "headers"- .= object- [ "Content-Type" .= T.decodeUtf8 contentType,- "Accept-Encoding" .= ("gzip" :: Text),- "Content-Length" .= ("242" :: Text)- ],- "files" .= emptyObject,- "form"- .= object- [ "foo" .= ("foo data!" :: Text),- "bar" .= ("bar data!" :: Text)- ]- ]- responseHeader r "Content-Type" `shouldBe` return "application/json"- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "receiving PATCHed file back" $- it "works" $ do- let file :: FilePath- file = "httpbun-data/robots.txt"- contents <- TIO.readFile file- r <- req PATCH (httpbun /: "patch") (ReqBodyFile file) jsonResponse mempty- (stripFunnyHeaders . stripOrigin) (responseBody r)- `shouldBe` object- [ "args" .= emptyObject,- "json" .= Null,- "data" .= contents,- "url" .= ("https://httpbun.org/patch" :: Text),- "method" .= ("PATCH" :: Text),- "headers"- .= object- [ "Accept-Encoding" .= ("gzip" :: Text),- "Content-Length" .= show (T.length contents)- ],- "files" .= emptyObject,- "form" .= emptyObject- ]- responseHeader r "Content-Type" `shouldBe` return "application/json"- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "receiving PUT form URL-encoded data back" $- it "works" $ do- let params =- "foo" =: ("bar" :: Text)- <> "baz" =: (5 :: Int)- <> queryFlag "quux"- r <- req PUT (httpbun /: "put") (ReqBodyUrlEnc params) jsonResponse mempty- (stripFunnyHeaders . stripOrigin) (responseBody r)- `shouldBe` object- [ "args" .= emptyObject,- "json" .= Null,- "data" .= ("" :: Text),- "url" .= ("https://httpbun.org/put" :: Text),- "method" .= ("PUT" :: Text),- "headers"- .= object- [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),- "Accept-Encoding" .= ("gzip" :: Text),- "Content-Length" .= ("18" :: Text)- ],- "files" .= emptyObject,- "form"- .= object- [ "foo" .= ("bar" :: Text),- "baz" .= ("5" :: Text),- "quux" .= ("" :: Text)- ]- ]- responseHeader r "Content-Type" `shouldBe` return "application/json"- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- -- describe "receiving UTF-8 encoded Unicode data" $- -- it "works" $ do- -- r <-- -- req- -- GET- -- (httpbun /: "encoding" /: "utf8")- -- NoReqBody- -- bsResponse- -- mempty- -- utf8data <- B.readFile "httpbun-data/utf8.html"- -- responseBody r `shouldBe` utf8data- -- responseStatusCode r `shouldBe` 200- -- responseStatusMessage r `shouldBe` "OK"-- describe "retrying" $- it "retries as many times as specified" $ do- -- FIXME We no longer can count retries because all the functions- -- responsible for controlling retrying are pure now.- let status = 408 :: Int- r <-- prepareForShit $- req- GET- (httpbun /: "status" /~ status)- NoReqBody- ignoreResponse- mempty- responseStatusCode r `shouldBe` status-- -- forM_ [101..102] checkStatusCode- forM_ [200 .. 208] checkStatusCode- -- forM_ [300..308] checkStatusCode- forM_ [400 .. 431] checkStatusCode- forM_ [500 .. 511] checkStatusCode-- describe "redirects" $- it "follows redirects" $ do- r <-- req- GET- (httpbun /: "redirect-to")- NoReqBody- ignoreResponse- ("url" =: ("https://httpbun.org" :: Text))- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "basicAuth" $ do- let user, password :: Text- user = "Scooby"- password = "Doo"- context "when we do not send appropriate basic auth data" $- it "fails with 401" $ do- r <-- prepareForShit $- req- GET- (httpbun /: "basic-auth" /~ user /~ password)- NoReqBody- ignoreResponse- mempty- responseStatusCode r `shouldBe` 401- responseStatusMessage r `shouldBe` "Unauthorized"- context "when we provide appropriate basic auth data" $- it "succeeds" $ do- r <-- req- GET- (httpbun /: "basic-auth" /~ user /~ password)- NoReqBody- ignoreResponse- (basicAuth (T.encodeUtf8 user) (T.encodeUtf8 password))- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "robots.txt" $- it "works" $ do- r <- req GET (httpbun /: "robots.txt") NoReqBody bsResponse mempty- robots <- B.readFile "httpbun-data/robots.txt"- responseBody r `shouldBe` robots- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"-- describe "getting random bytes" $ do- it "works" $- property $ \n' -> do- let n :: Word- n = getSmall n'- r <-- req- GET- (httpbun /: "bytes" /~ n)- NoReqBody- lbsResponse- mempty- responseBody r `shouldSatisfy` ((== n) . fromIntegral . BL.length)- responseStatusCode r `shouldBe` 200- responseStatusMessage r `shouldBe` "OK"- context "when we try to interpret 1000 random bytes as JSON" $- it "throws correct exception" $ do- let selector :: HttpException -> Bool- selector (JsonHttpException _) = True- selector _ = False- n :: Int- n = 1000- req- GET- (httpbun /: "bytes" /~ n)- NoReqBody- (Proxy :: Proxy (JsonResponse Value))- mempty- `shouldThrow` selector---- describe "streaming random bytes" $--- it "works" $--- property $ \n' -> do--- let n :: Word--- n = getSmall n'--- r <---- req--- GET--- (httpbun /: "stream-bytes" /~ n)--- NoReqBody--- bsResponse--- mempty--- responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)--- responseStatusCode r `shouldBe` 200--- responseStatusMessage r `shouldBe` "OK"--------------------------------------------------------------------------------- Instances--instance MonadHttp IO where- handleHttpException = throwIO--------------------------------------------------------------------------------- Helpers---- | Run a request with such settings that it does not signal errors.-prepareForShit :: Req a -> IO a-prepareForShit = runReq defaultHttpConfig {httpConfigCheckResponse = noNoise}- where- noNoise _ _ _ = Nothing---- | Run a request with such settings that it throws on any response.-blindlyThrowing :: Req a -> IO a-blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}- where- doit _ _ = error "Oops!"---- | 'Url' representing <https://httpbun.org>.-httpbun :: Url 'Https-httpbun = https "httpbun.org"---- | Remove “origin” field from JSON value. Origin may change, we don't want--- to depend on that.-stripOrigin :: Value -> Value-stripOrigin (Object m) = Object (Aeson.KeyMap.delete "origin" m)-stripOrigin value = value---- | Remove funny headers that might break the tests.-stripFunnyHeaders :: Value -> Value-stripFunnyHeaders (Object m) =- let f (Object p) = Object $ Aeson.KeyMap.filterWithKey (\k _ -> k `elem` hs) p- f value = value- hs =- [ "Content-Type",- "Accept-Encoding",- "Host",- "Content-Length",- "Foo",- "Baz"- ]- in Object (runIdentity (Aeson.KeyMap.alterF (pure . fmap f) "headers" m))-stripFunnyHeaders value = value---- | This is a complete test case that makes use of <https://httpbun.org> to--- get various response status codes.-checkStatusCode :: Int -> SpecWith ()-checkStatusCode code =- describe ("receiving status code " ++ show code) $- it "works" $ do- r <-- prepareForShit $- req- GET- (httpbun /: "status" /~ code)- NoReqBody- ignoreResponse- mempty- responseStatusCode r `shouldBe` code---- | Exception selector that selects only 404 “Not found” exceptions.-selector404 :: HttpException -> Bool-selector404- ( VanillaHttpException- ( L.HttpExceptionRequest- _- (L.StatusCodeException response chunk)- )- ) =- L.responseStatus response == Y.status404 && not (B.null chunk)-selector404 _ = False---- | Same as 'selector404' except that it uses 'isStatusCodeException'.-selector404ByStatusCodeException :: HttpException -> Bool-selector404ByStatusCodeException e =- case isStatusCodeException e of- Nothing -> False- Just r -> responseStatusCode r == 404---- | The empty JSON 'Object'.-emptyObject :: Value-emptyObject = Object Aeson.KeyMap.empty---- | Get a rendered JSON value as 'Text'.-reflectJSON :: (ToJSON a) => a -> Text-reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode---- | Clarify to the type checker that the inner computation is in the 'IO'--- monad.-asIO :: IO a -> IO a-asIO = id
− httpbun-tests/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
req.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.4 name: req-version: 3.13.1+version: 3.13.2 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov <markkarpov92@gmail.com> author: Mark Karpov <markkarpov92@gmail.com>-tested-with: ghc ==9.2.7 ghc ==9.4.4 ghc ==9.6.1+tested-with: ghc ==9.4.7 ghc ==9.6.3 ghc ==9.8.1 homepage: https://github.com/mrkkrp/req bug-reports: https://github.com/mrkkrp/req/issues synopsis: HTTP client library@@ -13,8 +13,8 @@ category: Network, Web build-type: Simple data-files:- httpbun-data/utf8.html- httpbun-data/robots.txt+ httpbin-data/utf8.html+ httpbin-data/robots.txt extra-doc-files: CHANGELOG.md@@ -35,23 +35,23 @@ build-depends: aeson >=0.9 && <3, authenticate-oauth >=1.5 && <1.8,- base >=4.15 && <5.0,+ base >=4.15 && <5, blaze-builder >=0.3 && <0.5,- bytestring >=0.10.8 && <0.12,+ bytestring >=0.10.8 && <0.13, case-insensitive >=0.2 && <1.3, containers >=0.5 && <0.7, crypton-connection >=0.2.2 && <0.4, exceptions >=0.6 && <0.11,- http-api-data >=0.2 && <0.6,+ http-api-data >=0.2 && <0.7, http-client >=0.7.13.1 && <0.8, http-client-tls >=0.3.2 && <0.4,- http-types >=0.8 && <10.0,+ http-types >=0.8 && <10, modern-uri >=0.3 && <0.4, monad-control >=1.0 && <1.1, mtl >=2.0 && <3.0, retry >=0.8 && <0.10,- template-haskell >=2.14 && <2.21,- text >=0.2 && <2.1,+ template-haskell >=2.19 && <2.22,+ text >=0.2 && <2.2, transformers >=0.5.3.0 && <0.7, transformers-base, unliftio-core >=0.1.1 && <0.3@@ -65,58 +65,60 @@ test-suite pure-tests type: exitcode-stdio-1.0 main-is: Spec.hs- build-tool-depends: hspec-discover:hspec-discover >=2.0 && <3.0+ build-tool-depends: hspec-discover:hspec-discover >=2 && <3 hs-source-dirs: pure-tests other-modules: Network.HTTP.ReqSpec default-language: GHC2021 build-depends:- QuickCheck >=2.7 && <3.0,+ QuickCheck >=2.7 && <3, aeson >=0.9 && <3, base >=4.15 && <5.0, blaze-builder >=0.3 && <0.5,- bytestring >=0.10.8 && <0.12,+ bytestring >=0.10.8 && <0.13, case-insensitive >=0.2 && <1.3,- hspec >=2.0 && <3.0,- hspec-core >=2.0 && <3.0,- http-api-data >=0.2 && <0.6,+ hspec >=2.0 && <3,+ hspec-core >=2.0 && <3,+ http-api-data >=0.2 && <0.7, http-client >=0.7 && <0.8,- http-types >=0.8 && <10.0,+ http-types >=0.8 && <10, modern-uri >=0.3 && <0.4,- mtl >=2.0 && <3.0, req, retry >=0.8 && <0.10,- template-haskell >=2.14 && <2.21,- text >=0.2 && <2.1,+ template-haskell >=2.19 && <2.22,+ text >=0.2 && <2.2, time >=1.2 && <1.13 if flag(dev)- ghc-options: -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else ghc-options: -O2 -Wall -test-suite httpbun-tests+test-suite httpbin-tests type: exitcode-stdio-1.0 main-is: Spec.hs- build-tool-depends: hspec-discover:hspec-discover >=2.0 && <3.0- hs-source-dirs: httpbun-tests+ build-tool-depends: hspec-discover:hspec-discover >=2 && <3+ hs-source-dirs: httpbin-tests other-modules: Network.HTTP.ReqSpec default-language: GHC2021 build-depends:- QuickCheck >=2.7 && <3.0,+ QuickCheck >=2.7 && <3, aeson >=2 && <3,- base >=4.15 && <5.0,- bytestring >=0.10.8 && <0.12,+ base >=4.15 && <5,+ bytestring >=0.10.8 && <0.13, hspec >=2.0 && <3.0, http-client >=0.7 && <0.8,- http-types >=0.8 && <10.0,+ http-types >=0.8 && <10, monad-control >=1.0 && <1.1,- mtl >=2.0 && <3.0, req,- text >=0.2 && <2.1+ text >=0.2 && <2.2 if flag(dev)- ghc-options: -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else- ghc-options: -O2 -Wall+ buildable: False