@@ -44,17 +44,22 @@ where
4444
4545import Control.Exception (throwIO)
4646import Control.Monad.Reader
47−import Data.Aeson (Value (..), object, (.=))
47+import Data.Aeson (Value (..), ToJSON (..), object, (.=))
4848import Data.Default.Class
49−import Data.HashMap.Strict (HashMap)
5049import Data.Monoid ((<>))
5150import Data.Text (Text)
5251import Network.HTTP.Req
5352import Test.Hspec
5453import Test.QuickCheck
55−import qualified Data.ByteString as B
56−import qualified Data.HashMap.Strict as HM
57−import qualified Data.Text.Encoding as T
54+import qualified Data.Aeson as A
55+import qualified Data.ByteString as B
56+import qualified Data.ByteString.Lazy as BL
57+import qualified Data.HashMap.Strict as HM
58+import qualified Data.Text as T
59+import qualified Data.Text.Encoding as T
60+import qualified Data.Text.IO as TIO
61+import qualified Network.HTTP.Client as L
62+import qualified Network.HTTP.Types as Y
5863
5964#if !MIN_VERSION_base(4,8,0)
6065import Data.Monoid (mempty)
@@ -64,13 +69,22 @@ import Data.Word (Word)
6469spec :: Spec
6570spec = do
6671
67− describe "exception throwing on non 2xx-status codes" $ do
68− it "doesn't throw for 200" pending
69− it "throws indeed for non-404" pending
72+ describe "exception throwing on non 2xx-status codes" $
73+ it "throws indeed for non-2xx" $ do
74+ let selector :: HttpException -> Bool
75+ selector (VanillaHttpException
76+ (L.HttpExceptionRequest _
77+ (L.StatusCodeException response chunk))) =
78+ L.responseStatus response == Y.status404 && not (B.null chunk)
79+ selector _ = False
80+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
81+ `shouldThrow` selector
7082
7183 describe "response check via httpConfigCheckResponse" $
7284 context "if it's set to always throw" $
73− it "throws indeed" pending
85+ it "throws indeed" $
86+ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty)
87+ `shouldThrow` anyException
7488
7589 describe "receiving user-agent header back" $
7690 it "works" $ do
@@ -98,7 +112,7 @@ spec = do
98112 it "works" $ do
99113 r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
100114 stripOrigin (responseBody r) `shouldBe` object
101− [ "args" .= (HM.empty :: HashMap Text Text)
115+ [ "args" .= emptyObject
102116 , "url" .= ("https://httpbin.org/get" :: Text)
103117 , "headers" .= object
104118 [ "Accept-Encoding" .= ("gzip" :: Text)
@@ -106,9 +120,62 @@ spec = do
106120 responseStatusCode r `shouldBe` 200
107121 responseStatusMessage r `shouldBe` "OK"
108122
109− -- TODO /post
110− -- TODO /patch
111− -- TODO /put
123+ describe "receiving POST JSON data back" $
124+ it "works" $ do
125+ let text = "foo" :: Text
126+ reflected = reflectJSON text
127+ r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty
128+ stripOrigin (responseBody r) `shouldBe` object
129+ [ "args" .= emptyObject
130+ , "json" .= text
131+ , "data" .= reflected
132+ , "url" .= ("https://httpbin.org/post" :: Text)
133+ , "headers" .= object
134+ [ "Content-Type" .= ("application/json; charset=utf-8" :: Text)
135+ , "Accept-Encoding" .= ("gzip" :: Text)
136+ , "Host" .= ("httpbin.org" :: Text)
137+ , "Content-Length" .= show (T.length reflected) ]
138+ , "files" .= emptyObject
139+ , "form" .= emptyObject ]
140+
141+ describe "receiving PATCHed file back" $
142+ it "works" $ do
143+ let file :: FilePath
144+ file = "httpbin-data/robots.txt"
145+ contents <- TIO.readFile file
146+ r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty
147+ stripOrigin (responseBody r) `shouldBe` object
148+ [ "args" .= emptyObject
149+ , "json" .= Null
150+ , "data" .= contents
151+ , "url" .= ("https://httpbin.org/patch" :: Text)
152+ , "headers" .= object
153+ [ "Accept-Encoding" .= ("gzip" :: Text)
154+ , "Host" .= ("httpbin.org" :: Text)
155+ , "Content-Length" .= show (T.length contents) ]
156+ , "files" .= emptyObject
157+ , "form" .= emptyObject ]
158+
159+ describe "receiving PUT form URL-encoded data back" $
160+ it "works" $ do
161+ let params = "foo" =: ("bar" :: Text) <>
162+ "baz" =: (5 :: Int)
163+ r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
164+ stripOrigin (responseBody r) `shouldBe` object
165+ [ "args" .= emptyObject
166+ , "json" .= Null
167+ , "data" .= ("" :: Text)
168+ , "url" .= ("https://httpbin.org/put" :: Text)
169+ , "headers" .= object
170+ [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text)
171+ , "Accept-Encoding" .= ("gzip" :: Text)
172+ , "Host" .= ("httpbin.org" :: Text)
173+ , "Content-Length" .= ("13" :: Text) ]
174+ , "files" .= emptyObject
175+ , "form" .= object
176+ [ "foo" .= ("bar" :: Text)
177+ , "baz" .= ("5" :: Text) ] ]
178+
112179 -- TODO /delete
113180
114181 describe "receiving UTF-8 encoded Unicode data" $
@@ -234,6 +301,14 @@ prepareForShit
234301prepareForShit m = runReaderT m def { httpConfigCheckResponse = noNoise }
235302 where noNoise _ _ = return ()
236303
304+-- | Run request with such settings that it throws on any response.
305+
306+blindlyThrowing
307+ :: (forall m. MonadHttp m => m a)
308+ -> IO a
309+blindlyThrowing m = runReaderT m def { httpConfigCheckResponse = doit }
310+ where doit _ _ = error "Oops!"
311+
237312-- | 'Url' representing <https://httpbin.org>.
238313
239314httpbin :: Url 'Https
@@ -256,3 +331,13 @@ checkStatusCode code =
256331 r <- prepareForShit $ req GET (httpbin /: "status" /~ code)
257332 NoReqBody ignoreResponse mempty
258333 responseStatusCode r `shouldBe` code
334+
335+-- | Empty JSON 'Object'.
336+
337+emptyObject :: Value
338+emptyObject = Object HM.empty
339+
340+-- | Get rendered JSON value as 'Text'.
341+
342+reflectJSON :: ToJSON a => a -> Text
343+reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode