Adds support for URLEncoded request bodies on the requestData field (#52

) * Adds support for URLEncoded request bodies on the requestData field To set a URLEncoded body set bodyType to urlencoded: requestData: bodyType: urlencoded content: a: b c: d e: f To set a JSON body set bodyType to json: requestData: bodyType: json content: a: b c: d e: f In either case the body is formed from the value of the content key. The change is backwards compatible so that the following: requestData: a: b c: d e: A will send a JSON body formed from the value of the requestData key. * Adds queryParameters to example JSON specification. * Adds `requestData` enhancements to JSON and YAML example specs. * Moves KeyValuePairs type into its own module * Adds tests for decoding KeyValuePairs * Moves Payload to its own module and adds documentation. * Adds tests for Payload
aviaviavi · Feb 19, 2020 · 36b1a32 · 36b1a32
1 parent 5353210
commit 36b1a32
Show file tree

Hide file tree

Showing 9 changed files with 287 additions and 52 deletions.
diff --git a/curl-runnings.cabal b/curl-runnings.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d7e8fd8b9ac832b7f655ad0afb08922e6d81f002810f33a8785f57504b9e38f3
+-- hash: 47e14a53d64cd8b70caa137bf6d6d5d667b4b75064f6cebc3ed82c11072d6258
 
 name:           curl-runnings
 version:        0.11.1
@@ -37,6 +37,8 @@ library
       Testing.CurlRunnings.Internal
       Testing.CurlRunnings.Internal.Parser
       Testing.CurlRunnings.Internal.Headers
+      Testing.CurlRunnings.Internal.KeyValuePairs
+      Testing.CurlRunnings.Internal.Payload
   other-modules:
       Paths_curl_runnings
   hs-source-dirs:
@@ -93,10 +95,13 @@ test-suite curl-runnings-test
       test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.0 && <5
+      aeson >=1.2.4.0
+    , base >=4.0 && <5
+    , bytestring >=0.10.8.2
     , curl-runnings
     , directory >=1.3.0.2
     , hspec >=2.4.4
     , hspec-expectations >=0.8.2
+    , raw-strings-qq >=1.1
     , text >=1.2.2.2
   default-language: Haskell2010
diff --git a/examples/example-spec.json b/examples/example-spec.json
@@ -3,6 +3,9 @@
     "name": "test 1",
     "url": "http://your-endpoint.com/status",
     "requestMethod": "GET",
+    "queryParameters": {
+       "key": "value"
+    },
     "expectData": {
       "exactly": {
         "okay": true,
@@ -26,6 +29,22 @@
   },
   {
     "name": "test 3",
+    "url": "http://your-endpoint.com/path",
+    "requestMethod": "POST",
+    "expectStatus": [
+      200,
+      201
+    ],
+    "requestData": {
+      "bodyType": "urlencoded",
+      "content": {
+        "hello": "there",
+        "num": 1
+      }
+    }
+  },
+  {
+    "name": "test 4",
     "url": "http://your-url.com/other/path",
     "requestMethod": "GET",
     "expectData": {
@@ -44,7 +63,7 @@
     "expectStatus": 200
   },
   {
-    "name": "test 4",
+    "name": "test 5",
     "url": "http://your-url.com/other/path",
     "requestMethod": "GET",
     "expectData": {
@@ -63,7 +82,7 @@
     "expectStatus": 200
   },
   {
-    "name": "test 5",
+    "name": "test 6",
     "url": "http://your-url.com/other/path",
     "requestMethod": "GET",
     "expectData": {
@@ -84,15 +103,15 @@
     "expectStatus": 200
   },
   {
-    "name": "test 6",
+    "name": "test 7",
     "url": "http://your-url.com/other/path",
     "requestMethod": "GET",
     "headers": "Content-Type: application/json",
     "expectStatus": 200,
     "expectHeaders": "Content-Type: application/json; Hello: world"
   },
   {
-    "name": "test 7",
+    "name": "test 8",
     "url": "http://your-url.com/other/path",
     "requestMethod": "GET",
     "headers": "Content-Type: application/json",
@@ -104,7 +123,7 @@
     ]
   },
   {
-    "name": "test 8",
+    "name": "test 9",
     "url": "http://your-url.com/other/path",
     "requestMethod": "GET",
     "headers": "Content-Type: application/json",

diff --git a/examples/example-spec.yaml b/examples/example-spec.yaml
@@ -34,6 +34,22 @@ cases:
       num: 1
 
   - name: test 3
+    url: http://your-endpoint.com/path
+    requestMethod: POST
+    expectStatus:
+    - 200
+    - 201
+    # [Optional] Data to send with the request.
+    requestData:
+      # `bodyType` specifies the type of request payload. Possible values
+      # are `urlencoded` | `json`.
+      bodyType: urlencoded
+      content:
+        # This object specifies the data to send with the request.
+        hello: there
+        num: 1
+
+  - name: test 4
     url: http://your-url.com/other/path
     requestMethod: GET
     expectData:
@@ -54,7 +70,7 @@ cases:
       - keyMatch: okay
     expectStatus: 200
 
-  - name: test 4
+  - name: test 5
     url: http://your-url.com/other/path
     requestMethod: GET
     expectData:
@@ -70,7 +86,7 @@ cases:
       - keyMatch: error
     expectStatus: 200
 
-  - name: test 5
+  - name: test 6
     url: http://your-url.com/other/path
     requestMethod: GET
     expectData:
@@ -83,7 +99,7 @@ cases:
       - valueMatch: false
     expectStatus: 200
 
-  - name: test 6
+  - name: test 7
     url: http://your-url.com/other/path
     requestMethod: GET
     # Specify the headers you want to sent, just like the -H flag in a curl command
@@ -94,7 +110,7 @@ cases:
     # Header strings again match the -H syntax from curl
     expectHeaders: "Content-Type: application/json; Hello: world"
 
-  - name: test 7
+  - name: test 8
     url: http://your-url.com/other/path
     requestMethod: GET
     headers: "Content-Type: application/json"
@@ -104,7 +120,7 @@ cases:
     -
       key: "Key-With-Val-We-Dont-Care-About"
 
-  - name: test 8
+  - name: test 9
     url: http://your-url.com/other/path
     requestMethod: GET
     headers: "Content-Type: application/json"
@@ -114,4 +130,3 @@ cases:
     - "Hello: world"
     -
       value: "Value-With-Key-We-Dont-Care-About"
-
diff --git a/package.yaml b/package.yaml
@@ -25,6 +25,8 @@ library:
   - Testing.CurlRunnings.Internal
   - Testing.CurlRunnings.Internal.Parser
   - Testing.CurlRunnings.Internal.Headers
+  - Testing.CurlRunnings.Internal.KeyValuePairs
+  - Testing.CurlRunnings.Internal.Payload
   dependencies:
   - aeson >=1.2.4.0
   - bytestring >=0.10.8.2
@@ -75,8 +77,11 @@ tests:
     - -rtsopts
     - -with-rtsopts=-N
     dependencies:
+    - bytestring >=0.10.8.2
     - curl-runnings
     - directory >=1.3.0.2
+    - aeson >=1.2.4.0
     - hspec >= 2.4.4
     - hspec-expectations >=0.8.2
+    - raw-strings-qq >= 1.1
     - text >=1.2.2.2
diff --git a/src/Testing/CurlRunnings.hs b/src/Testing/CurlRunnings.hs
@@ -71,10 +71,16 @@ noVerifyTlsSettings =
   }
 
 -- | Fetch existing query parameters from the request and append those specfied in the queryParameters field.
-appendQueryParameters :: [QueryParameter] -> Request -> Request
+appendQueryParameters :: [KeyValuePair] -> Request -> Request
 appendQueryParameters newParams r = setQueryString (existing ++ newQuery) r where
   existing = NT.parseQuery $ queryString r
-  newQuery = NT.simpleQueryToQuery $ fmap (\(QueryParameter k v) -> (T.encodeUtf8 k, T.encodeUtf8 v)) newParams
+  newQuery = NT.simpleQueryToQuery $ fmap (\(KeyValuePair k v) -> (T.encodeUtf8 k, T.encodeUtf8 v)) newParams
+
+setPayload :: Maybe Payload -> Request -> Request
+setPayload Nothing = id
+setPayload (Just (JSON v)) = setRequestBodyJSON v
+setPayload (Just (URLEncoded (KeyValuePairs xs))) = setRequestBodyURLEncoded $ kvpairs xs where
+  kvpairs = fmap (\(KeyValuePair k v) -> (T.encodeUtf8 k, T.encodeUtf8 v))
 
 -- | Run a single test case, and returns the result. IO is needed here since this method is responsible
 -- for actually curling the test case endpoint and parsing the result.
@@ -83,34 +89,33 @@ runCase state@(CurlRunningsState _ _ _ tlsCheckType) curlCase = do
   let eInterpolatedUrl = interpolateQueryString state $ url curlCase
       eInterpolatedHeaders =
         interpolateHeaders state $ fromMaybe (HeaderSet []) (headers curlCase)
-      eInterpolatedQueryParams = interpolateViaJSON state $ fromMaybe (QueryParameters []) (queryParameters curlCase)
+      eInterpolatedQueryParams = interpolateViaJSON state $ fromMaybe (KeyValuePairs []) (queryParameters curlCase)
   case (eInterpolatedUrl, eInterpolatedHeaders, eInterpolatedQueryParams) of
     (Left err, _, _) ->
       return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] 0
     (_, Left err, _) ->
       return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] 0
     (_, _, Left err) ->
       return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] 0
-    (Right interpolatedUrl, Right interpolatedHeaders, Right (QueryParameters interpolatedQueryParams)) ->
-      case sequence $ runReplacements state <$> requestData curlCase of
+    (Right interpolatedUrl, Right interpolatedHeaders, Right (KeyValuePairs interpolatedQueryParams)) ->
+      case sequence $ interpolateViaJSON state <$> requestData curlCase of
         Left l ->
           return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase l] 0
-        Right replacedJSON -> do
+        Right interpolatedData -> do
           initReq <- parseRequest $ T.unpack interpolatedUrl
           manager <- newManager noVerifyTlsManagerSettings
 
           let !request =
-                  setRequestBodyJSON (fromMaybe emptyObject replacedJSON) .
-                  setRequestHeaders (toHTTPHeaders interpolatedHeaders) .
-                  appendQueryParameters interpolatedQueryParams  .
-                  (if tlsCheckType == DoTLSCheck then id else (setRequestManager manager)) $
-                  initReq {method = B8S.pack . show $ requestMethod curlCase}
-
+                setPayload interpolatedData .
+                setRequestHeaders (toHTTPHeaders interpolatedHeaders) .
+                appendQueryParameters interpolatedQueryParams  .
+                (if tlsCheckType == DoTLSCheck then id else (setRequestManager manager)) $
+                initReq {method = B8S.pack . show $ requestMethod curlCase}
           logger state DEBUG (pShow request)
           logger
             state
             DEBUG
-            ("Request body: " <> (pShow $ fromMaybe emptyObject replacedJSON))
+            ("Request body: " <> (pShow $ fromMaybe (JSON emptyObject) interpolatedData))
           start <- nowMillis
           response <- httpBS request
           stop <- nowMillis

diff --git a/src/Testing/CurlRunnings/Internal/KeyValuePairs.hs b/src/Testing/CurlRunnings/Internal/KeyValuePairs.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | A module defining the KeyValuePairs type. This type may be used to
+-- represent a structure in a specification that is a collection of
+-- key-vaue pairs. For example query parameters and URLEncoded request
+-- bodies.
+--
+-- The module provides FromJSON and ToJSON instances for KeyValuePairs.
+-- Valid KeyValuePairs JSON is a single JSON object where all values
+-- are either String, Scienfific or Bool.
+
+module Testing.CurlRunnings.Internal.KeyValuePairs
+  ( KeyValuePairs (..)
+  , KeyValuePair (..)
+  ) where
+
+import           Data.Aeson
+import           Data.Aeson.Types
+import qualified Data.ByteString.Lazy as LBS
+import           Data.HashMap.Strict  as H
+import qualified Data.Text            as T
+import           Data.Text.Encoding   as T
+
+-- | A container for a list of key-value pairs
+newtype KeyValuePairs = KeyValuePairs [KeyValuePair] deriving Show
+
+-- | A representation of a single key-value pair
+data KeyValuePair = KeyValuePair T.Text T.Text deriving Show
+
+instance ToJSON KeyValuePairs where
+  toJSON (KeyValuePairs qs) =
+    object (fmap (\(KeyValuePair k v) -> k .= toJSON v) qs)
+
+instance FromJSON KeyValuePairs where
+  parseJSON = withObject "keyValuePairs" parseKeyValuePairs where
+    parseKeyValuePairs o = KeyValuePairs <$> traverse parseKeyValuePair (H.toList o)
+    parseKeyValuePair (t, v) = KeyValuePair t <$> parseSingleValueType v
+
+parseSingleValueType :: Value -> Parser T.Text
+parseSingleValueType (Bool b)   = parseToText b
+parseSingleValueType (String t) = return t
+parseSingleValueType (Number n) = parseToText n
+parseSingleValueType invalid    = typeMismatch "KeyValuePairs" invalid
+
+parseToText :: (ToJSON a) => a -> Parser T.Text
+parseToText = return . T.decodeUtf8 . LBS.toStrict . encode