diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,11 +4,13 @@ _Feel the rhythm! Feel the rhyme! Get on up, it's testing time! curl-runnings!_ -curl-runnings is a framework for writing declarative, curl based tests for your APIs. +curl-runnings is a framework for writing declarative, curl based tests for your +APIs. Write your tests quickly and correctly with a straight-forward +specification in yaml or json that can encode simple but powerful matchers +against responses. -Write your tests quickly and correctly with a straight-forward specification in -yaml or json. A DSL for writing your tests is on the way! Alternatively, you can -use the curl-runnings library to write your tests directly in Haskell. +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). ### Why? @@ -17,28 +19,29 @@ 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 simple to write tests that curl some endpoints and verify the +make it very easy to write tests that just hit some endpoints and verify the output looks sane. -With curl-runnings, you can write your tests just as data in a yaml or json file, -curl runnings will take care of the rest! +Now you can write your tests just as data in a yaml or json file, +and curl-runnings will take care of the rest! 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 +language, which is a future goal for the project. curl-runnings specs in Dhall +is also being developed and may fufill the same needs. ### Installing There are few options to install: -- download the releases from the github [releases page](https://github.com/aviaviavi/curl-runnings/releases) -- `stack install curl-runnings` -- `cabal install curl-runnings` +- download the 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 -For now, you write your tests specs in a yaml or json file. See /examples to get +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. @@ -46,30 +49,31 @@ Once you've written a spec, simply run it with: -```bash -$ curl-runnings -f path/to/your/spec.yaml -``` +```bash $ curl-runnings -f path/to/your/spec.yaml ``` 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. For more info: -```bash -$ curl-runnings --help -``` +```bash $ curl-runnings --help ``` -### Roadmap +### 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 -- [ ] Embedded dsl for specifications for tests. As the specification gets more complex. - - [ ] Spec out dsl that can compile down into a yaml/json spec - - [ ] Implement dsl +- [ ] Dhall specifications for tests - [ ] More specification features - - [ ] timeouts - - [ ] retry logic - - [ ] ability to configure alerts + - [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 @@ -3,16 +3,15 @@ module Main where -import qualified Data.Text as T -import Data.Version (showVersion) -import Paths_curl_runnings (version) +import qualified Data.Text as T +import Data.Version (showVersion) +import Paths_curl_runnings (version) import System.Console.CmdArgs import System.Environment import System.Exit import Testing.CurlRunnings import Testing.CurlRunnings.Internal import Testing.CurlRunnings.Types -import Text.Printf -- | Command line flags data CurlRunnings = CurlRunnings @@ -25,23 +24,30 @@ CurlRunnings {file = def &= typFile &= help "File to run"} &= 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 "" _ = + putStrLn + "Please specify an input file with the --file (-f) flag or use --help for more information" +runFile path verbosityLevel = 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 + 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 + +toLogLevel :: Verbosity -> LogLevel +toLogLevel v = toEnum $ fromEnum v + main :: IO () main = do - mainArgs <- cmdArgs argParser - case file mainArgs of - "" -> - putStrLn - "Please specify an input file with the --file (-f) flag or use --help for more information" - path -> 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 - if any isFailing results - then putStrLn (makeRed "Some tests failed") >> - exitWith (ExitFailure 1) - else putStrLn $ makeGreen "All tests passed!" - Left messgage -> putStrLn $ "Couldn't read input json or yaml file: " ++ messgage + userArgs <- cmdArgs argParser + verbosityLevel <- getVerbosity + runFile (file userArgs) verbosityLevel diff --git a/curl-runnings.cabal b/curl-runnings.cabal --- a/curl-runnings.cabal +++ b/curl-runnings.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 9530ddd7493ff79858e3c01c7064eb8119932f625cdb1fa3f5cb93e3b3786189 +-- hash: e22614c4e739f355b79fac77eb1cf5c8111237f2adc4aebcccbbb3b118e8d817 name: curl-runnings -version: 0.3.0 +version: 0.6.0 synopsis: A framework for declaratively writing curl based API tests description: Please see the README on Github at category: Testing @@ -22,7 +22,7 @@ extra-source-files: examples/example-spec.json examples/example-spec.yaml - examples/test.json + examples/interpolation-spec.yaml README.md source-repository head @@ -43,6 +43,7 @@ , hspec-expectations >=0.8.2 , http-conduit >=2.2.4 , http-types >=0.9.1 + , megaparsec >=6.3.0 , text >=1.2.2.2 , unordered-containers >=0.2.8.0 , vector >=0.12.0 @@ -51,6 +52,7 @@ Testing.CurlRunnings Testing.CurlRunnings.Types Testing.CurlRunnings.Internal + Testing.CurlRunnings.Internal.Parser 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 @@ -28,12 +28,31 @@ "name": "test 3", "url": "http://your-url.com/other/path", "requestMethod": "GET", + "expectData": { + "contains": [ + { + "keyValueMatch": { + "key": "okay", + "value": true + } + }, + { + "valueMatch": true + } + ] + }, + "expectStatus": 200 + }, + { + "name": "test 4", + "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 4", + "name": "test 5", "url": "http://your-url.com/other/path", "requestMethod": "GET", "headers": "Content-Type: application/json", @@ -45,7 +64,7 @@ ] }, { - "name": "test 5", + "name": "test 6", "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 @@ -32,6 +32,25 @@ - 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 # 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" @@ -40,7 +59,7 @@ # Header strings again match the -H syntax from curl expectHeaders: "Content-Type: application/json; Hello: world" -- name: test 4 +- name: test 5 url: http://your-url.com/other/path requestMethod: GET headers: "Content-Type: application/json" @@ -50,7 +69,7 @@ - key: "Key-With-Val-We-Dont-Care-About" -- name: test 5 +- name: test 6 url: http://your-url.com/other/path requestMethod: GET headers: "Content-Type: application/json" diff --git a/examples/interpolation-spec.yaml b/examples/interpolation-spec.yaml new file mode 100644 --- /dev/null +++ b/examples/interpolation-spec.yaml @@ -0,0 +1,46 @@ +--- +- 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 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 diff --git a/examples/test.json b/examples/test.json deleted file mode 100644 --- a/examples/test.json +++ /dev/null @@ -1,75 +0,0 @@ -[ - { - "name": "test 1", - "url": "http://sd.ddpay.io/status", - "requestMethod": "GET", - "expectData": { - "tag": "Exactly", - "contents": { - "okay": true, - "msg": "" - } - }, - "expectStatus": { - "tag": "ExactCode", - "contents": 200 - }, - "requestData": null - }, - - { - "name": "test 2", - "url": "http://sd.ddpay.io/status", - "requestMethod": "GET", - "expectData": { - "tag": "Contains", - "contents": [ - { - "tag": "ValueMatch", - "contents": true - }, - { - "tag": "ValueMatch", - "contents": "" - }, - { - "tag": "KeyValueMatch", - "matchKey": "msg", - "matchValue": "" - }, - { - "tag": "KeyValueMatch", - "matchKey": "okay", - "matchValue": true - } - ] - }, - "expectStatus": { - "tag": "AnyCodeIn", - "contents": [200, 300] - }, - "requestData": null - }, - - { - "name": "test 4", - "url": "http://sd.ddpay.io/v1/DevOnlyGetAllCustomerIds", - "requestMethod": "POST", - "expectStatus": { - "tag": "ExactCode", - "contents": 400 - }, - "requestData": {} - }, - { - "name": "test 5", - "url": "http://sd.ddpay.io/v1/DevOnlyGetAllCustomerIds", - "requestMethod": "POST", - "expectData": null, - "expectStatus": { - "tag": "AnyCodeIn", - "contents": [401] - }, - "requestData": {"api_token": "asdf"} - } -] diff --git a/src/Testing/CurlRunnings.hs b/src/Testing/CurlRunnings.hs --- a/src/Testing/CurlRunnings.hs +++ b/src/Testing/CurlRunnings.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | 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 @@ -12,74 +12,136 @@ import Control.Monad import Data.Aeson -import qualified Data.ByteString.Char8 as B8S -import qualified Data.ByteString.Lazy as B -import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as H +import Data.Aeson.Types +import qualified Data.ByteString.Char8 as B8S +import qualified Data.ByteString.Lazy as B +import qualified Data.CaseInsensitive as CI +import Data.Either +import qualified Data.HashMap.Strict as H +import Data.List import Data.Maybe -import qualified Data.Text as T -import qualified Data.Yaml as Y +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Yaml as Y import Network.HTTP.Conduit import Network.HTTP.Simple -import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types.Header as HTTP +import System.Directory +import System.Environment +import Testing.CurlRunnings.Internal +import Testing.CurlRunnings.Internal.Parser import Testing.CurlRunnings.Types import Text.Printf -- | decode a json or yaml file into a suite object decodeFile :: FilePath -> IO (Either String CurlSuite) -decodeFile specPath = - 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" (T.pack 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" -> + 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 -- | 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 :: CurlCase -> IO CaseResult -runCase curlCase = do - initReq <- parseRequest $ url curlCase - response <- - httpBS . - (setRequestHeaders - (toHTTPHeaders $ fromMaybe (HeaderSet []) (headers curlCase))) . - setRequestBodyJSON (requestData curlCase) $ - initReq {method = B8S.pack . show $ requestMethod curlCase} - returnVal <- - (return . decode . B.fromStrict $ getResponseBody response) :: IO (Maybe Value) - let returnCode = getResponseStatusCode response - receivedHeaders = responseHeaders response - assertionErrors = - map fromJust $ - filter - isJust - [ checkBody curlCase returnVal - , checkCode curlCase returnCode - , checkHeaders curlCase receivedHeaders - ] - return $ - case assertionErrors of - [] -> CasePass curlCase - failures -> CaseFail curlCase failures +runCase :: CurlRunningsState -> CurlCase -> IO CaseResult +runCase state curlCase = do + let eInterpolatedUrl = interpolateQueryString state $ T.pack $ url curlCase + eInterpolatedHeaders = + interpolateHeaders state $ fromMaybe (HeaderSet []) (headers curlCase) + case (eInterpolatedUrl, eInterpolatedHeaders) of + (Left err, _) -> + return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] + (_, Left err) -> + return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] + (Right interpolatedUrl, Right interpolatedHeaders) -> + case sequence $ runReplacements state <$> requestData curlCase of + Left l -> + return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase l] + Right replacedJSON -> do + initReq <- parseRequest $ T.unpack interpolatedUrl + let request = + setRequestBodyJSON (fromMaybe emptyObject replacedJSON) . + setRequestHeaders (toHTTPHeaders interpolatedHeaders) $ + initReq {method = B8S.pack . show $ requestMethod curlCase} + logger state DEBUG (show request) + response <- httpBS request + logger state DEBUG (show response) + returnVal <- + (return . decode . B.fromStrict $ getResponseBody response) :: IO (Maybe Value) + let returnCode = getResponseStatusCode response + receivedHeaders = fromHTTPHeaders $ responseHeaders response + assertionErrors = + map fromJust $ + filter + isJust + [ checkBody state curlCase returnVal + , checkCode curlCase returnCode + , checkHeaders state curlCase receivedHeaders + ] + return $ + case assertionErrors of + [] -> CasePass curlCase (Just receivedHeaders) returnVal + failures -> + CaseFail curlCase (Just receivedHeaders) returnVal failures -checkHeaders :: CurlCase -> [HTTP.Header] -> Maybe AssertionFailure -checkHeaders (CurlCase _ _ _ _ _ _ _ Nothing) _ = Nothing -checkHeaders curlCase@(CurlCase _ _ _ _ _ _ _ (Just matcher@(HeaderMatcher m))) l = - let receivedHeaders = fromHTTPHeaders l - notFound = filter (not . headerIn receivedHeaders) m - in - if null $ notFound then - Nothing - else - Just $ HeaderFailure curlCase matcher receivedHeaders +checkHeaders :: CurlRunningsState -> CurlCase -> Headers -> Maybe AssertionFailure +checkHeaders _ (CurlCase _ _ _ _ _ _ _ Nothing) _ = Nothing +checkHeaders state curlCase@(CurlCase _ _ _ _ _ _ _ (Just (HeaderMatcher m))) receivedHeaders = + let interpolatedHeaders = mapM (interpolatePartialHeader state) m + in case interpolatedHeaders of + Left f -> Just $ QueryFailure curlCase f + Right headerList -> + let notFound = + filter + (not . headerIn receivedHeaders) + (unsafeLogger state DEBUG "header matchers" headerList) + in if null notFound + then Nothing + else Just $ + HeaderFailure + curlCase + (HeaderMatcher headerList) + receivedHeaders +interpolatePartialHeader :: CurlRunningsState -> PartialHeaderMatcher -> Either QueryError PartialHeaderMatcher +interpolatePartialHeader state (PartialHeaderMatcher k v) = + let k' = interpolateQueryString state <$> k + v' = interpolateQueryString state <$> v + in case (k', v') of + (Just (Left err), _) -> Left err + (_, Just (Left err)) -> Left err + (Just (Right p), Just (Right q)) -> + Right $ PartialHeaderMatcher (Just p) (Just q) + (Just (Right p), Nothing) -> + Right $ PartialHeaderMatcher (Just p) Nothing + (Nothing, Just (Right p)) -> + Right $ PartialHeaderMatcher Nothing (Just p) + _ -> + unsafeLogger state ERROR "WARNING: empty header matcher found" . Right $ + PartialHeaderMatcher Nothing Nothing + +interpolateHeaders :: CurlRunningsState -> Headers -> Either QueryError Headers +interpolateHeaders state (HeaderSet headerList) = + mapM + (\(Header k v) -> + case sequence + [interpolateQueryString state k, interpolateQueryString state v] of + Left err -> Left err + Right [k', v'] -> Right $ Header k' v') + headerList >>= + (Right . HeaderSet) + -- | Does this header contain our matcher? headerMatches :: PartialHeaderMatcher -> Header -> Bool headerMatches (PartialHeaderMatcher mk mv) (Header k v) = - (maybe True (== k) mk) && (maybe True (== v) mv) + maybe True (== k) mk && maybe True (== v) mv -- | Does any of these headers contain our matcher? headerIn :: Headers -> PartialHeaderMatcher -> Bool @@ -94,44 +156,195 @@ printR x = print x >> return x -- | Runs the test cases in order and stop when an error is hit. Returns all the results -runSuite :: CurlSuite -> IO [CaseResult] -runSuite (CurlSuite cases) = +runSuite :: CurlSuite -> LogLevel -> IO [CaseResult] +runSuite (CurlSuite cases) logLevel = do + fullEnv <- getEnvironment + let envMap = H.fromList $ map (\(x, y) -> (T.pack x, T.pack y)) fullEnv foldM (\prevResults curlCase -> case safeLast prevResults of - Just (CaseFail _ _) -> return prevResults - Just (CasePass _) -> do - result <- runCase curlCase >>= printR + Just CaseFail {} -> return prevResults + Just CasePass {} -> do + result <- runCase (CurlRunningsState envMap prevResults logLevel) curlCase >>= printR return $ prevResults ++ [result] Nothing -> do - result <- runCase curlCase >>= printR + result <- runCase (CurlRunningsState envMap [] logLevel) curlCase >>= printR return [result]) [] cases -- | Check if the retrieved value fail's the case's assertion -checkBody :: 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 curlCase@(CurlCase _ _ _ _ _ (Just matcher@(Exactly expectedValue)) _ _) (Just receivedBody) - | expectedValue /= receivedBody = - Just $ DataFailure curlCase matcher (Just receivedBody) - | otherwise = Nothing +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 + 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 curlCase@(CurlCase _ _ _ _ _ (Just matcher@(Contains expectedSubvalues)) _ _) (Just receivedBody) - | jsonContainsAll receivedBody expectedSubvalues = Nothing - | otherwise = Just $ DataFailure curlCase matcher (Just receivedBody) +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) + then Nothing + else Just $ + DataFailure curlCase (Contains updatedMatcher) (Just receivedBody) + -- | We expected a body but didn't get one -checkBody curlCase@(CurlCase _ _ _ _ _ (Just anything) _ _) Nothing = Just $ DataFailure curlCase anything Nothing +checkBody _ curlCase@(CurlCase _ _ _ _ _ (Just anything) _ _) Nothing = + Just $ DataFailure curlCase anything Nothing + -- | No assertions on the body -checkBody (CurlCase _ _ _ _ _ Nothing _ _) _ = Nothing +checkBody _ (CurlCase _ _ _ _ _ Nothing _ _) _ = Nothing +runReplacementsOnSubvalues :: CurlRunningsState -> [JsonSubExpr] -> Either QueryError [JsonSubExpr] +runReplacementsOnSubvalues state = + mapM + (\expr -> + case expr of + ValueMatch v -> + case runReplacements state v of + Left l -> Left l + Right newVal -> Right $ ValueMatch newVal + KeyValueMatch k v -> + case (interpolateQueryString state k, runReplacements state v) of + (Left l, _) -> Left l + (_, Left l) -> Left l + (Right k', Right v') -> + Right KeyValueMatch {matchKey = k', matchValue = v'}) + +-- | runReplacements +runReplacements :: CurlRunningsState -> Value -> Either QueryError Value +runReplacements state (Object o) = + let keys = H.keys o + keysWithUpdatedKeyVal = + map + (\key -> + let value = fromJust $ H.lookup key o + -- (old key, new key, new value) + in ( key + , interpolateQueryString state key + , runReplacements state value)) + keys + in mapRight Object $ + foldr + (\((key, eKeyResult, eValueResult) :: ( T.Text + , Either QueryError T.Text + , Either QueryError Value)) (eObjectToUpdate :: Either QueryError Object) -> + case (eKeyResult, eValueResult, eObjectToUpdate) + -- TODO there should be a more elegant way to write this error + -- handling below + of + (Left queryErr, _, _) -> Left queryErr + (_, Left queryErr, _) -> Left queryErr + (_, _, Left queryErr) -> Left queryErr + (Right newKey, Right newValue, Right objectToUpdate) -> + if key /= newKey + then let inserted = H.insert newKey newValue objectToUpdate + deleted = H.delete key inserted + in Right deleted + else Right $ H.insert key newValue objectToUpdate) + (Right o) + keysWithUpdatedKeyVal +runReplacements p (Array a) = + let results = V.mapM (runReplacements p) a + in case results of + Left l -> Left l + Right r -> Right $ Array r +-- special case, i can't figure out how to get the parser to parse empty strings :'( +runReplacements _ s@(String "") = Right s +runReplacements state (String s) = + case parseQuery s of + Right [LiteralText t] -> Right $ String t + Right [q@(InterpolatedQuery _ _)] -> getStringValueForQuery state q >>= (Right . String) + Right [q@(NonInterpolatedQuery _)] -> getValueForQuery state q + Right _ -> mapRight String $ interpolateQueryString state s + Left parseErr -> Left parseErr +runReplacements _ valToUpdate = Right valToUpdate + +-- | 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 state query = + let parsedQuery = parseQuery query + in case parsedQuery of + (Left err) -> Left err + (Right interpolatedQ) -> + let lookups :: [Either QueryError T.Text] = + map (getStringValueForQuery state) interpolatedQ + failure = find isLeft lookups + goodLookups :: [T.Text] = + Prelude.map (fromRight (T.pack "error")) lookups + in fromMaybe (Right $ foldr (<>) (T.pack "") goodLookups) failure + +-- | Lookup the text at the specified query +getStringValueForQuery :: CurlRunningsState -> InterpolatedQuery -> Either QueryError T.Text +getStringValueForQuery _ (LiteralText rawText) = Right rawText +getStringValueForQuery state (NonInterpolatedQuery q) = + getStringValueForQuery state $ InterpolatedQuery "" q +getStringValueForQuery state i@(InterpolatedQuery rawText (Query _)) = + case getValueForQuery state i of + Left l -> Left l + Right (String s) -> Right $ rawText <> s + (Right o) -> Left $ QueryTypeMismatch "Expected a string" o +getStringValueForQuery (CurlRunningsState env _ _) (InterpolatedQuery rawText (EnvironmentVariable v)) = + Right $ rawText <> H.lookupDefault "" v env + +-- | Lookup the value for the specified query +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) + _ -> + Left . QueryValidationError $ + T.pack $ "$<> queries must start with a SUITE[index] query: " ++ show full +getValueForQuery (CurlRunningsState env _ _) (NonInterpolatedQuery (EnvironmentVariable var)) = + Right . String $ H.lookupDefault "" var env +getValueForQuery state (InterpolatedQuery _ q) = + case getValueForQuery state (NonInterpolatedQuery q) of + Right (String s) -> Right . String $ s + Right Null -> Right Null + Right v -> Left $ QueryTypeMismatch (T.pack "Expected a string") v + Left l -> Left l + -- | 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 -> - containsKeyVal jsonValue key subval + all $ \match -> + case match of + ValueMatch subval -> subval `elem` traverseValue jsonValue + KeyValueMatch key subval -> + any (\o -> containsKeyVal o key subval) (traverseValue jsonValue) -- | Does the json value contain the given key value pair? containsKeyVal :: Value -> T.Text -> Value -> Bool 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 @@ -3,10 +3,58 @@ module Testing.CurlRunnings.Internal ( makeRed , makeGreen + , tracer + , mapRight + , arrayGet + , makeLogger + , makeUnsafeLogger + + , LogLevel(..) + , CurlRunningsLogger + , CurlRunningsUnsafeLogger ) where +import Control.Monad +import Debug.Trace + makeGreen :: String -> String makeGreen s = "\x1B[32m" ++ s ++ "\x1B[0m" makeRed :: String -> String makeRed s = "\x1B[31m" ++ s ++ "\x1B[0m" + +tracer :: Show a => String -> a -> a +tracer a b = trace (a ++ ": " ++ show b) b + +mapRight :: (b -> c) -> Either a b -> Either a c +mapRight f (Right v) = Right $ f v +mapRight _ (Left v) = Left v + +-- | Array indexing with negative values allowed +arrayGet :: [a] -> Int -> a +arrayGet a i + | i >= 0 = a !! i + | otherwise = reverse a !! (-i) + +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 ()) + +-- | 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) + +makeLogger :: LogLevel -> CurlRunningsLogger +makeLogger threshold level text = + when (level <= threshold) $ putStrLn text + +makeUnsafeLogger :: Show a => LogLevel -> CurlRunningsUnsafeLogger a +makeUnsafeLogger threshold level text 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 new file mode 100644 --- /dev/null +++ b/src/Testing/CurlRunnings/Internal/Parser.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Internal module for parsing string based directives inside of curl runnings +-- suites. Use this module at your own risk, it may change. Currently, string +-- 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 +-- 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 $" +-- > +-- +-- 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 +-- +-- > +-- > $< ... > +-- > +-- +-- to signify an interpolation. You can have mutliple queries inside a +-- single string, but if interpolation is occuring, then the query specified +-- must resolve to a string value. Otheriwse, a type error will be thrown. +module Testing.CurlRunnings.Internal.Parser + ( + parseQuery + ) where + +import Data.List +import qualified Data.Text as T +import Data.Void +import Testing.CurlRunnings.Types +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +-- | Given some query text, attempt to parse it to a list of interplated query objects. This data representation may change. +parseQuery :: FullQueryText -> Either QueryError [InterpolatedQuery] +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 + +type Parser = Parsec Void T.Text + +parseSuiteIndex' :: Parser Index +parseSuiteIndex' = do + notFollowedBy gtlt + _ <- string "SUITE" + (ArrayIndex i) <- arrayIndexParser + return $ CaseResultIndex i + +spaceOrDot :: Parser () +spaceOrDot = (try $ char '.' >> space) <|> space + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme spaceOrDot + +symbol :: T.Text -> Parser T.Text +symbol = L.symbol spaceOrDot + +inGTLT :: Parser a -> Parser a +inGTLT = between (symbol "$<") (string ">") + +gtlt :: Parser T.Text +gtlt = symbol "<" <|> symbol ">" + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +bracket :: Parser T.Text +bracket = symbol "[" <|> symbol "]" + +braces :: Parser a -> Parser a +braces = between (symbol "${") (string "}") + +brace :: Parser T.Text +brace = symbol "{" <|> symbol "}" + +integer :: Parser Integer +integer = lexeme $ L.signed spaceOrDot L.decimal + +dot :: Parser T.Text +dot = symbol "." + +arrayIndexParser :: Parser Index +arrayIndexParser = notFollowedBy gtlt >> ArrayIndex <$> brackets integer + +environmentVariableParser :: Parser Query +environmentVariableParser = do + notFollowedBy endingChars + (EnvironmentVariable . T.pack) <$> braces (lexeme $ many (noneOf ['[', ']', '<', '>', ' ', '{', '}'])) + +endingChars :: Parser T.Text +endingChars = dot <|> eol <|> bracket <|> gtlt <|> brace + +keyIndexParser :: Parser Index +keyIndexParser = do + notFollowedBy endingChars + (lexeme . try) ((KeyIndex . T.pack) <$> p) + where + p = (:) <$> letterChar <*> many (noneOf ['.', '[', ']', '<', '>', ' ', '{', '}']) + +jsonIndexParser :: Parser Query +jsonIndexParser = + leadingText >> + (inGTLT $ some (parseSuiteIndex' <|> keyIndexParser <|> arrayIndexParser)) >>= + return . Query + +interpolatedQueryParser :: Parser InterpolatedQuery +interpolatedQueryParser = do + text <- leadingText + q <- environmentVariableParser <|> jsonIndexParser + if null text then return $ NonInterpolatedQuery q + else return $ InterpolatedQuery (T.pack text) q + +leadingText :: Parser String +leadingText = manyTill anyChar $ lookAhead (symbol "$<" <|> "${") + +noQueryText :: Parser InterpolatedQuery +noQueryText = do + str <- some anyChar + eof + if "$<" `isInfixOf` str + then fail "invalid `$<` found" + else if "${" `isInfixOf` str + then fail "invalid `${` found" + else return $ LiteralText $ T.pack str + +parseFullTextWithQuery :: Parser [InterpolatedQuery] +parseFullTextWithQuery = many ((try interpolatedQueryParser) <|> noQueryText) + 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 @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} -- | Data types for curl-runnings tests @@ -16,9 +16,18 @@ , JsonSubExpr(..) , PartialHeaderMatcher(..) , StatusCodeMatcher(..) + , QueryError(..) + , Index(..) + , Query(..) + , InterpolatedQuery(..) + , FullQueryText + , SingleQueryText + , CurlRunningsState(..) , isFailing , isPassing + , logger + , unsafeLogger ) where @@ -96,6 +105,26 @@ instance ToJSON HeaderMatcher +-- | 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 + -- | 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 + +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 (QueryValidationError message) = printf "invalid query: %s" message + parseHeader :: T.Text -> Either T.Text Header parseHeader str = case map T.strip $ T.splitOn ":" str of @@ -207,56 +236,79 @@ | HeaderFailure CurlCase HeaderMatcher Headers + -- | Something went wrong with a test case json query + | QueryFailure CurlCase + QueryError -- | Something else | UnexpectedFailure + +colorizeExpects :: String -> String +colorizeExpects t = + let expectedColor = makeRed "Excpected:" + actualColor = makeRed "Actual:" + replacedExpected = T.replace "Expected:" (T.pack expectedColor) (T.pack t) + in T.unpack $ T.replace "Actual:" (T.pack actualColor) replacedExpected + instance Show AssertionFailure where show (StatusFailure c receivedCode) = case expectStatus c of ExactCode code -> + colorizeExpects $ printf "Incorrect status code from %s. Expected: %s. Actual: %s" (url c) (show code) (show receivedCode) AnyCodeIn codes -> + colorizeExpects $ printf - "Incorrect status code from %s. Expected one of: %s. Actual: %s" + "Incorrect status code from %s. Expected: %s. Actual: %s" (url c) (show codes) (show receivedCode) show (DataFailure curlCase expected receivedVal) = case expected of Exactly expectedVal -> + colorizeExpects $ printf "JSON response from %s didn't match spec. Expected: %s. Actual: %s" (url curlCase) (B8.unpack (encodePretty expectedVal)) (B8.unpack (encodePretty receivedVal)) (Contains expectedVals) -> + colorizeExpects $ printf "JSON response from %s didn't contain the matcher. Expected: %s to be each be subvalues in: %s" (url curlCase) (B8.unpack (encodePretty expectedVals)) (B8.unpack (encodePretty receivedVal)) show (HeaderFailure curlCase expected receivedHeaders) = + colorizeExpects $ printf - "Headers from %s didn't contain expected headers. Expected headers: %s. Received headers: %s" + "Headers from %s didn't contain expected headers. Expected: %s. Actual: %s" (url curlCase) (show expected) (show receivedHeaders) + show (QueryFailure curlCase queryErr) = + colorizeExpects $ + printf "JSON query error in spec %s: %s" (name curlCase) (show queryErr) show UnexpectedFailure = "Unexpected Error D:" -- | A type representing the result of a single curl, and all associated -- assertions data CaseResult = CasePass CurlCase + (Maybe Headers) + (Maybe Value) | CaseFail CurlCase + (Maybe Headers) + (Maybe Value) [AssertionFailure] instance Show CaseResult where - show (CasePass c) = makeGreen "[PASS] " ++ name c - show (CaseFail c failures) = + show (CasePass c _ _) = makeGreen "[PASS] " ++ name c + show (CaseFail c _ _ failures) = makeRed "[FAIL] " ++ name c ++ "\n" ++ @@ -274,10 +326,67 @@ -- | Simple predicate that checks if the result is passing isPassing :: CaseResult -> Bool -isPassing (CasePass _) = True -isPassing (CaseFail _ _) = False +isPassing CasePass {} = True +isPassing CaseFail {} = False -- | Simple predicate that checks if the result is failing isFailing :: CaseResult -> Bool -isFailing (CasePass _) = False -isFailing (CaseFail _ _) = True +isFailing = not . isPassing + +-- | A map of the system environment +type Environment = H.HashMap T.Text T.Text + +-- | The state of a suite. Tracks environment variables, and all the test results so far +data CurlRunningsState = CurlRunningsState Environment [CaseResult] LogLevel + +logger :: CurlRunningsState -> CurlRunningsLogger +logger (CurlRunningsState _ _ l) = makeLogger l + +unsafeLogger :: Show a => CurlRunningsState -> CurlRunningsUnsafeLogger a +unsafeLogger (CurlRunningsState _ _ l) = makeUnsafeLogger l + +-- | A single lookup operation in a json query +data Index + -- | Drill into the json of a specific test case. The SUITE object is + -- accessible as an array of values that have come back from previous test + -- cases + = CaseResultIndex Integer + -- | A standard json key lookup. + | KeyIndex T.Text + -- | A standard json array index lookup. + | ArrayIndex Integer + deriving (Show) + +printOriginalQuery (CaseResultIndex t) = "SUITE[" ++ show t ++ "]" +printOriginalQuery (KeyIndex key) = "." ++ T.unpack key +printOriginalQuery (ArrayIndex i) = printf "[%d]" i + +-- | A single entity to be queries from a json value +data Query = + -- | A single query contains a list of discrete index operations + Query [Index] | + -- | Lookup a string in the environment + EnvironmentVariable T.Text + deriving (Show) + +-- | A distinct parsed unit in a query +data InterpolatedQuery + -- | Regular text, no query + = LiteralText T.Text + -- | Some leading text, then a query + | InterpolatedQuery T.Text + Query + -- | Just a query, no leading text + | NonInterpolatedQuery Query + deriving (Show) + +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) + +-- | The full string in which a query appears, eg "prefix-${{SUITE[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 +type SingleQueryText = T.Text diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Data.Either import System.Directory import Test.Hspec import Testing.CurlRunnings +import Testing.CurlRunnings.Internal.Parser main :: IO () main = hspec $ @@ -13,6 +16,28 @@ it "should provide valid example json specs" $ testValidSpec "/examples/example-spec.json" + + -- note that this doesn't actually try to parse the interpolations themselves, + -- but that would be useful thing to add here + it "should provid a valid interpolation spec" $ + testValidSpec "/examples/interpolation-spec.yaml" + + 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 + + it "should reject invalid queries" $ do + parseQuery "$<" `shouldSatisfy` isLeft + parseQuery "$" `shouldSatisfy` isLeft + parseQuery "$" `shouldSatisfy` isLeft + parseQuery "$>" `shouldSatisfy` isLeft + parseQuery "$.key[1][1] ${" `shouldSatisfy` isLeft testValidSpec :: String -> IO () testValidSpec file = do