@@ -31,11 +31,96 @@
3131-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
3232-- POSSIBILITY OF SUCH DAMAGE.
3333
34+{-# LANGUAGE CPP #-}
35+{-# LANGUAGE DataKinds #-}
36+{-# LANGUAGE FlexibleInstances #-}
37+{-# LANGUAGE OverloadedStrings #-}
38+{-# OPTIONS_GHC -fno-warn-orphans #-}
39+
3440module Network.HTTP.ReqSpec
3541 ( spec )
3642where
3743
44+import Control.Exception (throwIO)
45+import Control.Monad.Reader
46+import Data.Aeson (Value (..), object, (.=))
47+import Data.HashMap.Strict (HashMap)
48+import Data.Monoid ((<>))
49+import Data.Text (Text)
50+import Network.HTTP.Req
3851import Test.Hspec
52+import qualified Data.HashMap.Strict as HM
53+
54+#if !MIN_VERSION_base(4,8,0)
55+import Data.Monoid (mempty)
56+#endif
3957
4058spec :: Spec
41−spec = return ()
59+spec = do
60+
61+ describe "exception throwing on non 2xx-status codes" $ do
62+ it "doesn't throw for 200" pending
63+ it "throws indeed for non-404" pending
64+
65+ describe "response check via httpConfigCheckResponse" $
66+ context "if it's set to always throw" $
67+ it "throws indeed" pending
68+
69+ describe "receiving user-agent header back" $
70+ it "works" $ do
71+ r <- req GET (httpbin /: "user-agent")
72+ NoReqBody jsonResponse (header "user-agent" "Req")
73+ responseBody r `shouldBe` object
74+ ["user-agent" .= ("Req" :: Text)]
75+ responseStatusCode r `shouldBe` 200
76+ responseStatusMessage r `shouldBe` "OK"
77+
78+ describe "receiving request headers back" $
79+ it "works" $ do
80+ r <- req GET (httpbin /: "headers")
81+ NoReqBody jsonResponse (header "Foo" "bar" <> header "Baz" "quux")
82+ responseBody r `shouldBe` object
83+ [ "headers" .= object
84+ [ "Accept-Encoding" .= ("gzip" :: Text)
85+ , "Foo" .= ("bar" :: Text)
86+ , "Baz" .= ("quux" :: Text)
87+ , "Host" .= ("httpbin.org" :: Text) ] ]
88+ responseStatusCode r `shouldBe` 200
89+ responseStatusMessage r `shouldBe` "OK"
90+
91+ describe "receiving GET data back" $
92+ it "works" $ do
93+ r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
94+ stripOrigin (responseBody r) `shouldBe` object
95+ [ "args" .= (HM.empty :: HashMap Text Text)
96+ , "url" .= ("https://httpbin.org/get" :: Text)
97+ , "headers" .= object
98+ [ "Accept-Encoding" .= ("gzip" :: Text)
99+ , "Host" .= ("httpbin.org" :: Text) ] ]
100+ responseStatusCode r `shouldBe` 200
101+ responseStatusMessage r `shouldBe` "OK"
102+
103+----------------------------------------------------------------------------
104+-- Instances
105+
106+instance MonadHttp IO where
107+ handleHttpException = throwIO
108+
109+instance MonadHttp (ReaderT HttpConfig IO) where
110+ handleHttpException = liftIO . throwIO
111+ getHttpConfig = ask
112+
113+----------------------------------------------------------------------------
114+-- Helpers
115+
116+-- | 'Url' representing <https://httpbin.org>.
117+
118+httpbin :: Url 'Https
119+httpbin = https "httpbin.org"
120+
121+-- | Remove “origin” field from JSON value. Origin may change, we don't want
122+-- to depend on that.
123+
124+stripOrigin :: Value -> Value
125+stripOrigin (Object m) = Object (HM.delete "origin" m)
126+stripOrigin value = value