@@ -44,17 +44,22 @@ where
45import Control.Exception (throwIO)
45import Control.Exception (throwIO)
46import Control.Monad.Reader
46import Control.Monad.Reader
47−import Data.Aeson (Value (..), object, (.=))
47+import Data.Aeson (Value (..), ToJSON (..), object, (.=))
48import Data.Default.Class
48import Data.Default.Class
49−import Data.HashMap.Strict (HashMap)
50import Data.Monoid ((<>))
49import Data.Monoid ((<>))
51import Data.Text (Text)
50import Data.Text (Text)
52import Network.HTTP.Req
51import Network.HTTP.Req
53import Test.Hspec
52import Test.Hspec
54import Test.QuickCheck
53import Test.QuickCheck
55−import qualified Data.ByteString as B
54+import qualified Data.Aeson as A
55+import qualified Data.ByteString as B
56−import qualified Data.HashMap.Strict as HM
56+import qualified Data.ByteString.Lazy as BL
57+import qualified Data.HashMap.Strict as HM
57−import qualified Data.Text.Encoding as T
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
59#if !MIN_VERSION_base(4,8,0)
64#if !MIN_VERSION_base(4,8,0)
60import Data.Monoid (mempty)
65import Data.Monoid (mempty)
@@ -64,13 +69,22 @@ import Data.Word (Word)
64spec :: Spec
69spec :: Spec
67− describe "exception throwing on non 2xx-status codes" $ do
72+ describe "exception throwing on non 2xx-status codes" $
68− it "doesn't throw for 200" pending
69− it "throws indeed for non-404" pending
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)
80+ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
81+ `shouldThrow` selector
71 describe "response check via httpConfigCheckResponse" $
83 describe "response check via httpConfigCheckResponse" $
72 context "if it's set to always throw" $
84 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
75 describe "receiving user-agent header back" $
89 describe "receiving user-agent header back" $
76 it "works" $ do
90 it "works" $ do
@@ -98,7 +112,7 @@ spec = do
98 it "works" $ do
112 it "works" $ do
99 r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
113 r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
100 stripOrigin (responseBody r) `shouldBe` object
114 stripOrigin (responseBody r) `shouldBe` object
101− [ "args" .= (HM.empty :: HashMap Text Text)
115+ [ "args" .= emptyObject
102 , "url" .= ("https://httpbin.org/get" :: Text)
116 , "url" .= ("https://httpbin.org/get" :: Text)
103 , "headers" .= object
117 , "headers" .= object
104 [ "Accept-Encoding" .= ("gzip" :: Text)
118 [ "Accept-Encoding" .= ("gzip" :: Text)
@@ -106,9 +120,62 @@ spec = do
106 responseStatusCode r `shouldBe` 200
120 responseStatusCode r `shouldBe` 200
107 responseStatusMessage r `shouldBe` "OK"
121 responseStatusMessage r `shouldBe` "OK"
109− -- TODO /post
123+ describe "receiving POST JSON data back" $
110− -- TODO /patch
124+ it "works" $ do
111− -- TODO /put
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
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 ]
141+ describe "receiving PATCHed file back" $
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
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 ]
159+ describe "receiving PUT form URL-encoded data back" $
161+ let params = "foo" =: ("bar" :: Text) <>
163+ r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
164+ stripOrigin (responseBody r) `shouldBe` object
165+ [ "args" .= emptyObject
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
176+ [ "foo" .= ("bar" :: Text)
177+ , "baz" .= ("5" :: Text) ] ]
112 -- TODO /delete
179 -- TODO /delete
114 describe "receiving UTF-8 encoded Unicode data" $
181 describe "receiving UTF-8 encoded Unicode data" $
@@ -234,6 +301,14 @@ prepareForShit
234prepareForShit m = runReaderT m def { httpConfigCheckResponse = noNoise }
301prepareForShit m = runReaderT m def { httpConfigCheckResponse = noNoise }
235 where noNoise _ _ = return ()
302 where noNoise _ _ = return ()
304+-- | Run request with such settings that it throws on any response.
307+ :: (forall m. MonadHttp m => m a)
309+blindlyThrowing m = runReaderT m def { httpConfigCheckResponse = doit }
310+ where doit _ _ = error "Oops!"
237-- | 'Url' representing <https://httpbin.org>.
312-- | 'Url' representing <https://httpbin.org>.
239httpbin :: Url 'Https
314httpbin :: Url 'Https
@@ -256,3 +331,13 @@ checkStatusCode code =
256 r <- prepareForShit $ req GET (httpbin /: "status" /~ code)
331 r <- prepareForShit $ req GET (httpbin /: "status" /~ code)
257 NoReqBody ignoreResponse mempty
332 NoReqBody ignoreResponse mempty
258 responseStatusCode r `shouldBe` code
333 responseStatusCode r `shouldBe` code
335+-- | Empty JSON 'Object'.
338+emptyObject = Object HM.empty
340+-- | Get rendered JSON value as 'Text'.
342+reflectJSON :: ToJSON a => a -> Text
343+reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode