Ability to send non-valid Json payload in the request. Also introduce…

…d custom data types for request headers and payload.
cardano-foundation · Mar 29, 2019 · 90c2efc · 90c2efc
1 parent c9d272a
commit 90c2efc
Show file tree

Hide file tree

Showing 3 changed files with 52 additions and 13 deletions.
diff --git a/test/integration/Main.hs b/test/integration/Main.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Main where
 
@@ -111,16 +112,31 @@ dummySetup = do
 respCodesSpec :: SpecWith Context
 respCodesSpec = do
     it "GET; Response code 200" $ \ctx -> do
-        response <- request @Value ctx ("GET", "/get?my=arg") Nothing Nothing
+        response <- request @Value ctx ("GET", "/get?my=arg") Default Empty
         expectResponseCode @IO status200 response
 
     it "GET; Response code 404" $ \ctx -> do
-        response <- request @Value ctx ("GET", "/get/nothing") Nothing Nothing
+        response <- request @Value ctx ("GET", "/get/nothing") Default Empty
         expectResponseCode @IO status404 response
 
     it "POST; Response code 200" $ \ctx -> do
-        let header = [("dummy", "header")]
-        response <- request @Value ctx ("POST", "/post") (Just header) Nothing
+        let headers = Headers [("dummy", "header")]
+        let payload = Json [json| {
+                "addressPoolGap": 70,
+                "assuranceLevel": "strict",
+                "name": "Wallet EOS"
+                } |]
+        response <- request @Value ctx ("POST", "/post") headers payload
+        expectResponseCode @IO status200 response
+
+    it "POST; Response code 200" $ \ctx -> do
+        let headers = Headers [("dummy", "header")]
+        let payloadInvalid = NonJson "{\
+                        \\"addressPoolGap: 70,\
+                        \\"assuranceLevel\": strict,\
+                        \\"name\": \"Wallet EOS\"\
+                        \}"
+        response <- request @Value ctx ("POST", "/post") headers payloadInvalid
         expectResponseCode @IO status200 response
 
     it "POST; Response code 405" $ \ctx -> do

diff --git a/test/integration/Test/Integration/Framework/DSL.hs b/test/integration/Test/Integration/Framework/DSL.hs
@@ -9,6 +9,8 @@ module Test.Integration.Framework.DSL
     , expectSuccess
     , expectError
     , expectResponseCode
+    , Headers(..)
+    , Payload(..)
     , RequestException(..)
 
     -- * Helpers

diff --git a/test/integration/Test/Integration/Framework/Request.hs b/test/integration/Test/Integration/Framework/Request.hs
@@ -8,6 +8,8 @@
 module Test.Integration.Framework.Request
     ( request
     , unsafeRequest
+    , Headers(..)
+    , Payload(..)
     , RequestException(..)
     , Context(..)
     ) where
@@ -72,6 +74,19 @@ data RequestException
 
 instance Exception RequestException
 
+-- | The payload of the request
+data Payload
+    = Json Aeson.Value
+    | NonJson ByteString
+    | Empty
+
+-- | The headers of the request
+data Headers
+    = Headers RequestHeaders
+    | Default
+    | None
+
+-- | Makes a request to the API and decodes the response.
 request
     :: forall a m.
         ( FromJSON a
@@ -82,9 +97,9 @@ request
     => Context
     -> (Method, Text)
         -- ^ HTTP method and request path
-    -> Maybe RequestHeaders
+    -> Headers
         -- ^ Request headers
-    -> Maybe Aeson.Value
+    -> Payload
         -- ^ Request body
     -> m (HTTP.Status, Either RequestException a)
 request (Context _ (base, manager)) (verb, path) reqHeaders body = do
@@ -94,15 +109,21 @@ request (Context _ (base, manager)) (verb, path) reqHeaders body = do
     prepareReq :: HTTP.Request -> HTTP.Request
     prepareReq req = req
         { method = verb
-        , requestBody = maybe mempty (RequestBodyLBS . Aeson.encode) body
-        , requestHeaders = fromMaybe defaultHeaders reqHeaders
+        , requestBody = payload
+        , requestHeaders = headers
         }
+        where
+            headers = case h of
+                Headers x -> x
+                Default -> [ ("Content-Type", "application/json")
+                           , ("Accept", "application/json")
+                           ]
+                None -> mempty
 
-    defaultHeaders :: RequestHeaders
-    defaultHeaders =
-        [ ("Content-Type", "application/json")
-        , ("Accept", "application/json")
-        ]
+            payload = case body of
+                Json x -> (RequestBodyLBS . Aeson.encode) x
+                NonJson x -> RequestBodyLBS x
+                Empty -> mempty
 
     handleResponse res = case responseStatus res of
         s | s < status500 -> maybe