diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -16,18 +16,18 @@ ### Why? -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. +This library came out of a pain-point my coworkers 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! @@ -125,7 +125,6 @@ context: . dockerfile: ./Dockerfile ``` - ### Contributing diff --git a/curl-runnings.cabal b/curl-runnings.cabal --- a/curl-runnings.cabal +++ b/curl-runnings.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: c5eff7acb49843acbacdcf64e3e57fd05242eee41e466f2468cc9bf696b5f666 +-- hash: 184f34d36c0d081262571516a7ddbef911407a4dc5c3c08f6b67982a7d30d485 name: curl-runnings -version: 0.11.1 +version: 0.12.0 synopsis: A framework for declaratively writing curl based API tests description: Please see the README on Github at category: Testing @@ -36,6 +36,9 @@ Testing.CurlRunnings.Types Testing.CurlRunnings.Internal Testing.CurlRunnings.Internal.Parser + Testing.CurlRunnings.Internal.Headers + Testing.CurlRunnings.Internal.KeyValuePairs + Testing.CurlRunnings.Internal.Payload other-modules: Paths_curl_runnings hs-source-dirs: @@ -45,16 +48,19 @@ , base >=4.0 && <5 , bytestring >=0.10.8.2 , case-insensitive >=0.2.1 + , clock >=0.7.2 , connection >=0.2.8 , directory >=1.3.0.2 , hspec >=2.4.4 , hspec-expectations >=0.8.2 , http-client-tls >=0.3.5.3 , http-conduit >=2.3.6 + , http-types >=0.12.3 , megaparsec >=7.0.4 , pretty-simple >=2.0.2.1 , regex-posix >=0.95.2 , text >=1.2.2.2 + , time >=1.8.0.2 , unordered-containers >=0.2.8.0 , vector >=0.12.0 , yaml >=0.8.28 @@ -89,9 +95,13 @@ test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.0 && <5 + aeson >=1.2.4.0 + , base >=4.0 && <5 + , bytestring >=0.10.8.2 , curl-runnings , directory >=1.3.0.2 , hspec >=2.4.4 , hspec-expectations >=0.8.2 + , raw-strings-qq >=1.1 + , text >=1.2.2.2 default-language: Haskell2010 diff --git a/examples/example-spec.json b/examples/example-spec.json --- a/examples/example-spec.json +++ b/examples/example-spec.json @@ -3,6 +3,9 @@ "name": "test 1", "url": "http://your-endpoint.com/status", "requestMethod": "GET", + "queryParameters": { + "key": "value" + }, "expectData": { "exactly": { "okay": true, @@ -26,6 +29,22 @@ }, { "name": "test 3", + "url": "http://your-endpoint.com/path", + "requestMethod": "POST", + "expectStatus": [ + 200, + 201 + ], + "requestData": { + "bodyType": "urlencoded", + "content": { + "hello": "there", + "num": 1 + } + } + }, + { + "name": "test 4", "url": "http://your-url.com/other/path", "requestMethod": "GET", "expectData": { @@ -44,7 +63,7 @@ "expectStatus": 200 }, { - "name": "test 4", + "name": "test 5", "url": "http://your-url.com/other/path", "requestMethod": "GET", "expectData": { @@ -63,7 +82,7 @@ "expectStatus": 200 }, { - "name": "test 5", + "name": "test 6", "url": "http://your-url.com/other/path", "requestMethod": "GET", "expectData": { @@ -84,7 +103,7 @@ "expectStatus": 200 }, { - "name": "test 6", + "name": "test 7", "url": "http://your-url.com/other/path", "requestMethod": "GET", "headers": "Content-Type: application/json", @@ -92,7 +111,7 @@ "expectHeaders": "Content-Type: application/json; Hello: world" }, { - "name": "test 7", + "name": "test 8", "url": "http://your-url.com/other/path", "requestMethod": "GET", "headers": "Content-Type: application/json", @@ -104,7 +123,7 @@ ] }, { - "name": "test 8", + "name": "test 9", "url": "http://your-url.com/other/path", "requestMethod": "GET", "headers": "Content-Type: application/json", diff --git a/examples/example-spec.yaml b/examples/example-spec.yaml --- a/examples/example-spec.yaml +++ b/examples/example-spec.yaml @@ -6,6 +6,8 @@ - name: test 1 # required url: http://your-endpoint.com/status # required requestMethod: GET # required + queryParameters: # optional (in addition to those set on the url). + key: value # [Optional] Specify the json payload we expect here # The 1 key in this block should be either: # exactly | contains @@ -32,6 +34,22 @@ num: 1 - name: test 3 + url: http://your-endpoint.com/path + requestMethod: POST + expectStatus: + - 200 + - 201 + # [Optional] Data to send with the request. + requestData: + # `bodyType` specifies the type of request payload. Possible values + # are `urlencoded` | `json`. + bodyType: urlencoded + content: + # This object specifies the data to send with the request. + hello: there + num: 1 + + - name: test 4 url: http://your-url.com/other/path requestMethod: GET expectData: @@ -52,7 +70,7 @@ - keyMatch: okay expectStatus: 200 - - name: test 4 + - name: test 5 url: http://your-url.com/other/path requestMethod: GET expectData: @@ -68,7 +86,7 @@ - keyMatch: error expectStatus: 200 - - name: test 5 + - name: test 6 url: http://your-url.com/other/path requestMethod: GET expectData: @@ -81,7 +99,7 @@ - valueMatch: false expectStatus: 200 - - name: test 6 + - name: test 7 url: http://your-url.com/other/path requestMethod: GET # Specify the headers you want to sent, just like the -H flag in a curl command @@ -92,7 +110,7 @@ # Header strings again match the -H syntax from curl expectHeaders: "Content-Type: application/json; Hello: world" - - name: test 7 + - name: test 8 url: http://your-url.com/other/path requestMethod: GET headers: "Content-Type: application/json" @@ -102,7 +120,7 @@ - key: "Key-With-Val-We-Dont-Care-About" - - name: test 8 + - name: test 9 url: http://your-url.com/other/path requestMethod: GET headers: "Content-Type: application/json" @@ -112,4 +130,3 @@ - "Hello: world" - value: "Value-With-Key-We-Dont-Care-About" - diff --git a/src/Testing/CurlRunnings.hs b/src/Testing/CurlRunnings.hs --- a/src/Testing/CurlRunnings.hs +++ b/src/Testing/CurlRunnings.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# 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 @@ -22,6 +26,8 @@ import Data.Maybe import Data.Monoid import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock import qualified Data.Vector as V import qualified Data.Yaml.Include as YI import Network.Connection (TLSSettings (..)) @@ -29,6 +35,7 @@ import Network.HTTP.Conduit import Network.HTTP.Simple hiding (Header) import qualified Network.HTTP.Simple as HTTP +import qualified Network.HTTP.Types as NT import System.Directory import System.Environment import Testing.CurlRunnings.Internal @@ -63,6 +70,18 @@ , settingUseServerName = False } +-- | Fetch existing query parameters from the request and append those specfied in the queryParameters field. +appendQueryParameters :: [KeyValuePair] -> Request -> Request +appendQueryParameters newParams r = setQueryString (existing ++ newQuery) r where + existing = NT.parseQuery $ queryString r + newQuery = NT.simpleQueryToQuery $ fmap (\(KeyValuePair k v) -> (T.encodeUtf8 k, T.encodeUtf8 v)) newParams + +setPayload :: Maybe Payload -> Request -> Request +setPayload Nothing = id +setPayload (Just (JSON v)) = setRequestBodyJSON v +setPayload (Just (URLEncoded (KeyValuePairs xs))) = setRequestBodyURLEncoded $ kvpairs xs where + kvpairs = fmap (\(KeyValuePair k v) -> (T.encodeUtf8 k, T.encodeUtf8 v)) + -- | Run a single test case, and returns the result. IO is needed here since this method is responsible -- for actually curling the test case endpoint and parsing the result. runCase :: CurlRunningsState -> CurlCase -> IO CaseResult @@ -70,29 +89,37 @@ let eInterpolatedUrl = interpolateQueryString state $ 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 + eInterpolatedQueryParams = interpolateViaJSON state $ fromMaybe (KeyValuePairs []) (queryParameters curlCase) + case (eInterpolatedUrl, eInterpolatedHeaders, eInterpolatedQueryParams) of + (Left err, _, _) -> + return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] 0 + (_, Left err, _) -> + return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] 0 + (_, _, Left err) -> + return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase err] 0 + (Right interpolatedUrl, Right interpolatedHeaders, Right (KeyValuePairs interpolatedQueryParams)) -> + case sequence $ interpolateViaJSON state <$> requestData curlCase of Left l -> - return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase l] - Right replacedJSON -> do + return $ CaseFail curlCase Nothing Nothing [QueryFailure curlCase l] 0 + Right interpolatedData -> do initReq <- parseRequest $ T.unpack interpolatedUrl manager <- newManager noVerifyTlsManagerSettings - let request = - setRequestBodyJSON (fromMaybe emptyObject replacedJSON) . + + let !request = + setPayload interpolatedData . setRequestHeaders (toHTTPHeaders interpolatedHeaders) . + appendQueryParameters interpolatedQueryParams . (if tlsCheckType == DoTLSCheck then id else (setRequestManager manager)) $ initReq {method = B8S.pack . show $ requestMethod curlCase} logger state DEBUG (pShow request) logger state DEBUG - ("Request body: " <> (pShow $ fromMaybe emptyObject replacedJSON)) + ("Request body: " <> (pShow $ fromMaybe (JSON emptyObject) interpolatedData)) + start <- nowMillis response <- httpBS request + stop <- nowMillis + let elapsed = stop - start -- If the response is just returning bytes, we won't print them let responseHeaderValues = map snd (getResponseHeaders response) if "application/octet-stream" `notElem` responseHeaderValues && @@ -127,14 +154,14 @@ ] return $ case assertionErrors of - [] -> CasePass curlCase (Just receivedHeaders) returnVal + [] -> CasePass curlCase (Just receivedHeaders) returnVal elapsed failures -> - CaseFail curlCase (Just receivedHeaders) returnVal failures + CaseFail curlCase (Just receivedHeaders) returnVal failures elapsed checkHeaders :: CurlRunningsState -> CurlCase -> Headers -> Maybe AssertionFailure -checkHeaders _ (CurlCase _ _ _ _ _ _ _ Nothing) _ = Nothing -checkHeaders state curlCase@(CurlCase _ _ _ _ _ _ _ (Just (HeaderMatcher m))) receivedHeaders = +checkHeaders _ CurlCase { expectHeaders = Nothing } _ = Nothing +checkHeaders state curlCase@CurlCase { expectHeaders = Just (HeaderMatcher m) } receivedHeaders = let interpolatedHeaders = mapM (interpolatePartialHeader state) m in case interpolatedHeaders of Left f -> Just $ QueryFailure curlCase f @@ -229,7 +256,7 @@ 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) = +checkBody state curlCase@CurlCase { expectData = (Just (Exactly expectedValue)) } (Just receivedBody) = case runReplacements state expectedValue of (Left err) -> Just $ QueryFailure curlCase err (Right interpolated) -> @@ -242,7 +269,7 @@ (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) = +checkBody state curlCase@CurlCase { expectData = (Just (Contains subexprs)) } (Just receivedBody) = case runReplacementsOnSubvalues state subexprs of Left f -> Just $ QueryFailure curlCase f Right updatedMatcher -> @@ -253,7 +280,7 @@ 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) = +checkBody state curlCase@CurlCase { expectData = (Just (NotContains subexprs)) } (Just receivedBody) = case runReplacementsOnSubvalues state subexprs of Left f -> Just $ QueryFailure curlCase f Right updatedMatcher -> @@ -267,7 +294,7 @@ (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 = +checkBody state curlCase@CurlCase { expectData = (Just m@(MixedContains subexprs)) } receivedBody = let failure = join $ find @@ -281,10 +308,10 @@ subexprs) in fmap (\_ -> DataFailure curlCase m receivedBody) failure -- | We expected a body but didn't get one -checkBody _ curlCase@(CurlCase _ _ _ _ _ (Just anything) _ _) Nothing = +checkBody _ curlCase@CurlCase { expectData = (Just anything) } Nothing = Just $ DataFailure curlCase anything Nothing -- | No assertions on the body -checkBody _ (CurlCase _ _ _ _ _ Nothing _ _) _ = Nothing +checkBody _ CurlCase { expectData = Nothing } _ = Nothing runReplacementsOnSubvalues :: CurlRunningsState -> [JsonSubExpr] -> Either QueryError [JsonSubExpr] @@ -357,6 +384,16 @@ Left parseErr -> Left parseErr runReplacements _ valToUpdate = Right valToUpdate +-- | Given an instance of both ToJSON and FromJSON return a new instance with +-- interpolated values. +-- NB: interpolateViaJSON assumes that fromJSON . toJSON is identity +interpolateViaJSON :: (ToJSON a, FromJSON a) => CurlRunningsState -> a -> Either QueryError a +interpolateViaJSON state i = do + replaced <- runReplacements state $ toJSON i + resultToEither $ fromJSON replaced where + resultToEither (Error e) = Left $ QueryValidationError $ T.pack e + resultToEither (Success a) = Right a + -- | Given a query string, return some text with interpolated values. Type -- errors will be returned if queries don't resolve to strings interpolateQueryString :: @@ -396,9 +433,9 @@ (CaseResultIndex i) -> let maybeCase = arrayGet previousResults $ fromInteger i in if isJust maybeCase - then let (CasePass _ _ returnedJSON) = fromJust maybeCase + then let CasePass{caseResponseValue} = fromJust maybeCase jsonToIndex = - case returnedJSON of + case caseResponseValue of Just v -> Right v Nothing -> Left $ @@ -493,10 +530,10 @@ -- | Verify the returned http status code is ok, construct the right failure -- type if needed checkCode :: CurlCase -> Int -> Maybe AssertionFailure -checkCode curlCase@(CurlCase _ _ _ _ _ _ (ExactCode expectedCode) _) receivedCode +checkCode curlCase@CurlCase { expectStatus = (ExactCode expectedCode) } receivedCode | expectedCode /= receivedCode = Just $ StatusFailure curlCase receivedCode | otherwise = Nothing -checkCode curlCase@(CurlCase _ _ _ _ _ _ (AnyCodeIn l) _) receivedCode +checkCode curlCase@CurlCase { expectStatus = (AnyCodeIn l) } receivedCode | receivedCode `notElem` l = Just $ StatusFailure curlCase receivedCode | otherwise = Nothing 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 @@ -12,6 +12,8 @@ , makeLogger , makeUnsafeLogger , pShow + , nowMillis + , roundToStr , LogLevel(..) , CurlRunningsLogger , CurlRunningsUnsafeLogger @@ -22,8 +24,11 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Debug.Trace +import System.Clock import qualified Text.Pretty.Simple as P +import Text.Printf + makeGreen :: T.Text -> T.Text makeGreen s = "\x1B[32m" <> s <> "\x1B[0m" @@ -73,3 +78,11 @@ if level <= threshold then tracer text object else object + +nowMillis :: IO Integer +nowMillis = do + t <- getTime Realtime + return $ (toNanoSecs t) `div` 1000000 + +roundToStr :: (PrintfArg a, Floating a) => a -> String +roundToStr = printf "%0.2f" diff --git a/src/Testing/CurlRunnings/Internal/Headers.hs b/src/Testing/CurlRunnings/Internal/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Testing/CurlRunnings/Internal/Headers.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Module defining the Header and Headers types and a parser with a FromJSON +-- instance for the Headers type. +-- +-- Headers are parsed from a semi-colon separated sequence of key:value pairs. +-- Some examples: +-- +-- > "key: value" +-- > "key1: value1; key2: value2" +-- +-- Keys can be any sequence of ASCII characters excluding ':' and must not be +-- all whitespace. For example: +-- +-- > " : value" +-- +-- is invalid. +-- +-- Values can be any sequence of ASCII characters excluding ';' and may be all +-- whitespace. For example: +-- +-- > "key : " +-- +-- is valid. +module Testing.CurlRunnings.Internal.Headers + ( Header (..) + , Headers (..) + , parseHeaders + ) where + +import Data.Aeson +import Data.Aeson.Types hiding (Parser) +import Data.Bifunctor (Bifunctor (..)) +import Data.Char (isAscii, isSpace) +import Data.Functor (void) +import qualified Data.Text as T +import Data.Void +import GHC.Generics +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +-- | A representation of a single header +data Header = + Header T.Text + T.Text + deriving (Show, Generic, Eq) + +instance ToJSON Header + +instance ToJSON Headers + +-- | Simple container for a list of headers, useful for a vehicle for defining a +-- fromJSON +newtype Headers = + HeaderSet [Header] + deriving (Show, Generic, Eq) + +instance FromJSON Headers where + parseJSON a@(String v) = + case parseHeaders v of + Right h -> return h + Left e -> typeMismatch ("Header failure: " ++ T.unpack e) a + parseJSON invalid = typeMismatch "Header" invalid + +-- | Given a header text, attempt to parse it into Headers. +parseHeaders :: T.Text -> Either T.Text Headers +parseHeaders hs = let trimmed = T.strip hs in + first (T.pack . errorBundlePretty) (Text.Megaparsec.parse headersParser "" trimmed) + +type Parser = Parsec Void T.Text + +headerColon :: Parser T.Text +headerColon = L.symbol space ":" + +headerSemiColon :: Parser T.Text +headerSemiColon = L.symbol space ";" + +endOfHeader :: Parser () +endOfHeader = try (void headerSemiColon) <|> eof + +headerParser :: Parser Header +headerParser = do + key <- do + firstChar <- satisfy asciiExcludingColonAndSpace + rest <- takeWhileP (Just "header key") asciiExcludingColon <* headerColon + return $ T.singleton firstChar <> rest + value <- takeWhileP (Just "header value") asciiExcludingSemiColon <* endOfHeader + return $ Header (T.strip key) (T.strip value) where + asciiExcludingColon = asciiExcludingChar ':' + asciiExcludingSemiColon = asciiExcludingChar ';' + asciiExcludingColonAndSpace t = asciiExcludingColon t && not (isSpace t) + asciiExcludingChar c t = isAscii t && t /= c + +headersParser :: Parser Headers +headersParser = HeaderSet <$> some headerParser diff --git a/src/Testing/CurlRunnings/Internal/KeyValuePairs.hs b/src/Testing/CurlRunnings/Internal/KeyValuePairs.hs new file mode 100644 --- /dev/null +++ b/src/Testing/CurlRunnings/Internal/KeyValuePairs.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A module defining the KeyValuePairs type. This type may be used to +-- represent a structure in a specification that is a collection of +-- key-vaue pairs. For example query parameters and URLEncoded request +-- bodies. +-- +-- The module provides FromJSON and ToJSON instances for KeyValuePairs. +-- Valid KeyValuePairs JSON is a single JSON object where all values +-- are either String, Scienfific or Bool. + +module Testing.CurlRunnings.Internal.KeyValuePairs + ( KeyValuePairs (..) + , KeyValuePair (..) + ) where + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Lazy as LBS +import Data.HashMap.Strict as H +import qualified Data.Text as T +import Data.Text.Encoding as T + +-- | A container for a list of key-value pairs +newtype KeyValuePairs = KeyValuePairs [KeyValuePair] deriving Show + +-- | A representation of a single key-value pair +data KeyValuePair = KeyValuePair T.Text T.Text deriving Show + +instance ToJSON KeyValuePairs where + toJSON (KeyValuePairs qs) = + object (fmap (\(KeyValuePair k v) -> k .= toJSON v) qs) + +instance FromJSON KeyValuePairs where + parseJSON = withObject "keyValuePairs" parseKeyValuePairs where + parseKeyValuePairs o = KeyValuePairs <$> traverse parseKeyValuePair (H.toList o) + parseKeyValuePair (t, v) = KeyValuePair t <$> parseSingleValueType v + +parseSingleValueType :: Value -> Parser T.Text +parseSingleValueType (Bool b) = parseToText b +parseSingleValueType (String t) = return t +parseSingleValueType (Number n) = parseToText n +parseSingleValueType invalid = typeMismatch "KeyValuePairs" invalid + +parseToText :: (ToJSON a) => a -> Parser T.Text +parseToText = return . T.decodeUtf8 . LBS.toStrict . encode 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 @@ -34,6 +34,8 @@ parseQuery ) where +import Data.Bifunctor (Bifunctor (..)) +import Data.Char (isAscii) import Data.List import qualified Data.Text as T import Data.Void @@ -151,4 +153,3 @@ parseFullTextWithQuery :: Parser [InterpolatedQuery] parseFullTextWithQuery = many ((try interpolatedQueryParser) <|> noQueryText) - diff --git a/src/Testing/CurlRunnings/Internal/Payload.hs b/src/Testing/CurlRunnings/Internal/Payload.hs new file mode 100644 --- /dev/null +++ b/src/Testing/CurlRunnings/Internal/Payload.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | A module defining the Payload type. This is used in specifications to +-- represent request body data. Currently JSON and URLEncoded bodies are +-- supported. +-- +-- The module provides a FromJSON instance to parse a Payload from a +-- specification. +-- +-- Payload is parsed from an object containing two keys: `bodyType` and +-- `content`. +-- +-- The value of the `bodyType` field must be either `json` or +-- `urlencoded` and this indicates how the request data should be encoded. +-- +-- When `bodyType` is `urlencoded ` the value of the `content` field must be an +-- object with string, numeric or boolean values. +-- +-- When `bodyType` is `json` the value of the `content` field will be used as +-- the JSON payload. +-- +-- If `bodyType` is not present then the whole object is used as the JSON +-- payload. +-- +-- Examples: +-- 1. A URLEncoded request payload: +-- +-- > requestData: +-- > bodyType: urlencoded +-- > content: +-- > key1: value +-- > key2: true +-- > key3: 10.22 +-- +-- 2: A JSON request payload using `bodyType`: +-- +-- > requestData: +-- > bodyType: json +-- > content: +-- > key1: value +-- > key2: [1,2,3] +-- +-- 3: A JSON request payload without using `bodyType`: +-- +-- > requestData: +-- > key1: value +-- > key2: [1,2,3] +-- +module Testing.CurlRunnings.Internal.Payload + ( Payload (..) + ) where + +import Data.Aeson +import qualified Data.Char as C +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import GHC.Generics +import Testing.CurlRunnings.Internal.KeyValuePairs + +data Payload = JSON Value | URLEncoded KeyValuePairs deriving Generic + +instance Show Payload where + show (JSON v) = show v + show (URLEncoded (KeyValuePairs xs)) = T.unpack $ T.intercalate "&" $ fmap (\(KeyValuePair k v) -> k <> "=" <> v) xs + +payloadTagFieldName :: T.Text +payloadTagFieldName = "bodyType" + +payloadContentsFieldName :: T.Text +payloadContentsFieldName = "content" + +instance FromJSON Payload where + parseJSON v = withObject "payload" parsePayload v where + parsePayload o = if not (H.member payloadTagFieldName o) then return (JSON v) else genericParseJSON payloadOptions v + payloadOptions = defaultOptions { sumEncoding = TaggedObject { tagFieldName = T.unpack payloadTagFieldName + , contentsFieldName = T.unpack payloadContentsFieldName + } + , constructorTagModifier = fmap C.toLower + } + +instance ToJSON Payload where + toJSON (JSON v) = object [(payloadTagFieldName, "json"), (payloadContentsFieldName, toJSON v)] + toJSON (URLEncoded xs) = object [(payloadTagFieldName, "urlencoded"), (payloadContentsFieldName, toJSON xs)] 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,7 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} -- | Data types for curl-runnings tests @@ -11,6 +13,9 @@ , Header(..) , HeaderMatcher(..) , Headers(..) + , KeyValuePair(..) + , KeyValuePairs(..) + , Payload(..) , HttpMethod(..) , JsonMatcher(..) , JsonSubExpr(..) @@ -34,15 +39,17 @@ import Data.Aeson import Data.Aeson.Types -import Data.Either -import qualified Data.HashMap.Strict as H -import Data.List +import qualified Data.Char as C +import qualified Data.HashMap.Strict as H import Data.Maybe import Data.Monoid -import qualified Data.Text as T -import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Vector as V import GHC.Generics import Testing.CurlRunnings.Internal +import Testing.CurlRunnings.Internal.Headers +import Testing.CurlRunnings.Internal.KeyValuePairs +import Testing.CurlRunnings.Internal.Payload import Text.Printf -- | A basic enum for supported HTTP verbs @@ -93,22 +100,6 @@ isNotContains (NotContains _) = True isNotContains _ = False --- | A representation of a single header -data Header = - Header T.Text - T.Text - deriving (Show, Generic) - -instance ToJSON Header - --- | Simple container for a list of headers, useful for a vehicle for defining a --- fromJSON -data Headers = - HeaderSet [Header] - deriving (Show, Generic) - -instance ToJSON Headers - -- | Specify a key, value, or both to match against in the returned headers of a -- response. data PartialHeaderMatcher = @@ -145,33 +136,6 @@ 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 - -parseHeaders :: T.Text -> Either T.Text Headers -parseHeaders str = - let _headers = filter (/= "") $ T.splitOn ";" str - parses = map parseHeader _headers - in case find isLeft parses of - Just (Left failure) -> Left failure - _ -> - Right . HeaderSet $ - map - (fromRight $ - error - "Internal error parsing headers, this is a bug in curl runnings :(") - parses - -instance FromJSON Headers where - parseJSON a@(String v) = - case parseHeaders v of - Right h -> return h - Left failure -> typeMismatch ("Header failure: " ++ T.unpack failure) a - parseJSON invalid = typeMismatch "Header" invalid - instance FromJSON HeaderMatcher where parseJSON o@(String v) = either @@ -232,14 +196,15 @@ -- | A single curl test case, the basic foundation of a curl-runnings test. data CurlCase = CurlCase - { 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 - , expectData :: Maybe JsonMatcher -- ^ The assertions to make on the response payload, if any - , expectStatus :: StatusCodeMatcher -- ^ Assertion about the status code returned by the target - , expectHeaders :: Maybe HeaderMatcher -- ^ Assertions to make about the response headers, if any + { 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 Payload -- ^ Payload to send with the request, if any + , queryParameters :: Maybe KeyValuePairs -- ^ Query parameters to set in the request, if any + , headers :: Maybe Headers -- ^ Headers to send with the request, if any + , expectData :: Maybe JsonMatcher -- ^ The assertions to make on the response payload, if any + , expectStatus :: StatusCodeMatcher -- ^ Assertion about the status code returned by the target + , expectHeaders :: Maybe HeaderMatcher -- ^ Assertions to make about the response headers, if any } deriving (Show, Generic) instance FromJSON CurlCase @@ -344,22 +309,31 @@ printf "JSON query error in spec %s: %s" (name curlCase) (show queryErr) show UnexpectedFailure = "Unexpected Error D:" +formatSecToMS :: Integer -> String +formatSecToMS t = roundToStr ((fromIntegral t :: Double) / 1000.0) + -- | 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] - + = CasePass + { curlCase :: CurlCase + , caseResponseHeaders :: Maybe Headers + , caseResponseValue :: Maybe Value + , elapsedTime :: Integer -- ^ Elapsed time + } + | CaseFail + { curlCase :: CurlCase + , caseResponseHeaders :: Maybe Headers + , caseResponseValue :: Maybe Value + , failures :: [AssertionFailure] + , elapsedTime :: Integer -- ^ Elapsed time + } instance Show CaseResult where - show (CasePass c _ _) = T.unpack . makeGreen $ "[PASS] " <> name c - show (CaseFail c _ _ failures) = + show CasePass{curlCase, elapsedTime} = T.unpack . makeGreen $ "[PASS] " <> (T.pack $ printf "%s (%s seconds)" (name curlCase) (formatSecToMS elapsedTime)) + show CaseFail{curlCase, failures, elapsedTime} = T.unpack $ makeRed "[FAIL] " <> - name c <> + name curlCase <> + (T.pack $ printf " (%s seconds) " (formatSecToMS elapsedTime)) <> "\n" <> mconcat (map ((\s -> "\nAssertion failed: " <> s) . (<> "\n") . (T.pack . show)) failures) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,13 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} module Main where +import Data.Aeson +import Data.ByteString (ByteString) import Data.Either +import Data.List +import qualified Data.Text as T import System.Directory import Test.Hspec import Testing.CurlRunnings import Testing.CurlRunnings.Internal +import Testing.CurlRunnings.Internal.Headers +import Testing.CurlRunnings.Internal.KeyValuePairs import Testing.CurlRunnings.Internal.Parser +import Testing.CurlRunnings.Internal.Payload +import Text.RawString.QQ main :: IO () main = hspec $ @@ -44,6 +54,38 @@ parseQuery "$" `shouldSatisfy` isLeft parseQuery "some text $" `shouldSatisfy` isLeft + it "should parse valid headers" $ do + parseHeaders "key:" `shouldBeHeaders` [("key", "")] + parseHeaders "key: ;" `shouldBeHeaders` [("key", "")] + parseHeaders "key:" `shouldBeHeaders` [("key", "")] + parseHeaders "key: value" `shouldBeHeaders` [("key", "value")] + parseHeaders "key: value;" `shouldBeHeaders` [("key", "value")] + parseHeaders "key : value" `shouldBeHeaders` [("key", "value")] + parseHeaders "key :value" `shouldBeHeaders` [("key", "value")] + parseHeaders "key : value " `shouldBeHeaders` [("key", "value")] + parseHeaders " key : value " `shouldBeHeaders` [("key", "value")] + parseHeaders "key name : value" `shouldBeHeaders` [("key name", "value")] + parseHeaders "key : value name " `shouldBeHeaders` [("key", "value name")] + parseHeaders "key1 : value1:value2;" `shouldBeHeaders` [("key1", "value1:value2")] + parseHeaders "key1 : value1:value2" `shouldBeHeaders` [("key1", "value1:value2")] + parseHeaders "key1 : value1 ; key2: value2" `shouldBeHeaders` [("key1", "value1"), ("key2", "value2")] + parseHeaders "key1 : value1 ;\n key2: value2" `shouldBeHeaders` [("key1", "value1"), ("key2", "value2")] + parseHeaders "key1 : value1 ;\n key2: value2\n" `shouldBeHeaders` [("key1", "value1"), ("key2", "value2")] + parseHeaders "key1 : value1 ;\n key2: value2;" `shouldBeHeaders` [("key1", "value1"), ("key2", "value2")] + parseHeaders "Content-Type : application/json" `shouldBeHeaders` [("Content-Type", "application/json")] + parseHeaders "$: $ ;" `shouldBeHeaders` [("$", "$")] + + it "should reject invalid headers" $ do + parseHeaders "" `shouldSatisfy` isLeft + parseHeaders "\n" `shouldSatisfy` isLeft + parseHeaders "£key: value" `shouldSatisfy` isLeft + parseHeaders "key: £value" `shouldSatisfy` isLeft + parseHeaders "key" `shouldSatisfy` isLeft + parseHeaders "key ;" `shouldSatisfy` isLeft + parseHeaders " : value" `shouldSatisfy` isLeft + parseHeaders " : value ;" `shouldSatisfy` isLeft + parseHeaders " : value ; key : value2" `shouldSatisfy` isLeft + it "arrayGet should handle positive and negative indexes correctly" $ do let a = [1, 2, 3] b = [] :: [Int] @@ -59,10 +101,74 @@ (arrayGet b 1) `shouldBe` Nothing (arrayGet b (-1)) `shouldBe` Nothing + it "should decode valid key-value pairs" $ do + [r|{"key": "value"}|] `shouldBeKeyValuePairs` [("key", "value")] + [r|{"key": 1}|] `shouldBeKeyValuePairs` [("key", "1")] + [r|{"key": 9.999}|] `shouldBeKeyValuePairs` [("key", "9.999")] + [r|{"key": true}|] `shouldBeKeyValuePairs` [("key", "true")] + [r|{"key1": 10, "key2": "a", "key3": 1.1, "key4": false}|] + `shouldBeKeyValuePairs` + [ ("key1", "10") + , ("key2", "a") + , ("key3", "1.1") + , ("key4", "false") + ] + + it "should not decode invalid key-value pairs" $ do + decodeKeyValuePair [r|{"key": null}|] `shouldSatisfy` isLeft + decodeKeyValuePair [r|{"key": [1, "1"]}|] `shouldSatisfy` isLeft + decodeKeyValuePair [r|{"key": {"nestedKey": true}}|] `shouldSatisfy` isLeft + decodeKeyValuePair [r|{"key1": "a", "key2": {"nestedKey": true}}|] `shouldSatisfy` isLeft + + it "should decode request body" $ do + decodePayload [r|{"bodyType": "urlencoded", "content": {"key1": "value1"}}|] `shouldSatisfy` isURLEncoded + decodePayload [r|{"bodyType": "json", "content": {"key1": "value1"}}|] `shouldSatisfy` isJSON + decodePayload [r|{"bodyType": "json", "content": ["key1", "value1"]}|] `shouldSatisfy` isJSON + decodePayload [r|{"content": {"key1": "value1"}}|] `shouldSatisfy` isJSON + decodePayload [r|{"other": {"key1": "value1"}}|] `shouldSatisfy` isJSON + decodePayload [r|{"other": ["key1", "value1"]}|] `shouldSatisfy` isJSON + -- "other" is ignored + decodePayload [r|{"bodyType": "json", "content": {"a": "b"}, "other": 1}|] `shouldSatisfy` isJSON + decodePayload [r|{"bodytype": "urlencoded", "content": ["key1", "value1"]}|] `shouldSatisfy` isJSON + + it "should not decode invalid request body" $ do + decodePayload [r|{"bodyType": "plain", "content": {"key1": "value1"}}|] `shouldSatisfy` isLeft + decodePayload [r|{"bodyType": "urlencoded"}|] `shouldSatisfy` isLeft + decodePayload [r|{"bodyType": "json"}|] `shouldSatisfy` isLeft + decodePayload [r|{"bodyType": "urlencoded", "content": ["key1", "value1"]}|] `shouldSatisfy` isLeft + testValidSpec :: String -> IO () testValidSpec file = do currentDirectory <- getCurrentDirectory spec <- decodeFile (currentDirectory ++ file) spec `shouldSatisfy` isRight +decodeKeyValuePair :: ByteString -> Either String KeyValuePairs +decodeKeyValuePair = eitherDecodeStrict +decodePayload :: ByteString -> Either String Payload +decodePayload = eitherDecodeStrict + +shouldBeHeaders :: (Eq a, Show a) => Either a Headers -> [(T.Text, T.Text)] -> Expectation +shouldBeHeaders actual expected = + let expectedHeaders = Right . HeaderSet $ uncurry Header <$> expected in + actual `shouldBe` expectedHeaders + +shouldBeKeyValuePairs :: ByteString -> [(T.Text, T.Text)] -> Expectation +shouldBeKeyValuePairs json expected = actual `shouldBe` expectedKeyValuePairs where + actual = eitherDecodeStrict json + expectedKeyValuePairs = Right . KeyValuePairs $ uncurry KeyValuePair <$> expected + +deriving instance Eq KeyValuePair + +-- KeyValuePairs should be considered equal if they contain the same elements. +instance Eq KeyValuePairs where + (==) (KeyValuePairs x) (KeyValuePairs y) = null (x \\ y) && null (y \\ x) + +isURLEncoded :: Either String Payload -> Bool +isURLEncoded (Right (URLEncoded _)) = True +isURLEncoded _ = False + +isJSON :: Either String Payload -> Bool +isJSON (Right (JSON _)) = True +isJSON _ = False