diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # curl-runnings -[![Build Status](https://travis-ci.org/aviaviavi/curl-runnings.svg?branch=master)](https://travis-ci.org/aviaviavi/curl-runnings) +[![Build Status](https://travis-ci.org/aviaviavi/curl-runnings.svg?branch=master)](https://travis-ci.org/aviaviavi/curl-runnings) [![Hackage](https://img.shields.io/hackage/v/curl-runnings.svg)](https://hackage.haskell.org/package/curl-runnings) _Feel the rhythm! Feel the rhyme! Get on up, it's testing time! curl-runnings!_ @@ -10,17 +10,22 @@ against responses. Alternatively, you can use the curl-runnings library to write your tests in -Haskell (though a haskell setup is absolutely not required to use this tool). +Haskell (though a Haskell setup is absolutely not required to use this tool). ### Why? -When writing curl based smoke/integration tests for APIs using bash and `curl` -is very convenient, but quickly becomes hard to maintain. Writing matchers for -json output quickly becomes unweildy and error prone. Writing these sorts of -tests in a more traditional programming language is fine, but certainly more -time consuming to write than some simple curl requests. curl-runnings aims to -make it very easy to write tests that just hit some endpoints and verify the -output looks sane. +This library came out of a pain-point my coworkers at +[DotDashPay](https://dotdashpay.com) and I were running into during development: +Writing integration tests for our APIs was generally annoying. They were time +consuming to write especially considering how basic they were, and we are a +small startup where developer time is in short supply. Over time, we found +ourselves sometimes just writing bash scripts that would `curl` our various +endpoints and check the output with very basic matchers. These tests were fast +to write, but quickly became difficult to maintain as complexity was added. Not +only did maintenance become challenging, but the whole system was very error prone +and confidence in the tests overall was decreasing. At the end of the day, we +needed to just curl some endpoints and verify the output looks sane, and do this +quickly and correctly. This is precisely the goal of curl-runnings. Now you can write your tests just as data in a yaml or json file, and curl-runnings will take care of the rest! @@ -28,52 +33,76 @@ While yaml/json is the current way to write curl-runnings tests, this project is being built in a way that should lend itself well to an embedded domain specific language, which is a future goal for the project. curl-runnings specs in Dhall -is also being developed and may fufill the same needs. +is also being developed and may fulfill the same needs. ### Installing There are few options to install: -- download the releases from the +- download the Linux or Mac built releases from the github [releases page](https://github.com/aviaviavi/curl-runnings/releases) - install the binary with `stack` or `cabal` - build from source with `stack` ### Writing a test specification -Write your tests specs in a yaml or json file. See /examples to get -started. A test spec is a top level array of test cases, each item represents a -single curl and set of assertions about the response. +Curl runnings tests are just data! A test spec is an object containing an array +of `cases`, where each item represents a single curl and set of assertions about +the response. Write your tests specs in a yaml or json file. Note: the legacy +format of a top level array of test cases is still supported, but may not be in +future releases. + +```yaml +--- +# example-test.yaml +# +# specify all your test cases as an array keys on `cases` +cases: + - name: A curl runnings test case + url: http://your-endpoint.com/status + requestMethod: GET + # Specify the json payload we expect here + expectData: + # The 1 key in this object specifies the matcher we want + # to use to test the returned payload. In this case, we + # require the payload is exactly what we specify. + exactly: + okay: true + msg: 'a message' + # Assertions about the returned status code. Pass in + # an acceptable code or list of codes + expectStatus: 200 + +``` + +See /examples for more example curl runnings specifications, which walk +through some of the other features that can be encoded in your tests such as: +- reference data from previous responses of previous test cases +- reference environment variables +- various easy-to-use json matchers +- support for importing data from other yaml files in your spec + ### Running Once you've written a spec, simply run it with: -```bash $ curl-runnings -f path/to/your/spec.yaml ``` +```curl-runnings -f path/to/your/spec.yaml ``` +(hint: try using the --verbose flag for more output) + If all your tests pass, curl-runnings will cleanly exit with a 0 code. A code of 1 will be returned if any tests failed. +You can also select specific test cases by filtering via regex by using the +`--grep` flag. Just make sure your case isn't referencing data from previous +examples that won't get run! + For more info: -```bash $ curl-runnings --help ``` +```curl-runnings --help ``` ### Contributing -Curl-runnings is totally usable now but is also being actively developed. Contributions in any form are welcome and encouraged. Don't be shy! :D -### Roadmap - -- [x] Json specifications for tests -- [x] Yaml specifications for tests -- [ ] Dhall specifications for tests -- [ ] More specification features - - [x] Reference values from previous json responses in matchers - - [x] Environment variable interpolation - - [ ] Call out to arbitrary shell commands in and between test cases - - [ ] Timeouts - - [ ] Support for non-json content type - - [ ] Retry logic -- [ ] A DSL for writing test specs - diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,48 +1,186 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Main where +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZ +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy as B +import Data.List +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.Monoid import qualified Data.Text as T import Data.Version (showVersion) +import GHC.Generics +import Network.HTTP.Conduit +import Network.HTTP.Simple import Paths_curl_runnings (version) import System.Console.CmdArgs +import System.Directory import System.Environment import System.Exit +import System.Info import Testing.CurlRunnings import Testing.CurlRunnings.Internal import Testing.CurlRunnings.Types -- | Command line flags data CurlRunnings = CurlRunnings - { file :: FilePath + { file :: FilePath + , grep :: Maybe T.Text + , upgrade :: Bool } deriving (Show, Data, Typeable, Eq) -- | cmdargs object argParser :: CurlRunnings argParser = - CurlRunnings {file = def &= typFile &= help "File to run"} &= + CurlRunnings + { file = def &= typFile &= help "File to run" + , grep = def &= help "Regex to filter test cases by name" + , upgrade = def &= help "Pull the latest version of curl runnings" + } &= summary ("curl-runnings " ++ showVersion version) &= program "curl-runnings" &= verbosity &= help "Use the --file or -f flag to specify an intput file spec to run" -runFile :: FilePath -> Verbosity -> IO () -runFile "" _ = +-- | A single release asset in a github release. Eg curl-runnings-${version}.tar.gz +data GithubReleaseAsset = GithubReleaseAsset + { name :: T.Text + , browser_download_url :: T.Text -- snake case because that's what we get back from github + } deriving (Show, Generic) + +instance FromJSON GithubReleaseAsset + +-- | The json response we expect from github when we check for the latest release +data GithubRelease = GithubRelease + { assets :: [GithubReleaseAsset] + , tag_name :: T.Text -- snake case because that's what we get back from github + } deriving (Show, Generic) +instance FromJSON GithubRelease + +newtype GithubReleasesResponse = + GithubReleasesResponse (NE.NonEmpty GithubRelease) + deriving (Show, Generic) +instance FromJSON GithubReleasesResponse + +-- | Github requires a user agent, preferably with a username +setGithubReqHeaders :: Request -> Request +setGithubReqHeaders = setRequestHeaders [("User-Agent", "aviaviavi")] + +runFile :: FilePath -> Verbosity -> Maybe T.Text -> IO () +runFile "" _ _ = putStrLn "Please specify an input file with the --file (-f) flag or use --help for more information" -runFile path verbosityLevel = do +runFile path verbosityLevel regexp = do home <- getEnv "HOME" suite <- decodeFile . T.unpack $ T.replace "~" (T.pack home) (T.pack path) case suite of Right s -> do - results <- runSuite s $ toLogLevel verbosityLevel + results <- + runSuite (s {suiteCaseFilter = regexp}) $ toLogLevel verbosityLevel if any isFailing results - then putStrLn (makeRed "Some tests failed") >> exitWith (ExitFailure 1) - else putStrLn $ makeGreen "All tests passed!" - Left messgage -> - putStrLn . makeRed $ "Couldn't read input json or yaml file: " ++ messgage + then putStrLn (T.unpack $ makeRed "Some tests failed") >> + exitWith (ExitFailure 1) + else putStrLn . T.unpack $ makeGreen "All tests passed!" + Left message -> + (putStrLn . T.unpack . makeRed . T.pack $ + "Couldn't read input json or yaml file: " <> message) >> + exitWith (ExitFailure 1) +-- | If we're on mac, we want a *-mac tarball from the releases page. If we're on linux we +-- do not +filterAsset :: [GithubReleaseAsset] -> Maybe GithubReleaseAsset +filterAsset assetList = find filterFn assetList + where + filterFn' a = "mac" `T.isInfixOf` Main.name a + filterFn = + if os == "darwin" + then filterFn' + else not . filterFn' + +-- | From the list of releases on github, find the newest release that has a binary +-- tarball for the platform we're on. +findAssetFromReleases :: GithubReleasesResponse -> Maybe GithubReleaseAsset +findAssetFromReleases (GithubReleasesResponse releases) = + let assetList = map (filterAsset . assets) $ NE.toList releases + in join $ find isJust assetList + +-- | We'll upgrade any time the latest version is different from what we have +shouldUpgrade :: GithubReleaseAsset -> Bool +shouldUpgrade asset = + let assetNameTokens = T.splitOn "-" (Main.name asset) + in if length assetNameTokens `notElem` [3, 4] + then False + else (T.replace ".tar.gz" "" (assetNameTokens !! 2)) /= T.pack (showVersion version) + +-- | If conditions are met, download the appropriate tarball from the latest +-- github release, extract and copy to /usr/local/bin +upgradeCurlRunnings :: IO () +upgradeCurlRunnings = + let tmpArchive = "/tmp/curl-runnings-latest.tar.gz" + tmpArchiveExtracedFolder = "/tmp/curl-runnings-latest" + tmpExtractedBin = tmpArchiveExtracedFolder ++ "/curl-runnings" + installPath = "/usr/local/bin/curl-runnings" + in do req <- + parseRequest + "https://api.github.com/repos/aviaviavi/curl-runnings/releases" + req' <- return $ setGithubReqHeaders req + resp <- httpBS req' + decoded <- return $ eitherDecode' . B.fromStrict $ getResponseBody resp + case decoded of + Right r -> + let asset = findAssetFromReleases r + in if maybe False shouldUpgrade asset + then case asset of + (Just a) -> do + let downloadUrl = browser_download_url a + putStrLn + "Getting the latest version of curl-runnings..." + downloadResp <- + httpBS . setGithubReqHeaders =<< + (parseRequest $ T.unpack downloadUrl) + _ <- + B.writeFile + tmpArchive + (B.fromStrict $ getResponseBody downloadResp) + putStrLn "Extracting..." + Tar.unpack tmpArchiveExtracedFolder . + Tar.read . GZ.decompress =<< + B.readFile tmpArchive + putStrLn "Copying..." + permissions <- getPermissions tmpExtractedBin + setPermissions + tmpExtractedBin + (setOwnerExecutable True permissions) + copyFile tmpExtractedBin installPath + putStrLn $ + "The latest version curl-runnings has been installed to /usr/local/bin. " ++ + "If you are using curl-runnings from a different location," ++ + " please update your environment accordingly." + -- We got a good response from github, but no asset for our platform was there + Nothing -> do + putStrLn . T.unpack $ + makeRed "Error upgrading curl-runnings" + putStrLn $ + "No asset found from github. It's possible the binary for your " ++ + "platform hasn't yet been uploaded to the latest release. Please wait and try again. " ++ + "If the issue persists, please open an issue at https://github.com/aviaviavi/curl-runnings/issues." + exitWith (ExitFailure 1) + -- No upgrade required + else putStrLn $ + "curl-runnings is already at the newest version: " ++ + showVersion version ++ ". Nothing to upgrade." + -- Coudn't decode github response + Left err -> do + putStrLn . T.unpack $ makeRed "Error upgrading curl-runnings" + putStrLn err + exitWith (ExitFailure 1) + toLogLevel :: Verbosity -> LogLevel toLogLevel v = toEnum $ fromEnum v @@ -50,4 +188,6 @@ main = do userArgs <- cmdArgs argParser verbosityLevel <- getVerbosity - runFile (file userArgs) verbosityLevel + if upgrade userArgs + then upgradeCurlRunnings + else runFile (file userArgs) verbosityLevel (grep userArgs) diff --git a/curl-runnings.cabal b/curl-runnings.cabal --- a/curl-runnings.cabal +++ b/curl-runnings.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: e22614c4e739f355b79fac77eb1cf5c8111237f2adc4aebcccbbb3b118e8d817 +-- hash: 0e66b58842dd3cfc4bba11992201740113a8539e45270702205df083d4feb579 name: curl-runnings -version: 0.6.0 +version: 0.9.2 synopsis: A framework for declaratively writing curl based API tests description: Please see the README on Github at category: Testing @@ -18,10 +18,10 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: examples/example-spec.json examples/example-spec.yaml + examples/importable.yaml examples/interpolation-spec.yaml README.md @@ -34,7 +34,6 @@ src build-depends: aeson >=1.2.4.0 - , aeson-pretty >=0.8.5 , base >=4.7 && <5 , bytestring >=0.10.8.2 , case-insensitive >=0.2.1 @@ -44,6 +43,8 @@ , http-conduit >=2.2.4 , http-types >=0.9.1 , megaparsec >=6.3.0 + , pretty-simple >=2.0.2.1 + , regex-posix >=0.95.2 , text >=1.2.2.2 , unordered-containers >=0.2.8.0 , vector >=0.12.0 @@ -63,10 +64,16 @@ app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 + aeson >=1.2.4.0 + , base >=4.7 + , bytestring >=0.10.8.2 , cmdargs >=0.10.20 , curl-runnings + , directory >=1.3.0.2 + , http-conduit >=2.2.4 + , tar >=0.5.0.3 , text >=1.2.2.2 + , zlib >=0.6.1.2 other-modules: Paths_curl_runnings default-language: Haskell2010 diff --git a/examples/example-spec.json b/examples/example-spec.json --- a/examples/example-spec.json +++ b/examples/example-spec.json @@ -47,12 +47,52 @@ "name": "test 4", "url": "http://your-url.com/other/path", "requestMethod": "GET", + "expectData": { + "notContains": [ + { + "keyValueMatch": { + "key": "okay", + "value": true + } + }, + { + "valueMatch": true + } + ] + }, + "expectStatus": 200 + }, + { + "name": "test 5", + "url": "http://your-url.com/other/path", + "requestMethod": "GET", + "expectData": { + "contains": [ + { + "keyValueMatch": { + "key": "okay", + "value": true + } + } + ], + "notContains": [ + { + "valueMatch": false + } + ] + }, + "expectStatus": 200 + }, + { + "name": "test 6", + "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 5", + "name": "test 7", "url": "http://your-url.com/other/path", "requestMethod": "GET", "headers": "Content-Type: application/json", @@ -64,7 +104,7 @@ ] }, { - "name": "test 6", + "name": "test 8", "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 --- a/examples/example-spec.yaml +++ b/examples/example-spec.yaml @@ -1,82 +1,115 @@ --- -# The top level of the file is an array of test cases +# A curl runnings spec is an object with an array of `cases`. +# Note: the legacy format of a top level array of cases is still supported at this time, but it's recommended +# to migrate to the new format, as it may not be supported in later versions. +cases: + - name: test 1 # required + url: http://your-endpoint.com/status # required + requestMethod: GET # required + # [Optional] Specify the json payload we expect here + # The 1 key in this block should be either: + # exactly | contains + expectData: + # The 1 key in this object specifies the matcher we want + # to use to test the returned payload. In this case, we + # require the payload is exactly what we specify. + exactly: + okay: true + msg: 'a message' + # [Required] Assertions about the returned status code. Pass in + # an acceptable code or list of codes + expectStatus: 200 -- name: test 1 # required - url: http://your-endpoint.com/status # required - requestMethod: GET # required - # [Optional] Specify the json payload we expect here - # The 1 key in this block should be either: - # exactly | contains - expectData: - # The 1 key in this object specifies the matcher we want - # to use to test the returned payload. In this case, we - # require the payload is exactly what we specify. - exactly: - okay: true - msg: 'a message' - # [Required] Assertions about the returned status code. Pass in - # an acceptable code or list of codes - expectStatus: 200 + - name: test 2 + url: http://your-endpoint.com/path + requestMethod: POST + expectStatus: + - 200 + - 201 + # [Optional] json data to send with the request + requestData: + hello: there + num: 1 -- name: test 2 - url: http://your-endpoint.com/path - requestMethod: POST - expectStatus: - - 200 - - 201 - # [Optional] json data to send with the request - requestData: - hello: there - num: 1 + - name: test 3 + url: http://your-url.com/other/path + requestMethod: GET + expectData: + # In the `contains` case of data validation, a list of matchers is specified. Currently, + # possible types are `keyMatch` | `valueMatch` | `keyValueMatch`. + contains: + # `keyValueMatch` looks for the key/value pair anywhere in the payload + # here, {'okay': true} must be somewhere in the return payload + - keyValueMatch: + key: okay + value: true + # `valueMatch` searches for a value anywhere in the payload (note: _not_ a key). + # Here, we look for the value `true` anywhere in the payload. + # This can be useful for matching against values where you don't know the key ahead of time, + # or for values in a top level array. + - valueMatch: true + # `keyMatch` searches for a key anywhere in the payload + - keyMatch: okay + expectStatus: 200 -- name: test 3 - url: http://your-url.com/other/path - requestMethod: GET - expectData: - # In the `contains` case of data validation, a list of matchers is specified. Currently, - # possible types are `valueMatch` | `keyValueMatch`. - contains: - # `keyValueMatch` looks for the key/value pair anywhere in the payload - # here, {'okay': true} must be somewhere in the return payload - - keyValueMatch: - key: okay - value: true - # `valueMatch` searches for a value anywhere in the payload (note: _not_ a key). - # Here, we look for the value `true` anywhere in the payload. - # This can be useful for matching against values where you don't know the key ahead of time, - # or for values in a top level array. - - valueMatch: true - expectStatus: 200 + - name: test 4 + url: http://your-url.com/other/path + requestMethod: GET + expectData: + # In the `notContains` case of data validation, a list of matchers is specified. If any + # matcher is found in the response payload, the test will fail. Currently, + # possible matchers are `valueMatch` | `keyValueMatch`. + notContains: + - keyValueMatch: + key: okay + value: true + - valueMatch: true + # notContains + keyMatch works great for asserting no errors came back + - keyMatch: error + expectStatus: 200 -- name: test 4 - 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 - # IE "key: value; key: value; ..." - headers: "Content-Type: application/json" - expectStatus: 200 - # The response must constain at least these headers exactly. - # Header strings again match the -H syntax from curl - expectHeaders: "Content-Type: application/json; Hello: world" + - name: test 5 + url: http://your-url.com/other/path + requestMethod: GET + expectData: + # you can have both a contains and a notContains block in your expectData + contains: + - keyValueMatch: + key: okay + value: true + notContains: + - valueMatch: false + expectStatus: 200 -- name: test 5 - url: http://your-url.com/other/path - requestMethod: GET - headers: "Content-Type: application/json" - expectStatus: 200 - # You can also specify a key and/or value to look for in the headers - expectHeaders: - - - key: "Key-With-Val-We-Dont-Care-About" + - name: test 6 + 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 + # IE "key: value; key: value; ..." + headers: "Content-Type: application/json" + expectStatus: 200 + # The response must contain at least these headers exactly. + # Header strings again match the -H syntax from curl + expectHeaders: "Content-Type: application/json; Hello: world" -- name: test 6 - url: http://your-url.com/other/path - requestMethod: GET - headers: "Content-Type: application/json" - expectStatus: 200 - # Specify a mix of full or partial header matches in a list like so: - expectHeaders: - - "Hello: world" - - - value: "Value-With-Key-We-Dont-Care-About" - + - name: test 7 + url: http://your-url.com/other/path + requestMethod: GET + headers: "Content-Type: application/json" + expectStatus: 200 + # You can also specify a key and/or value to look for in the headers + expectHeaders: + - + key: "Key-With-Val-We-Dont-Care-About" + + - name: test 8 + url: http://your-url.com/other/path + requestMethod: GET + headers: "Content-Type: application/json" + expectStatus: 200 + # Specify a mix of full or partial header matches in a list like so: + expectHeaders: + - "Hello: world" + - + value: "Value-With-Key-We-Dont-Care-About" + diff --git a/examples/importable.yaml b/examples/importable.yaml new file mode 100644 --- /dev/null +++ b/examples/importable.yaml @@ -0,0 +1,4 @@ +--- +# you can define any variables in a yaml file, which can be imported in your specs via the +# !import directive. This is especially useful for defining aliases for data you use frequently +some_key: &ping ping diff --git a/examples/interpolation-spec.yaml b/examples/interpolation-spec.yaml --- a/examples/interpolation-spec.yaml +++ b/examples/interpolation-spec.yaml @@ -1,46 +1,70 @@ --- -- name: test 1 - # interpolate environment variables with ${...} just like you would in bash - url: 'https://tabdextension.com/${ping_path}' - headers: 'ping: ${ping_path}' - requestMethod: GET - expectData: - exactly: - ping: pong - expectStatus: 200 +# use the !include yaml directive for import data from other yaml files! +include: !include ./importable.yaml +cases: + - name: test 1 + # interpolate environment variables with ${...} just like you would in bash + url: 'https://tabdextension.com/${ping_path}' + headers: 'ping: ${ping_path}' + requestMethod: GET + expectData: + exactly: + ping: pong + expectStatus: 200 -- name: test should pass - url: https://tabdextension.com/ping - requestMethod: GET - expectData: - exactly: - # a string can be interpolated with variables inside of a $<...> - # a query should start by indexing the array `SUITE` which contains - # the json results of all previous test results. otherwise, use normal json / jq syntax. - # you can put just a bare query and subsitute any json value, or use several queries - # combined with raw text and substitue string values - ping: $ - expectStatus: 200 + - name: test should pass + url: https://tabdextension.com/ping + requestMethod: GET + expectData: + exactly: + # a string can be interpolated with variables inside of a $<...> + # a query should start by indexing the array `RESPONSES` which contains + # the json results of all previous test results. otherwise, use normal json / jq syntax. + # you can put just a bare query and subsitute any json value, or use several queries + # combined with raw text and substitue string values + # NOTE - The legacy reserved variable SUITE is still supported at this time, but may not + # be in a future version of curl-runnings. + ping: $ + expectStatus: 200 -- name: test will fail - url: https://tabdextension.com/ping - requestMethod: GET - expectHeaders: "ping: $; ${ping_path}: pong" - expectStatus: 200 + - name: test will fail + url: https://tabdextension.com/ping + requestMethod: GET + expectHeaders: "ping: $; ${ping_path}: pong" + expectStatus: 200 -- name: test will fail - url: https://tabdextension.com/ping - requestMethod: GET - expectData: - contains: - - keyValueMatch: - # environment interpolation just like bash - key: 'interpolated ${env_variable} ${another_variable}-key' - value: ${ping_value} - - keyValueMatch: - key: msg - value: $ - # here, we are interpolating several string values into a string - - valueMatch: 'hello $ : $ trailing text' - - valueMatch: $ - expectStatus: 200 + - name: test will fail + url: https://tabdextension.com/ping + requestMethod: GET + expectData: + contains: + - keyValueMatch: + # environment interpolation just like bash + key: 'interpolated ${env_variable} ${another_variable}-key' + value: ${ping_value} + - keyValueMatch: + key: msg + value: $ + # here, we are interpolating several string values into a string + - valueMatch: 'hello $ : $ trailing text' + - valueMatch: $ + expectStatus: 200 + + - name: test should pass + url: https://tabdextension.com/ping + requestMethod: GET + expectData: + notContains: + - keyValueMatch: + # environment interpolation just like bash + key: 'interpolated ${env_variable} ${another_variable}-key' + value: ${ping_value} + - keyValueMatch: + key: msg + value: $ + # here, we are interpolating several string values into a string + - valueMatch: 'hello $ : $ trailing text' + - valueMatch: $ + # use anchors from this file or an imported one. here, `ping` is an anchor defined in importable.yaml + - valueMatch: *ping + expectStatus: 200 diff --git a/src/Testing/CurlRunnings.hs b/src/Testing/CurlRunnings.hs --- a/src/Testing/CurlRunnings.hs +++ b/src/Testing/CurlRunnings.hs @@ -4,12 +4,12 @@ -- | curl-runnings is a framework for writing declaratively writing curl based tests for your API's. -- Write your test specifications with yaml or json, and you're done! module Testing.CurlRunnings - ( - runCase - , runSuite - , decodeFile - ) where + ( runCase + , runSuite + , decodeFile + ) where +import Control.Exception import Control.Monad import Data.Aeson import Data.Aeson.Types @@ -23,7 +23,7 @@ import Data.Monoid import qualified Data.Text as T import qualified Data.Vector as V -import qualified Data.Yaml as Y +import qualified Data.Yaml.Include as YI import Network.HTTP.Conduit import Network.HTTP.Simple import qualified Network.HTTP.Types.Header as HTTP @@ -33,26 +33,26 @@ import Testing.CurlRunnings.Internal.Parser import Testing.CurlRunnings.Types import Text.Printf +import Text.Regex.Posix -- | decode a json or yaml file into a suite object decodeFile :: FilePath -> IO (Either String CurlSuite) -decodeFile specPath = doesFileExist specPath >>= \exists -> - if exists then - case last $ T.splitOn "." (T.pack specPath) of - "json" -> - eitherDecode' <$> B.readFile specPath :: IO (Either String CurlSuite) - "yaml" -> - Y.decodeEither <$> B8S.readFile specPath :: IO (Either String CurlSuite) - "yml" -> - Y.decodeEither <$> B8S.readFile specPath :: IO (Either String CurlSuite) - _ -> return . Left $ printf "Invalid spec path %s" specPath - else return . Left $ printf "%s not found" specPath +decodeFile specPath = + doesFileExist specPath >>= \exists -> + if exists + then case last $ T.splitOn "." (T.pack specPath) of + "json" -> + eitherDecode' <$> B.readFile specPath :: IO (Either String CurlSuite) + "yaml" -> mapLeft show <$> YI.decodeFileEither specPath + "yml" -> mapLeft show <$> YI.decodeFileEither specPath + _ -> return . Left $ printf "Invalid spec path %s" specPath + else return . Left $ printf "%s not found" specPath -- | 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. runCase :: CurlRunningsState -> CurlCase -> IO CaseResult runCase state curlCase = do - let eInterpolatedUrl = interpolateQueryString state $ T.pack $ url curlCase + let eInterpolatedUrl = interpolateQueryString state $ url curlCase eInterpolatedHeaders = interpolateHeaders state $ fromMaybe (HeaderSet []) (headers curlCase) case (eInterpolatedUrl, eInterpolatedHeaders) of @@ -70,11 +70,34 @@ setRequestBodyJSON (fromMaybe emptyObject replacedJSON) . setRequestHeaders (toHTTPHeaders interpolatedHeaders) $ initReq {method = B8S.pack . show $ requestMethod curlCase} - logger state DEBUG (show request) + logger state DEBUG (pShow request) + logger + state + DEBUG + ("Request body: " <> (pShow $ fromMaybe emptyObject replacedJSON)) response <- httpBS request - logger state DEBUG (show response) + -- If the response is just returning bytes, we won't print them + let responseHeaderValues = map snd (getResponseHeaders response) + if "application/octet-stream" `notElem` responseHeaderValues && + "application/vnd.apple.pkpass" `notElem` responseHeaderValues + then catch + (logger state DEBUG (pShow response)) + (\(e :: IOException) -> + logger state ERROR ("Error logging response: " <> pShow e)) + -- TODO: we should log as much info as possible without printing the raw body + else logger + state + DEBUG + "Response output supressed (returned content-type was bytes)" returnVal <- - (return . decode . B.fromStrict $ getResponseBody response) :: IO (Maybe Value) + catch + ((return . decode . B.fromStrict $ getResponseBody response) :: IO (Maybe Value)) + (\(e :: IOException) -> + logger + state + ERROR + ("Error decoding response into json: " <> pShow e) >> + return (Just Null)) let returnCode = getResponseStatusCode response receivedHeaders = fromHTTPHeaders $ responseHeaders response assertionErrors = @@ -91,7 +114,8 @@ failures -> CaseFail curlCase (Just receivedHeaders) returnVal failures -checkHeaders :: CurlRunningsState -> CurlCase -> Headers -> Maybe AssertionFailure +checkHeaders :: + CurlRunningsState -> CurlCase -> Headers -> Maybe AssertionFailure checkHeaders _ (CurlCase _ _ _ _ _ _ _ Nothing) _ = Nothing checkHeaders state curlCase@(CurlCase _ _ _ _ _ _ _ (Just (HeaderMatcher m))) receivedHeaders = let interpolatedHeaders = mapM (interpolatePartialHeader state) m @@ -110,7 +134,10 @@ (HeaderMatcher headerList) receivedHeaders -interpolatePartialHeader :: CurlRunningsState -> PartialHeaderMatcher -> Either QueryError PartialHeaderMatcher +interpolatePartialHeader :: + CurlRunningsState + -> PartialHeaderMatcher + -> Either QueryError PartialHeaderMatcher interpolatePartialHeader state (PartialHeaderMatcher k v) = let k' = interpolateQueryString state <$> k v' = interpolateQueryString state <$> v @@ -157,55 +184,93 @@ -- | Runs the test cases in order and stop when an error is hit. Returns all the results runSuite :: CurlSuite -> LogLevel -> IO [CaseResult] -runSuite (CurlSuite cases) logLevel = do +runSuite (CurlSuite cases filterRegex) logLevel = do fullEnv <- getEnvironment let envMap = H.fromList $ map (\(x, y) -> (T.pack x, T.pack y)) fullEnv + filterNameByRegexp curlCase = + maybe + True + (\regexp -> T.unpack (name curlCase) =~ T.unpack regexp :: Bool) + filterRegex foldM (\prevResults curlCase -> case safeLast prevResults of Just CaseFail {} -> return prevResults Just CasePass {} -> do - result <- runCase (CurlRunningsState envMap prevResults logLevel) curlCase >>= printR + result <- + runCase (CurlRunningsState envMap prevResults logLevel) curlCase >>= + printR return $ prevResults ++ [result] Nothing -> do - result <- runCase (CurlRunningsState envMap [] logLevel) curlCase >>= printR + result <- + runCase (CurlRunningsState envMap [] logLevel) curlCase >>= printR return [result]) [] - cases + (filter filterNameByRegexp cases) -- | Check if the retrieved value fail's the case's assertion -checkBody :: CurlRunningsState -> CurlCase -> Maybe Value -> Maybe AssertionFailure +checkBody :: + CurlRunningsState -> CurlCase -> Maybe Value -> Maybe AssertionFailure -- | We are looking for an exact payload match, and we have a payload to check checkBody state curlCase@(CurlCase _ _ _ _ _ (Just (Exactly expectedValue)) _ _) (Just receivedBody) = case runReplacements state expectedValue of (Left err) -> Just $ QueryFailure curlCase err (Right interpolated) -> - if (unsafeLogger state DEBUG "exact body matcher" interpolated) /= receivedBody + if (unsafeLogger state DEBUG "exact body matcher" interpolated) /= + receivedBody then Just $ DataFailure (curlCase {expectData = Just $ Exactly interpolated}) (Exactly interpolated) (Just receivedBody) else Nothing - -- | We are checking a list of expected subvalues, and we have a payload to check checkBody state curlCase@(CurlCase _ _ _ _ _ (Just (Contains subexprs)) _ _) (Just receivedBody) = case runReplacementsOnSubvalues state subexprs of Left f -> Just $ QueryFailure curlCase f Right updatedMatcher -> - if jsonContainsAll receivedBody (unsafeLogger state DEBUG "partial json body matcher" updatedMatcher) + if jsonContainsAll + receivedBody + (unsafeLogger state DEBUG "partial json body matcher" updatedMatcher) then Nothing else Just $ DataFailure curlCase (Contains updatedMatcher) (Just receivedBody) - +-- | We are checking a list of expected absent subvalues, and we have a payload to check +checkBody state curlCase@(CurlCase _ _ _ _ _ (Just (NotContains subexprs)) _ _) (Just receivedBody) = + case runReplacementsOnSubvalues state subexprs of + Left f -> Just $ QueryFailure curlCase f + Right updatedMatcher -> + if jsonContainsAny + receivedBody + (unsafeLogger state DEBUG "partial json body matcher" updatedMatcher) + then Just $ + DataFailure + curlCase + (NotContains updatedMatcher) + (Just receivedBody) + else Nothing +-- | We are checking for both contains and notContains vals, and we have a payload to check +checkBody state curlCase@(CurlCase _ _ _ _ _ (Just m@(MixedContains subexprs)) _ _) receivedBody = + let failure = + join $ + find + isJust + (map + (\subexpr -> + checkBody + state + curlCase {expectData = Just subexpr} + receivedBody) + subexprs) + in fmap (\_ -> DataFailure curlCase m receivedBody) failure -- | We expected a body but didn't get one checkBody _ curlCase@(CurlCase _ _ _ _ _ (Just anything) _ _) Nothing = Just $ DataFailure curlCase anything Nothing - -- | No assertions on the body checkBody _ (CurlCase _ _ _ _ _ Nothing _ _) _ = Nothing -runReplacementsOnSubvalues :: CurlRunningsState -> [JsonSubExpr] -> Either QueryError [JsonSubExpr] +runReplacementsOnSubvalues :: + CurlRunningsState -> [JsonSubExpr] -> Either QueryError [JsonSubExpr] runReplacementsOnSubvalues state = mapM (\expr -> @@ -214,6 +279,10 @@ case runReplacements state v of Left l -> Left l Right newVal -> Right $ ValueMatch newVal + KeyMatch k -> + case interpolateQueryString state k of + Left l -> Left l + Right newKey -> Right $ KeyMatch newKey KeyValueMatch k v -> case (interpolateQueryString state k, runReplacements state v) of (Left l, _) -> Left l @@ -264,7 +333,8 @@ runReplacements state (String s) = case parseQuery s of Right [LiteralText t] -> Right $ String t - Right [q@(InterpolatedQuery _ _)] -> getStringValueForQuery state q >>= (Right . String) + Right [q@(InterpolatedQuery _ _)] -> + getStringValueForQuery state q >>= (Right . String) Right [q@(NonInterpolatedQuery _)] -> getValueForQuery state q Right _ -> mapRight String $ interpolateQueryString state s Left parseErr -> Left parseErr @@ -272,7 +342,8 @@ -- | Given a query string, return some text with interpolated values. Type -- errors will be returned if queries don't resolve to strings -interpolateQueryString :: CurlRunningsState -> FullQueryText -> Either QueryError T.Text +interpolateQueryString :: + CurlRunningsState -> FullQueryText -> Either QueryError T.Text interpolateQueryString state query = let parsedQuery = parseQuery query in case parsedQuery of @@ -286,7 +357,8 @@ in fromMaybe (Right $ foldr (<>) (T.pack "") goodLookups) failure -- | Lookup the text at the specified query -getStringValueForQuery :: CurlRunningsState -> InterpolatedQuery -> Either QueryError T.Text +getStringValueForQuery :: + CurlRunningsState -> InterpolatedQuery -> Either QueryError T.Text getStringValueForQuery _ (LiteralText rawText) = Right rawText getStringValueForQuery state (NonInterpolatedQuery q) = getStringValueForQuery state $ InterpolatedQuery "" q @@ -299,35 +371,52 @@ Right $ rawText <> H.lookupDefault "" v env -- | Lookup the value for the specified query -getValueForQuery :: CurlRunningsState -> InterpolatedQuery -> Either QueryError Value +getValueForQuery :: + CurlRunningsState -> InterpolatedQuery -> Either QueryError Value getValueForQuery _ (LiteralText rawText) = Right $ String rawText getValueForQuery (CurlRunningsState _ previousResults _) full@(NonInterpolatedQuery (Query indexes)) = case head indexes of (CaseResultIndex i) -> - let (CasePass _ _ returnedJSON) = arrayGet previousResults $ fromInteger i - jsonToIndex = - case returnedJSON of - Just v -> Right v - Nothing -> - Left $ - NullPointer - (T.pack $ show full) - "No data was returned from this case" - in foldr - (\index eitherVal -> - case (eitherVal, index) of - (Left l, _) -> Left l - (Right (Object o), KeyIndex k) -> - Right $ H.lookupDefault Null k o - (Right (Array a), ArrayIndex i') -> Right $ arrayGet (V.toList a) $ fromInteger i' - (Right Null, q) -> - Left $ NullPointer (T.pack $ show full) (T.pack $ show q) - (Right o, _) -> Left $ QueryTypeMismatch (T.pack $ show index) o) - jsonToIndex - (tail indexes) + let maybeCase = arrayGet previousResults $ fromInteger i + in if isJust maybeCase + then let (CasePass _ _ returnedJSON) = fromJust maybeCase + jsonToIndex = + case returnedJSON of + Just v -> Right v + Nothing -> + Left $ + NullPointer + (T.pack $ show full) + "No data was returned from this case" + in foldl + (\eitherVal index -> + case (eitherVal, index) of + (Left l, _) -> Left l + (Right (Object o), KeyIndex k) -> + Right $ H.lookupDefault Null k o + (Right (Array a), ArrayIndex i') -> + maybe + (Left $ + NullPointer (T.pack $ show full) $ + "Array index not found: " <> T.pack (show i')) + Right + (arrayGet (V.toList a) $ fromInteger i') + (Right Null, q) -> + Left $ + NullPointer (T.pack $ show full) (T.pack $ show q) + (Right o, _) -> + Left $ QueryTypeMismatch (T.pack $ show index) o) + jsonToIndex + (tail indexes) + else Left $ + NullPointer (T.pack $ show full) $ + "Attempted to index into previous a test case that didn't exist: " <> + T.pack (show i) _ -> Left . QueryValidationError $ - T.pack $ "$<> queries must start with a SUITE[index] query: " ++ show full + T.pack $ + "'$< ... >' queries must start with a RESPONSES[index] query: " ++ + show full getValueForQuery (CurlRunningsState env _ _) (NonInterpolatedQuery (EnvironmentVariable var)) = Right . String $ H.lookupDefault "" var env getValueForQuery state (InterpolatedQuery _ q) = @@ -337,21 +426,42 @@ Right v -> Left $ QueryTypeMismatch (T.pack "Expected a string") v Left l -> Left l +jsonContains :: + ((JsonSubExpr -> Bool) -> [JsonSubExpr] -> Bool) + -> Value + -> [JsonSubExpr] + -> Bool +jsonContains f jsonValue = + let traversedValue = traverseValue jsonValue + in f $ \match -> + case match of + ValueMatch subval -> subval `elem` traversedValue + KeyMatch key -> any (`containsKey` key) traversedValue + KeyValueMatch key subval -> + any (\o -> containsKeyVal o key subval) traversedValue + -- | Does the json value contain all of these sub-values? jsonContainsAll :: Value -> [JsonSubExpr] -> Bool -jsonContainsAll jsonValue = - all $ \match -> - case match of - ValueMatch subval -> subval `elem` traverseValue jsonValue - KeyValueMatch key subval -> - any (\o -> containsKeyVal o key subval) (traverseValue jsonValue) +jsonContainsAll = jsonContains all +-- | Does the json value contain any of these sub-values? +jsonContainsAny :: Value -> [JsonSubExpr] -> Bool +jsonContainsAny = jsonContains any + -- | Does the json value contain the given key value pair? containsKeyVal :: Value -> T.Text -> Value -> Bool -containsKeyVal jsonValue key val = case jsonValue of - Object o -> H.lookup key o == Just val - _ -> False +containsKeyVal jsonValue key val = + case jsonValue of + Object o -> H.lookup key o == Just val + _ -> False +-- | Does the json value contain the given key value pair? +containsKey :: Value -> T.Text -> Bool +containsKey jsonValue key = + case jsonValue of + Object o -> isJust $ H.lookup key o + _ -> False + -- | Fully traverse the json and return a list of all the values traverseValue :: Value -> [Value] traverseValue val = @@ -384,7 +494,8 @@ -- | Utility conversion from an HTTP header to a CurlRunnings header. toHTTPHeader :: Header -> HTTP.Header -toHTTPHeader (Header a b) = (CI.mk . B8S.pack $ T.unpack a, B8S.pack $ T.unpack b) +toHTTPHeader (Header a b) = + (CI.mk . B8S.pack $ T.unpack a, B8S.pack $ T.unpack b) -- | Utility conversion from CurlRunnings headers to HTTP headers. toHTTPHeaders :: Headers -> HTTP.RequestHeaders diff --git a/src/Testing/CurlRunnings/Internal.hs b/src/Testing/CurlRunnings/Internal.hs --- a/src/Testing/CurlRunnings/Internal.hs +++ b/src/Testing/CurlRunnings/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | This module specifies any utilities used by this package. At this time, -- consider everything in this module to be private to the curl-runnings package module Testing.CurlRunnings.Internal @@ -5,56 +7,69 @@ , makeGreen , tracer , mapRight + , mapLeft , arrayGet , makeLogger , makeUnsafeLogger - + , pShow , LogLevel(..) , CurlRunningsLogger , CurlRunningsUnsafeLogger ) where import Control.Monad +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Debug.Trace +import qualified Text.Pretty.Simple as P -makeGreen :: String -> String -makeGreen s = "\x1B[32m" ++ s ++ "\x1B[0m" +makeGreen :: T.Text -> T.Text +makeGreen s = "\x1B[32m" <> s <> "\x1B[0m" -makeRed :: String -> String -makeRed s = "\x1B[31m" ++ s ++ "\x1B[0m" +makeRed :: T.Text -> T.Text +makeRed s = "\x1B[31m" <> s <> "\x1B[0m" -tracer :: Show a => String -> a -> a -tracer a b = trace (a ++ ": " ++ show b) b +pShow :: Show a => a -> T.Text +pShow = TL.toStrict . P.pShow +tracer :: Show a => T.Text -> a -> a +tracer a b = trace (T.unpack $ a <> T.pack ": " <> pShow b) b + mapRight :: (b -> c) -> Either a b -> Either a c mapRight f (Right v) = Right $ f v mapRight _ (Left v) = Left v +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft f (Left v) = Left $ f v +mapLeft _ (Right v) = Right v + -- | Array indexing with negative values allowed -arrayGet :: [a] -> Int -> a +arrayGet :: [a] -> Int -> Maybe a arrayGet a i - | i >= 0 = a !! i - | otherwise = reverse a !! (-i) + | (i >= 0 && length a <= abs i) || null a || (i < 0 && length a <= (abs i - 1)) = Nothing + | i >= 0 = Just $ a !! i + | otherwise = Just $ a !! (length a + i) -data LogLevel = ERROR | INFO | DEBUG deriving (Show, Eq, Ord, Enum) +data LogLevel + = ERROR + | INFO + | DEBUG + deriving (Show, Eq, Ord, Enum) -- | A logger that respects the verbosity level given by input args -type CurlRunningsLogger = (LogLevel -> String -> IO ()) +type CurlRunningsLogger = (LogLevel -> T.Text -> IO ()) -- | A tracer that respects the verbosity level given by input args. Logging -- with this calls out to Debug.trace and can be used in pure code, but be aware -- of the unsafe IO. -type CurlRunningsUnsafeLogger a = (LogLevel -> String -> a -> a) +type CurlRunningsUnsafeLogger a = (LogLevel -> T.Text -> a -> a) makeLogger :: LogLevel -> CurlRunningsLogger -makeLogger threshold level text = - when (level <= threshold) $ putStrLn text +makeLogger threshold level text = when (level <= threshold) $ P.pPrint text makeUnsafeLogger :: Show a => LogLevel -> CurlRunningsUnsafeLogger a makeUnsafeLogger threshold level text object = - if level <= threshold then - tracer text object - else - object - - + if level <= threshold + then tracer text object + else object diff --git a/src/Testing/CurlRunnings/Internal/Parser.hs b/src/Testing/CurlRunnings/Internal/Parser.hs --- a/src/Testing/CurlRunnings/Internal/Parser.hs +++ b/src/Testing/CurlRunnings/Internal/Parser.hs @@ -5,22 +5,22 @@ -- interpolation can be performed, where interpolated values are json quries -- into responses from past test cases. -- --- > "$" +-- > "$" -- --- here the `SUITE` keyword references the results of previous test cases. Here, the +-- here the `RESPONSES` keyword references the results of previous test cases. Here, the -- whole string is a query, so if the value referenced by this query is itself a -- json value, the entire value will replace this string in a json matcher. -- Additionally, interpolation of the form: -- -- > --- > "some text to interpolate with $" +-- > "some text to interpolate with $" -- > -- -- will substitute a string found at the specified query -- and subsitute the string. -- -- Rules for the language are similar to JQ or regular JSON indexing rules. All --- queries must start with a SUITE[integer] index, and be written between a +-- queries must start with a RESPONSES[integer] index, and be written between a -- -- > -- > $< ... > @@ -47,15 +47,28 @@ parseQuery q = let trimmed = T.strip q in case Text.Megaparsec.parse parseFullTextWithQuery "" trimmed of - Right a -> Right a - Left a -> Left $ QueryParseError (T.pack $ parseErrorPretty a) q + Right a -> Right a >>= validateQuery + Left a -> Left $ QueryParseError (T.pack $ parseErrorPretty a) q +-- | Once we have parsed a query successfully, ensure that it is a legal query +validateQuery :: [InterpolatedQuery] -> Either QueryError [InterpolatedQuery] +-- If we have a json indexing query, it needs to start by indexing the special +-- RESPONSES array +validateQuery q@(InterpolatedQuery _ (Query (CaseResultIndex _:_)):_) = Right q +validateQuery q@(NonInterpolatedQuery (Query (CaseResultIndex _:_)):_) = Right q +-- If the RESPONSES array is not indexed, it's not valid, as we don't know which +-- response to look at +validateQuery (InterpolatedQuery _ (Query _):_) = Left $ QueryValidationError "JSON interpolation must begin by indexing into RESPONSES" +validateQuery (NonInterpolatedQuery (Query _):_) = Left $ QueryValidationError "JSON interpolation must begin by indexing into RESPONSES" +-- Otherwise, we're good! +validateQuery q = Right q + type Parser = Parsec Void T.Text parseSuiteIndex' :: Parser Index parseSuiteIndex' = do notFollowedBy gtlt - _ <- string "SUITE" + _ <- string "RESPONSES" <|> string "SUITE" (ArrayIndex i) <- arrayIndexParser return $ CaseResultIndex i diff --git a/src/Testing/CurlRunnings/Types.hs b/src/Testing/CurlRunnings/Types.hs --- a/src/Testing/CurlRunnings/Types.hs +++ b/src/Testing/CurlRunnings/Types.hs @@ -32,13 +32,12 @@ ) where import Data.Aeson -import Data.Aeson.Encode.Pretty import Data.Aeson.Types -import qualified Data.ByteString.Lazy.Char8 as B8 import Data.Either import qualified Data.HashMap.Strict as H import Data.List import Data.Maybe +import Data.Monoid import qualified Data.Text as T import qualified Data.Vector as V import GHC.Generics @@ -62,8 +61,12 @@ data JsonMatcher -- | Performs `==` = Exactly Value - -- | A list of matchers to make assertions about some subset of the response. + -- | A list of matchers to make assertions that contains values exist in the response | Contains [JsonSubExpr] + -- | A list of matchers to make assertions that contains values do not exist in the response + | NotContains [JsonSubExpr] + -- | We're specifiying both Contains and NotContains matchers + | MixedContains [JsonMatcher] deriving (Show, Generic) instance ToJSON JsonMatcher @@ -71,9 +74,24 @@ instance FromJSON JsonMatcher where parseJSON (Object v) | isJust $ H.lookup "exactly" v = Exactly <$> v .: "exactly" + | isJust (H.lookup "contains" v) && isJust (H.lookup "notContains" v) = do + c <- Contains <$> v .: "contains" + n <- NotContains <$> v .: "notContains" + return $ MixedContains [c, n] | isJust $ H.lookup "contains" v = Contains <$> v .: "contains" + | isJust $ H.lookup "notContains" v = NotContains <$> v .: "notContains" parseJSON invalid = typeMismatch "JsonMatcher" invalid +-- | Simple predicate to check value constructor type +isContains :: JsonMatcher -> Bool +isContains (Contains _) = True +isContains _ = False + +-- | Simple predicate to check value constructor type +isNotContains :: JsonMatcher -> Bool +isNotContains (NotContains _) = True +isNotContains _ = False + -- | A representation of a single header data Header = Header T.Text @@ -108,28 +126,29 @@ -- | Different errors relating to querying json from previous test cases data QueryError -- | The query was malformed and couldn't be parsed - = QueryParseError T.Text T.Text + = QueryParseError T.Text + T.Text -- | The retrieved a value of the wrong type or was otherwise operating on the -- wrong type of thing | QueryTypeMismatch T.Text Value -- | The query was parse-able | QueryValidationError T.Text - -- | Tried to access a value in a null object - | NullPointer T.Text - T.Text + -- | Tried to access a value in a null object. + | NullPointer T.Text -- full query + T.Text -- message instance Show QueryError where show (QueryParseError t q) = printf "error parsing query %s: %s" q $ T.unpack t show (NullPointer full part) = printf "null pointer in %s at %s" (T.unpack full) $ T.unpack part - show (QueryTypeMismatch message val) = printf "type error: %s %s" (message) $ show val + show (QueryTypeMismatch message val) = printf "type error: %s %s" message $ show val show (QueryValidationError message) = printf "invalid query: %s" message parseHeader :: T.Text -> Either T.Text Header parseHeader str = case map T.strip $ T.splitOn ":" str of - [key, val] -> Right $ Header key val - anythingElse -> Left . T.pack $ "bad header found: " ++ (show anythingElse) + [key, val] -> Right $ Header key val + anythingElse -> Left . T.pack $ "bad header found: " ++ show anythingElse parseHeaders :: T.Text -> Either T.Text Headers parseHeaders str = @@ -174,6 +193,8 @@ -- value. The motivation for this field is largely for checking contents of a -- top level array. It's also useful if you don't know the key ahead of time. = ValueMatch Value + -- | Assert a key exists anywhere in the json + | KeyMatch T.Text -- | Assert the key value pair can be found somewhere the json. | KeyValueMatch { matchKey :: T.Text , matchValue :: Value } @@ -186,6 +207,11 @@ in case toParse of Object o -> KeyValueMatch <$> o .: "key" <*> o .: "value" _ -> typeMismatch "JsonSubExpr" toParse + | isJust $ H.lookup "keyMatch" v = + let toParse = fromJust $ H.lookup "keyMatch" v + in case toParse of + String s -> return $ KeyMatch s + _ -> typeMismatch "JsonSubExpr" toParse | isJust $ H.lookup "valueMatch" v = ValueMatch <$> v .: "valueMatch" parseJSON invalid = typeMismatch "JsonSubExpr" invalid instance ToJSON JsonSubExpr @@ -205,8 +231,8 @@ -- | A single curl test case, the basic foundation of a curl-runnings test. data CurlCase = CurlCase - { name :: String -- ^ The name of the test case - , url :: String -- ^ The target url to test + { name :: T.Text -- ^ The name of the test case + , url :: T.Text -- ^ The target url to test , requestMethod :: HttpMethod -- ^ Verb to use for the request , requestData :: Maybe Value -- ^ Payload to send with the request, if any , headers :: Maybe Headers -- ^ Headers to send with the request, if any @@ -245,10 +271,10 @@ colorizeExpects :: String -> String colorizeExpects t = - let expectedColor = makeRed "Excpected:" + let expectedColor = makeRed "Expected:" actualColor = makeRed "Actual:" - replacedExpected = T.replace "Expected:" (T.pack expectedColor) (T.pack t) - in T.unpack $ T.replace "Actual:" (T.pack actualColor) replacedExpected + replacedExpected = T.replace "Expected:" expectedColor (T.pack t) + in T.unpack $ T.replace "Actual:" actualColor replacedExpected instance Show AssertionFailure where show (StatusFailure c receivedCode) = @@ -256,14 +282,16 @@ ExactCode code -> colorizeExpects $ printf - "Incorrect status code from %s. Expected: %s. Actual: %s" + "[%s] Incorrect status code from %s. Expected: %s. Actual: %s" + (name c) (url c) (show code) (show receivedCode) AnyCodeIn codes -> colorizeExpects $ printf - "Incorrect status code from %s. Expected: %s. Actual: %s" + "[%s] Incorrect status code from %s. Expected: %s. Actual: %s" + (name c) (url c) (show codes) (show receivedCode) @@ -272,21 +300,41 @@ Exactly expectedVal -> colorizeExpects $ printf - "JSON response from %s didn't match spec. Expected: %s. Actual: %s" + "[%s] JSON response from %s didn't match spec. Expected: %s. Actual: %s" + (name curlCase) (url curlCase) - (B8.unpack (encodePretty expectedVal)) - (B8.unpack (encodePretty receivedVal)) + (T.unpack (pShow expectedVal)) + (T.unpack (pShow receivedVal)) (Contains expectedVals) -> colorizeExpects $ printf - "JSON response from %s didn't contain the matcher. Expected: %s to be each be subvalues in: %s" + "[%s] JSON response from %s didn't contain the matcher. Expected: %s to each be subvalues in: %s" + (name curlCase) (url curlCase) - (B8.unpack (encodePretty expectedVals)) - (B8.unpack (encodePretty receivedVal)) + (T.unpack (pShow expectedVals)) + (T.unpack (pShow receivedVal)) + (NotContains expectedVals) -> + colorizeExpects $ + printf + "[%s] JSON response from %s did contain the matcher. Expected: %s not to be subvalues in: %s" + (name curlCase) + (url curlCase) + (T.unpack (pShow expectedVals)) + (T.unpack (pShow receivedVal)) + (MixedContains expectedVals) -> + colorizeExpects $ + printf + "[%s] JSON response from %s didn't satisfy the matcher. Expected: %s to each be subvalues and %s not to be subvalues in: %s" + (name curlCase) + (url curlCase) + (T.unpack (pShow (filter isContains expectedVals))) + (T.unpack (pShow (filter isNotContains expectedVals))) + (T.unpack (pShow receivedVal)) show (HeaderFailure curlCase expected receivedHeaders) = colorizeExpects $ printf - "Headers from %s didn't contain expected headers. Expected: %s. Actual: %s" + "[%s] Headers from %s didn't contain expected headers. Expected: %s. Actual: %s" + (name curlCase) (url curlCase) (show expected) (show receivedHeaders) @@ -307,23 +355,30 @@ [AssertionFailure] instance Show CaseResult where - show (CasePass c _ _) = makeGreen "[PASS] " ++ name c + show (CasePass c _ _) = T.unpack . makeGreen $ "[PASS] " <> name c show (CaseFail c _ _ failures) = - makeRed "[FAIL] " ++ - name c ++ - "\n" ++ - concatMap ((\s -> "\nAssertion failed: " ++ s) . (++ "\n") . show) failures + T.unpack $ makeRed "[FAIL] " <> + name c <> + "\n" <> + mconcat (map ((\s -> "\nAssertion failed: " <> s) . (<> "\n") . pShow) failures) -- | A wrapper type around a set of test cases. This is the top level spec type -- that we parse a test spec file into -newtype CurlSuite = - CurlSuite [CurlCase] - deriving (Show, Generic) +data CurlSuite = CurlSuite + { suiteCases :: [CurlCase] + , suiteCaseFilter :: Maybe T.Text + } deriving (Show, Generic) -instance FromJSON CurlSuite +noFilterSuite :: [CurlCase] -> CurlSuite +noFilterSuite = flip CurlSuite Nothing instance ToJSON CurlSuite +instance FromJSON CurlSuite where + parseJSON (Object v) = noFilterSuite <$> v .: "cases" + parseJSON a@(Array _) = noFilterSuite <$> parseJSON a + parseJSON invalid = typeMismatch "JsonMatcher" invalid + -- | Simple predicate that checks if the result is passing isPassing :: CaseResult -> Bool isPassing CasePass {} = True @@ -347,7 +402,7 @@ -- | A single lookup operation in a json query data Index - -- | Drill into the json of a specific test case. The SUITE object is + -- | Drill into the json of a specific test case. The RESPONSES object is -- accessible as an array of values that have come back from previous test -- cases = CaseResultIndex Integer @@ -357,7 +412,8 @@ | ArrayIndex Integer deriving (Show) -printOriginalQuery (CaseResultIndex t) = "SUITE[" ++ show t ++ "]" +printOriginalQuery :: Index -> String +printOriginalQuery (CaseResultIndex t) = "RESPONSES[" ++ show t ++ "]" printOriginalQuery (KeyIndex key) = "." ++ T.unpack key printOriginalQuery (ArrayIndex i) = printf "[%d]" i @@ -383,10 +439,10 @@ printQueryString :: InterpolatedQuery -> String printQueryString (LiteralText t) = show t printQueryString (InterpolatedQuery raw (Query indexes)) = - printf "%s$<%s>" raw (concat $ map show indexes) -printQueryString (NonInterpolatedQuery (Query indexes)) = printf "$<%s>" (concat $ map show indexes) + printf "%s$<%s>" raw $ concatMap show indexes +printQueryString (NonInterpolatedQuery (Query indexes)) = printf "$<%s>" (concatMap show indexes) --- | The full string in which a query appears, eg "prefix-${{SUITE[0].key.another_key[0].last_key}}" +-- | The full string in which a query appears, eg "prefix-${{RESPONSES[0].key.another_key[0].last_key}}" type FullQueryText = T.Text --- | The string for one query given the FullQueryText above, the single query text would be SUITE[0].key.another_key[0].last_key +-- | The string for one query given the FullQueryText above, the single query text would be RESPONSES[0].key.another_key[0].last_key type SingleQueryText = T.Text diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Main where @@ -6,6 +6,7 @@ import System.Directory import Test.Hspec import Testing.CurlRunnings +import Testing.CurlRunnings.Internal import Testing.CurlRunnings.Internal.Parser main :: IO () @@ -24,20 +25,38 @@ it "should parse valid queries" $ do parseQuery "just some text" `shouldSatisfy` isRight - parseQuery "$" `shouldSatisfy` isRight - parseQuery "$" `shouldSatisfy` isRight - parseQuery "$" `shouldSatisfy` isRight - parseQuery "some text before $ and after" `shouldSatisfy` isRight - parseQuery "some $ querires $" `shouldSatisfy` isRight - parseQuery "some $ querires $ ${SOME_ENV_VARIABLE} asdf" `shouldSatisfy` isRight + parseQuery "$" `shouldSatisfy` isRight + parseQuery "$" `shouldSatisfy` isRight + parseQuery "$" `shouldSatisfy` isRight + parseQuery "some text before $ and after" `shouldSatisfy` isRight + parseQuery "some $ querires $" `shouldSatisfy` isRight + parseQuery "some $ querires $ ${SOME_ENV_VARIABLE} asdf" `shouldSatisfy` isRight + parseQuery "$" `shouldSatisfy` isRight -- legacy SUITE should still be supported it "should reject invalid queries" $ do parseQuery "$<" `shouldSatisfy` isLeft - parseQuery "$" `shouldSatisfy` isLeft - parseQuery "$" `shouldSatisfy` isLeft - parseQuery "$>" `shouldSatisfy` isLeft - parseQuery "$.key[1][1] ${" `shouldSatisfy` isLeft + parseQuery "$" `shouldSatisfy` isLeft + parseQuery "$" `shouldSatisfy` isLeft + parseQuery "$>" `shouldSatisfy` isLeft + parseQuery "$.key[1][1] ${" `shouldSatisfy` isLeft + parseQuery "$" `shouldSatisfy` isLeft + parseQuery "some text $" `shouldSatisfy` isLeft + + it "arrayGet should handle positive and negative indexes correctly" $ do + let a = [1, 2, 3] + b = [] :: [Int] + (arrayGet a 0) `shouldBe` Just 1 + (arrayGet a 1) `shouldBe` Just 2 + (arrayGet a 2) `shouldBe` Just 3 + (arrayGet a (-1)) `shouldBe` Just 3 + (arrayGet a (-2)) `shouldBe` Just 2 + (arrayGet a (-3)) `shouldBe` Just 1 + (arrayGet a (-4)) `shouldBe` Nothing + (arrayGet a 3) `shouldBe` Nothing + (arrayGet b 0) `shouldBe` Nothing + (arrayGet b 1) `shouldBe` Nothing + (arrayGet b (-1)) `shouldBe` Nothing testValidSpec :: String -> IO () testValidSpec file = do