diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Rodrigo Setti (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Rodrigo Setti nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,120 @@ +# swagger-test + +This is a tool for +[Property Based Testing](https://en.wikipedia.org/wiki/Property_testing) +of [swagger](https://swagger.io) APIs. + +It basically allow you to approximate the computation of the following +proposition: + +> valid(response, schema), response = execute(request), ∀ request ∈ schema + +Which translates to: + +> For all valid requests that can be derived from my Swagger schema, the +> API response obtained from executing that request is valid according to the +> same Swagger schema. + +The tool exposes several ways to configure get value from parts of it, for +example, you may be interested in getting just a random valid request from the +schema (use the `generate` command), or validating if a given response (from a +particular operation) is valid (use the `validate` command), or, run one sample +instance of the full proposition, which picks a random request and validate it's +resulting response (use the `request` command). + +The generator random request values are reproducible by re-using the same _seed_ +value, or one can focus on a particular operation by specifying the operation +id. + +The tool also simplifies integration with other systems by allowing to configure +output formats as standard HTTP message, JSON, or curl. Additionally, there +are Haskell modules exposed as a library if one wants to build on top of it. + +## Command Line Interface + +*swagger-test* supports three commands: + + * `generate` - generates a new random valid request from Swagger schema. + * `validate` - validate a response to a given operation id, according to the + schema. + * `request` - generate and make the request, then validates the response + (combines generate and validate). + +```console +swagger-test --help +``` + +``` +Testing tool for Swagger APIs + +Usage: swagger-test [-s|--schema FILENAME] COMMAND + Generate Swagger requests and validates responses + +Available options: + -s,--schema FILENAME swagger JSON schema file to read + from (default: "swagger.json") + -h,--help Show this help text + +Available commands: + generate Generate a random request according to Schema + validate Validate a response against Schema + request Generate, make the request, and validate response +``` + +### Sub-commands + +#### Generate + +``` +Usage: swagger-test generate [--seed N] [-o|--operation ID] + [--request-format http|curl|none|json] [-i|--info] + [--size N] + Generate a request + +Available options: + --seed N specify the seed for the random generator + -o,--operation ID specify a operation id to test (default pick + randomly) + --request-format http|curl|none|json + output format of the HTTP request (default: http) + -i,--info render information about seed and operation id + --size N control the size of the generated + request (default: 30) + -h,--help Show this help text +``` + +#### Validate + +``` +Usage: swagger-test validate [FILENAME] (-o|--operation ID) + Validate a response + +Available options: + FILENAME http response file to read from (default=stdin) + -o,--operation ID specify a operation id to test (default pick + randomly) + -h,--help Show this help text +``` + +#### Request + +``` +Usage: swagger-test request [--seed N] [-o|--operation ID] + [--request-format http|curl|none|json] + [--response-format http|json|none] [-i|--info] + [--size N] + Generate, make the request, and validate response + +Available options: + --seed N specify the seed for the random generator + -o,--operation ID specify a operation id to test (default pick + randomly) + --request-format http|curl|none|json + output format of the HTTP request (default: none) + --response-format http|json|none + output format of the HTTP request (default: none) + -i,--info render information about seed and operation id + --size N control the size of the generated + request (default: 30) + -h,--help Show this help text +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Main +Description : Command line application +Copyright : (c) Rodrigo Setti, 2017 +License : BSD3 +Maintainer : rodrigosetti@gmail.com +Stability : experimental +Portability : POSIX +-} +module Main (main) where + +import Control.Lens ((^.)) +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.List (find, intercalate) +import Data.Semigroup ((<>)) +import Data.Swagger hiding (Format, info) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Options.Applicative +import System.Exit (die) +import System.Random +import Test.Swagger + +-- |Program options +data Opts = Opts FilePath -- ^Swagger input file + Command + +data Command = Generate (Maybe Seed) + (Maybe OperationId) + Format -- ^request output format + Bool -- ^output extra header info with seed and/or operation id + Int -- ^size parameter for the generation + | Validate (Maybe FilePath) -- ^read http response from file or stdin + OperationId + | Request (Maybe Seed) + (Maybe OperationId) + Format -- ^request output format + Format -- ^response output format + Bool -- ^output extra header info with seed and/or operation id + Int -- ^size parameter for the generation + +opts :: Parser Opts +opts = Opts <$> strOption ( metavar "FILENAME" + <> long "schema" + <> short 's' + <> help "swagger JSON schema file to read from" + <> value "swagger.json" + <> showDefault) + <*> subparser ( command "generate" (info (generate <**> helper) + (progDesc "Generate a random request according to Schema")) + <> command "validate" (info (validate <**> helper) + (progDesc "Validate a response against Schema")) + <> command "request" (info (request <**> helper) + (progDesc "Generate, make the request, and validate response"))) + where + generate :: Parser Command + generate = Generate <$> seedP + <*> optional operationIdP + <*> option (formatReader requestFormats) + ( metavar (intercalate "|" (map show requestFormats)) + <> help "output format of the HTTP request" + <> long "request-format" + <> value FormatHttp + <> showDefault ) + <*> infoP + <*> sizeP + + seedP = optional (option auto ( metavar "N" + <> help "specify the seed for the random generator" + <> long "seed" )) + + infoP = switch (long "info" + <> short 'i' + <> help "render information about seed and operation id") + + sizeP = option auto ( metavar "N" + <> long "size" + <> help "control the size of the generated request" + <> value 30 + <> showDefault ) + + request :: Parser Command + request = Request <$> seedP + <*> optional operationIdP + <*> option (formatReader requestFormats) + ( metavar (intercalate "|" (map show requestFormats)) + <> help "output format of the HTTP request" + <> long "request-format" + <> value FormatNone + <> showDefault ) + <*> option (formatReader responseFormats) + (metavar (intercalate "|" (map show responseFormats)) + <> help "output format of the HTTP request" + <> long "response-format" + <> value FormatNone + <> showDefault ) + <*> infoP + <*> sizeP + + validate :: Parser Command + validate = Validate <$> optional (strArgument ( metavar "FILENAME" + <> help "http response file to read from (default=stdin)" )) + <*> operationIdP + + operationIdP :: Parser OperationId + operationIdP = T.pack <$> strOption (long "operation" + <> short 'o' + <> metavar "ID" + <> help "specify a operation id to test (default pick randomly)") + + formatReader :: [Format] -> ReadM Format + formatReader valids = maybeReader (\s -> find (\f -> show f == s) valids) + +main :: IO () +main = do Opts swaggerFile cmd <- execParser optsInfo + contents <- LBS.readFile swaggerFile + case eitherDecode contents of + Left e -> die e + Right model -> + case cmd of + Generate mseed mopid reqFmt renderInfo size -> + void $ doGenerate model mseed mopid reqFmt renderInfo size + Validate respFile opId -> + do respContents <- maybe LBS.getContents LBS.readFile respFile + case validateResponseBytes respContents model opId of + Left e -> die $ "invalid: " <> e + Right _ -> putStrLn "valid" + Request mseed mopid reqFmt resFmt renderInfo size -> + do (op, req) <- doGenerate model mseed mopid reqFmt renderInfo size + res <- doHttpRequest req + printResponse resFmt res + case validateResponseWithOperation res model op of + Left e -> die $ "invalid: " <> e + Right _ -> putStrLn "valid" + + where + optsInfo = info (opts <**> helper) + (fullDesc + <> progDesc "Generate Swagger requests and validates responses" + <> header "Testing tool for Swagger APIs") + + doGenerate :: Swagger -> Maybe Seed -> Maybe OperationId -> Format -> Bool -> Int -> IO (Operation, HttpRequest) + doGenerate model mseed mopid reqFmt renderInfo size = + do seed <- maybe randomIO pure mseed + let (op, req) = generateRequest seed size model mopid + when renderInfo $ + TIO.putStrLn $ "# seed=" <> T.pack (show seed) <> maybe "" (\i -> " id=" <> i) (op ^. operationId) + printRequest reqFmt req + pure (op, req) diff --git a/src/Test/Swagger.hs b/src/Test/Swagger.hs new file mode 100644 --- /dev/null +++ b/src/Test/Swagger.hs @@ -0,0 +1,22 @@ +{-| +Module : Test.Swagger +Description : Re-exports +Copyright : (c) Rodrigo Setti, 2017 +License : BSD3 +Maintainer : rodrigosetti@gmail.com +Stability : experimental +Portability : POSIX + +Re-exports +-} +module Test.Swagger ( module Test.Swagger.Gen + , module Test.Swagger.Print + , module Test.Swagger.Request + , module Test.Swagger.Types + , module Test.Swagger.Validate ) where + +import Test.Swagger.Gen +import Test.Swagger.Print +import Test.Swagger.Request +import Test.Swagger.Types +import Test.Swagger.Validate diff --git a/src/Test/Swagger/Gen.hs b/src/Test/Swagger/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Test/Swagger/Gen.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-| +Module : Test.Swagger.Gen +Description : Exposes a function to generate a random request +Copyright : (c) Rodrigo Setti, 2017 +License : BSD3 +Maintainer : rodrigosetti@gmail.com +Stability : experimental +Portability : POSIX + +Exposes 'generateRequest', which creates a random request from a Swagger +schema. +-} +module Test.Swagger.Gen (generateRequest) where + +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Control.Lens hiding (elements) +import Control.Monad +import Data.Aeson +import Data.Binary.Builder +import Data.CaseInsensitive +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashMap.Strict.InsOrd as M +import Data.List (partition) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Scientific +import Data.Swagger +import Data.Swagger.Internal (SwaggerKind (..)) +import qualified Data.Text as T +import qualified Data.Vector as V +import Network.HTTP.Types +import System.FilePath.Posix (joinPath) +import Test.QuickCheck hiding (Fixed) +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random +import Test.Swagger.Types + + +-- |Given a swagger.json schema, produce a Request that complies with the schema. +-- The return type is a random Request (in the IO monad because it's random). +generateRequest :: Seed -> Int -> Swagger -> Maybe OperationId -> (Operation, HttpRequest) +generateRequest seed size model mopid = + let gen = mkQCGen seed + in unGen (requestGenerator model mopid) gen size + +-- Random Request generator +requestGenerator :: Swagger -> Maybe OperationId -> Gen (Operation, HttpRequest) +requestGenerator s' mopid = + do let s = resolveReferences s' + baseP = fromMaybe "/" $ s ^. basePath + mHost = s ^. host + + -- compute all available operations, in a 4-tuple + let availableOps :: [(FilePath, PathItem, Method, Operation)] + availableOps = catMaybes $ mconcat $ + (\i -> let (path, item) = i + in [ (path, item, methodGet,) <$> item ^. get + , (path, item, methodPut,) <$> item ^. put + , (path, item, methodPost,) <$> item ^. post + , (path, item, methodDelete,) <$> item ^. delete + , (path, item, methodOptions,) <$> item ^. options + , (path, item, methodHead,) <$> item ^. head_ + , (path, item, methodPatch,) <$> item ^. patch ]) + <$> M.toList (s ^. paths) + + -- select one operation of the selected path either randomly or lookup by + -- operation id if providede + (path, item, method, operation) <- + case mopid of + Nothing -> elements availableOps + Just opid -> + do let opId2Op = catMaybes + $ (\i -> let (_, _, _, o) = i in (,i) <$> o ^. operationId) + <$> availableOps + found = lookup opid opId2Op + allIds = T.intercalate ", " $ fst <$> opId2Op + maybe (fail $ "undefined operation id: \"" + <> T.unpack opid + <> "\". Available ids: " + <> T.unpack allIds) + pure found + + -- combine parameters common to all operations to parameters + -- specific to the selected operation + let params = catMaybes $ refToMaybe <$> (item ^. parameters) <> (operation ^. parameters) + -- partition between required and non-required parameters + (requiredParams, notRequiredParams) = partition paramIsRequired params + + selectedOptionalParams <- sublistOf notRequiredParams + + -- final list of parameters that must be applied + let finalParams = requiredParams <> selectedOptionalParams + + -- pick params for path + let pathParams = catMaybes (paramSchemaAndAllowEmpty ParamPath <$> finalParams) + path' <- applyPathTemplating pathParams $ T.pack path + + -- pick params for query string + let queryParams = catMaybes $ paramSchemaAndAllowEmpty ParamQuery <$> finalParams + + queryStr <- genQuery queryParams + + -- pick params for header + let headerParams = catMaybes (paramSchemaAndAllowEmpty ParamHeader <$> finalParams) + + randomHeaders <- genQuery headerParams + + -- pick params for form data + let formDataParams = catMaybes $ paramSchemaAndAllowEmpty ParamFormData <$> finalParams + + maybeMimeAndBody <- + if null formDataParams + then do -- pick a param for body + bodySchema <- maybeElements $ catMaybes $ (refToMaybe =<<) . bodySchemaParam <$> finalParams + randomJsonBody <- maybe (pure Nothing) (Just <$>) $ genJSON <$> bodySchema + pure $ (("application/json",) . encode) <$> randomJsonBody + else do formDataQuery <- genQuery formDataParams + pure $ Just ( "application/x-www-form-urlencoded" + , toLazyByteString $ renderQueryText False formDataQuery) + + let randomHeaders' = catMaybes + $ (\h -> (fst h,) <$> snd h) + <$> ((mk . fst &&& snd) <$> randomHeaders) + <> [("Host", (T.pack . (^. name)) <$> mHost)] + <> [("Content-Type", fst <$> maybeMimeAndBody)] + + -- use scheme from operation, if defined, or from global + scheme <- elements $ fromMaybe [Https] (operation ^. schemes <|> s ^. schemes) + pure ( operation + , HttpRequest (buildHost scheme <$> mHost) + method + (T.pack (joinPath [baseP, T.unpack path'])) + queryStr + randomHeaders' + (snd <$> maybeMimeAndBody) ) + + where + buildHost :: Scheme -> Host -> String + buildHost sc h = schemeToHttpPrefix sc <> (h ^. name) <> maybe "" ((':':) . show) (h ^. port) + + schemeToHttpPrefix Http = "http://" + schemeToHttpPrefix Https = "https://" + schemeToHttpPrefix Ws = "ws://" + schemeToHttpPrefix Wss = "wss://" + + bodySchemaParam :: Param -> Maybe (Referenced Schema) + bodySchemaParam Param { _paramSchema = ParamBody r} = Just r + bodySchemaParam _ = Nothing + + applyPathTemplating :: [(T.Text, ParamSchema k, Bool)] -> T.Text -> Gen T.Text + applyPathTemplating [] p = pure p + applyPathTemplating ((key, sc, ae):ts) p = + do let f = sc ^. format + v <- (mconcat . jsonToText f CollectionSSV) <$> paramGen sc ae + applyPathTemplating ts $ T.replace ("{" <> key <> "}") v p + + genQuery :: [(T.Text, ParamSchema k, Bool)] -> Gen QueryText + genQuery [] = pure [] + genQuery ((key, sc, ae):ts) = + do let f = sc ^. format + v <- jsonToText f CollectionCSV <$> paramGen sc ae + let this = (\x -> (key, if T.null x then Nothing else Just x)) <$> v + rest <- genQuery ts + pure $ this <> rest + + paramSchemaAndAllowEmpty :: ParamLocation -> Param -> Maybe (T.Text, ParamSchema 'SwaggerKindParamOtherSchema, Bool) + paramSchemaAndAllowEmpty loc Param { _paramName = n, _paramSchema = ParamOther pos@ParamOtherSchema {} } + | loc == pos ^. in_ = Just ( n + , pos ^. paramSchema + , (loc == ParamQuery || loc == ParamFormData) + && fromMaybe False (pos ^. allowEmptyValue)) + | otherwise = Nothing + paramSchemaAndAllowEmpty _ Param { _paramSchema = ParamBody _ } = Nothing + +-- |Useful combinator for (Gen a) family: chose one of the values or +-- Nothing if the list is empty. (i.e. safe "elements") +maybeElements :: [a] -> Gen (Maybe a) +maybeElements [] = pure Nothing +maybeElements xs = (Just . (xs !!)) <$> choose (0, length xs - 1) + +paramIsRequired :: Param -> Bool +paramIsRequired Param { _paramSchema = ParamOther ParamOtherSchema { _paramOtherSchemaIn = ParamPath}} = True +paramIsRequired p = fromMaybe False $ p ^. required + +-- |Generator for a parameter, which is used on the "path", "query", "form", or +-- "header". +-- TODO: respect "pattern" generation +paramGen :: ParamSchema a -> Bool -> Gen Value +paramGen ParamSchema { _paramSchemaEnum=Just values} allowEmpty = elements $ values <> [Null | allowEmpty] +paramGen ParamSchema { _paramSchemaType=SwaggerString } allowEmpty = genJString allowEmpty + +-- TODO: respect "multiple of" number generation +paramGen ps@ParamSchema { _paramSchemaType=SwaggerNumber } allowEmpty = + do let n :: Gen Double + min_ = fromMaybe (-1/0) $ toRealFloat <$> ps ^. minimum_ + max_ = fromMaybe (1/0) $ toRealFloat <$> ps ^. maximum_ + n = choose (min_, max_) + frequency $ [(10, Number . fromFloatDigits <$> n)] <> [(1, pure Null) | allowEmpty] +paramGen ps@ParamSchema { _paramSchemaType=SwaggerInteger } allowEmpty = + do let n :: Gen Int + min_ = fromMaybe (-1000) $ toBoundedInteger =<< ps ^. minimum_ + max_ = fromMaybe 1000 $ toBoundedInteger =<< ps ^. maximum_ + n = choose ( min_ + if fromMaybe False $ ps ^. exclusiveMinimum then 1 else 0 + , max_ - if fromMaybe False $ ps ^. exclusiveMaximum then 1 else 0) + frequency $ [(10, Number . fromInteger . toInteger <$> n)] <> [(1, pure Null) | allowEmpty] +paramGen ParamSchema { _paramSchemaType=SwaggerBoolean } allowEmpty = + elements $ [Bool True, Bool False] <> [Null | allowEmpty] + +-- TODO: respect generation of "unique items" +paramGen ps@ParamSchema { _paramSchemaType=SwaggerArray, _paramSchemaFormat=fmt } allowEmpty = + do siz <- toInteger <$> getSize + len <- fromIntegral <$> choose ( fromMaybe (if allowEmpty then 0 else 1) $ ps ^. minLength + , fromMaybe siz $ ps ^. maxLength) + case ps ^. items of + Just (SwaggerItemsObject (Inline s)) -> + toJSON <$> replicateM len (genJSON s) + Just (SwaggerItemsArray rs) -> + toJSON <$> mapM genJSON (catMaybes (refToMaybe <$> rs)) + Just (SwaggerItemsPrimitive cfmt ps') -> + do x <- toJSON <$> replicateM len (paramGen ps' allowEmpty) + pure $ maybe x (toJSON . flip (jsonToText fmt) x) cfmt + _ -> + toJSON <$> replicateM len (genJString allowEmpty) + +-- NOTE: we don't really support files +paramGen ParamSchema { _paramSchemaType=SwaggerFile } allowEmpty = genJString allowEmpty +paramGen ParamSchema { _paramSchemaType=SwaggerNull } _ = pure Null + +-- TODO: what to do here? +paramGen ParamSchema { _paramSchemaType=SwaggerObject } _ = undefined + +jsonToText :: Maybe Format -> CollectionFormat t -> Value -> [T.Text] +jsonToText _ _ (String t) = [t] +jsonToText _ _ Null = [] +jsonToText _ _ (Bool True) = ["true"] +jsonToText _ _ (Bool False) = ["false"] +jsonToText f _ (Number n) = [T.pack $ display n] + where + display = case f of + Just "double" -> formatScientific Fixed Nothing + Just "float" -> formatScientific Fixed Nothing + _ -> formatScientific Fixed (Just 0) + +jsonToText fmt cfmt (Object m) = + let txts = concatMap (\i -> (\x -> fst i <> "=" <> x) <$> jsonToText fmt cfmt (snd i)) $ HM.toList m + in case cfmt of + CollectionCSV -> [T.intercalate "," txts] + CollectionSSV -> [T.intercalate " " txts] + CollectionTSV -> [T.intercalate "\t" txts] + CollectionPipes -> [T.intercalate "|" txts] + CollectionMulti -> txts +jsonToText fmt cfmt (Array v) = + let txts = concatMap (jsonToText fmt cfmt) $ V.toList v + in case cfmt of + CollectionCSV -> [T.intercalate "," txts] + CollectionSSV -> [T.intercalate " " txts] + CollectionTSV -> [T.intercalate "\t" txts] + CollectionPipes -> [T.intercalate "|" txts] + CollectionMulti -> txts + +-- |Merge two Json values, if possible +merge :: Value -> Value -> Value +merge Null v = v +merge v Null = v +merge (Array v1) (Array v2) = Array $ v1 <> v2 +merge (Object v1) (Object v2) = Object $ v1 <> v2 +merge v _ = v + +-- |Generate a JSON from a schema +genJSON :: Schema -> Gen Value +genJSON Schema { _schemaAllOf = Just ss } | not (null ss) = + do jsons <- shuffle =<< mapM genJSON ss + n <- choose (1, length jsons) + pure $ foldl1 merge $ take n jsons + +genJSON s@Schema { _schemaParamSchema = ParamSchema { _paramSchemaType = SwaggerObject } } = + do let props = catMaybes $ (\i -> (fst i,) <$> refToMaybe (snd i)) <$> M.toList (s ^. properties) + (reqProps, optProps) = partition (\i -> fst i `elem` s ^. required) props + siz <- toInteger <$> getSize + nProps <- fromIntegral <$> choose ( fromMaybe 0 $ s ^. minProperties + , fromMaybe siz $ s ^. maxProperties) + nOptProps <- choose (0, nProps) + decidedOptProps <- take nOptProps <$> shuffle optProps + + reqPropsV <- mapM (\i -> (fst i,) <$> genJSON (snd i)) reqProps + optPropsV <- mapM (\i -> (fst i,) <$> genJSON (snd i)) decidedOptProps + addPropsV <- case s ^. additionalProperties of + Just (Inline s') -> replicateM (nProps - (nOptProps + length reqProps)) $ + do k <- genNonemptyText + (k,) <$> genJSON s' + _ -> pure [] + + pure $ Object $ HM.fromList $ reqPropsV <> optPropsV <> addPropsV + +genJSON Schema { _schemaParamSchema = ps } = paramGen ps True + +genNonemptyText :: Gen T.Text +genNonemptyText = genText False + +genText :: Bool -> Gen T.Text +genText allowEmpty = + do c <- arbitraryASCIIChar + s <- getASCIIString <$> arbitrary + pure $ T.pack $ [c | not allowEmpty] <> s + +genJString :: Bool -> Gen Value +genJString allowEmpty = toJSON <$> genText allowEmpty diff --git a/src/Test/Swagger/Print.hs b/src/Test/Swagger/Print.hs new file mode 100644 --- /dev/null +++ b/src/Test/Swagger/Print.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.Swagger.Print (Format(..) + , requestFormats + , responseFormats + , printRequest + , printResponse) where + +import Control.Monad +import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Data.Text.IO as TIO +import Network.HTTP.Types +import Test.Swagger.Types + +-- |Possible output formats that applies to 'HttpRequest' and 'HttpResponse' +-- values +data Format = FormatHttp | FormatCurl | FormatNone | FormatJSON + deriving (Bounded, Enum) + +instance Show Format where + show FormatHttp = "http" + show FormatCurl = "curl" + show FormatNone = "none" + show FormatJSON = "json" + +requestFormats, responseFormats :: [Format] + +-- |Valid output formats for 'HttpRequest' values +requestFormats = [minBound..] + +-- |Valid output formats for 'HttpResponse' values +responseFormats = [FormatHttp, FormatJSON, FormatNone] + +-- |Print a request according to format +printRequest :: Format -> HttpRequest -> IO () +printRequest FormatJSON r = TIO.putStrLn $ decodeUtf8 $ LBS.toStrict $ encode r +printRequest FormatNone _ = pure () +printRequest FormatHttp (HttpRequest _ method path query headers body) = + do BS.putStr method + putStr " " + TIO.putStr path + TIO.putStr $ decodeUtf8 $ renderQuery True $ queryTextToQuery query + putStrLn " HTTP/1.1" + forM_ headers $ \(k,v) -> TIO.putStr (original k) >> putStr ": " >> TIO.putStrLn v + case body of + Just b -> putStr "\n" >> TIO.putStrLn (decodeUtf8 $ LBS.toStrict b) + Nothing -> pure () +printRequest FormatCurl (HttpRequest host method path query headers body) = + do putStr "curl -i" + when (method /= methodGet) + $ BS.putStr $ " -X " <> method + putStr " '" + let host' = fromMaybe "http://localhost" host + TIO.putStr $ escapeS host' + TIO.putStr $ escape path + TIO.putStr $ escapeBS $ renderQuery True $ queryTextToQuery query + putChar '\'' + forM_ headers $ \(k,v) -> TIO.putStr (" -H '" <> escape (original k)) >> putStr ": " >> TIO.putStr (escape v <> "'") + case body of + Just b -> TIO.putStrLn $ " -d '" <> escapeLBS b <> "'" + Nothing -> putChar '\n' + where + escapeLBS :: LBS.ByteString -> T.Text + escapeLBS = escapeBS . LBS.toStrict + + escapeBS :: BS.ByteString -> T.Text + escapeBS = escape . decodeUtf8 + + escape :: T.Text -> T.Text + escape = T.replace "'" "'\\''" + + escapeS :: String -> T.Text + escapeS = escape . T.pack + +-- |Print a response according to format +printResponse :: Format -> HttpResponse -> IO () +printResponse FormatCurl _ = error "unsupported format" +printResponse FormatJSON r = TIO.putStrLn $ decodeUtf8 $ LBS.toStrict $ encode r +printResponse FormatNone _ = pure () +printResponse FormatHttp r = + do let ver = responseHttpVersion r + st = responseStatus r + headers = responseHeaders r + putStr $ "HTTP/" <> show (httpMajor ver) <> "." <> show (httpMinor ver) <> " " + putStr $ show (statusCode st) <> " " + TIO.putStrLn $ decodeUtf8 $ statusMessage st + forM_ headers $ \(k,v) -> TIO.putStr (original k) >> putStr ": " >> TIO.putStrLn v + case responseBody r of + Just b -> putStr "\n" >> TIO.putStrLn (decodeUtf8 $ LBS.toStrict b) + Nothing -> pure () diff --git a/src/Test/Swagger/Request.hs b/src/Test/Swagger/Request.hs new file mode 100644 --- /dev/null +++ b/src/Test/Swagger/Request.hs @@ -0,0 +1,50 @@ +{-| +Module : Test.Swagger.Request +Description : Exposes a function to perform the HTTP request +Copyright : (c) Rodrigo Setti, 2017 +License : BSD3 +Maintainer : rodrigosetti@gmail.com +Stability : experimental +Portability : POSIX + +Exposes 'doHttpRequest', which executes the HTTP request and return the +response. +-} +module Test.Swagger.Request (doHttpRequest) where + +import Control.Arrow +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import Data.Text.Encoding +import Network.HTTP.Client +import Network.HTTP.Types +import Network.HTTP.Client.TLS +import Test.Swagger.Types hiding (requestBody, requestHeaders, + responseBody, responseHeaders, + responseStatus) + +-- |Executes the HTTP request and returns the HTTP response +doHttpRequest :: HttpRequest -> IO HttpResponse +doHttpRequest req = do manager <- getGlobalManager + res <- httpLbs (transformReq req) manager + pure $ transformRes res + +transformReq :: HttpRequest -> Request +transformReq (HttpRequest h m p query headers body) = + (parseRequest_ url) { method=m, requestHeaders=headers', requestBody=RequestBodyLBS body' } + where + url = host' <> T.unpack (p <> decodeUtf8 (renderQuery True $ queryTextToQuery query)) + host' = fromMaybe "http://localhost" h + headers' = (mk . encodeUtf8 . original *** encodeUtf8) <$> headers + body' = fromMaybe mempty body + +transformRes :: Response LBS.ByteString -> HttpResponse +transformRes r = HttpResponse (responseVersion r) + (responseStatus r) + headers' + (Just $ responseBody r) + where + headers' = (mk . decodeUtf8 . original *** decodeUtf8) <$> responseHeaders r diff --git a/src/Test/Swagger/Types.hs b/src/Test/Swagger/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Swagger/Types.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Test.Swagger.Types +Description : Types used for other swagger-test modules +Copyright : (c) Rodrigo Setti, 2017 +License : BSD3 +Maintainer : rodrigosetti@gmail.com +Stability : experimental +Portability : POSIX + +This module exposes some types that ure used across other modules +of swagger-test. +-} +module Test.Swagger.Types (FullyQualifiedHost + , Seed + , OperationId + , HttpHeader + , Headers + , HttpRequest(..) + , HttpResponse(..) + , resolveReferences + , refToMaybe) where + +import Control.Arrow +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive +import qualified Data.HashMap.Lazy as HM +import qualified Data.Text as T +import Data.Text.Encoding +import Network.HTTP.Types +import Control.Lens ((^.)) +import Data.Generics +import qualified Data.HashMap.Strict.InsOrd as M +import Data.Monoid ((<>)) +import Data.Swagger + +-- |The FullyQualifiedHost contains the scheme (i.e. http://), hostname and port. +type FullyQualifiedHost = String + +type Seed = Int +type OperationId = T.Text + +type HttpHeader = (CI T.Text, T.Text) +type Headers = [HttpHeader] + +data HttpRequest = HttpRequest { requestHost :: Maybe FullyQualifiedHost + , requestMethod :: Method + , requestPath :: T.Text + , requestQuery :: QueryText + , requestHeaders :: Headers + , requestBody :: Maybe LBS.ByteString } + deriving (Show) + +instance ToJSON HttpRequest where + toJSON r = object [ "host" .= toJSON (requestHost r) + , "method" .= toJSON (decodeUtf8 $ requestMethod r) + , "path" .= toJSON (requestPath r) + , "query" .= toJSON (requestQuery r) + , "headers" .= toJSON headersMap + , "body" .= toJSON (decodeUtf8 . LBS.toStrict <$> requestBody r) ] + where + headersMap = HM.fromList $ first original <$> requestHeaders r + +data HttpResponse = HttpResponse { responseHttpVersion :: HttpVersion + , responseStatus :: Status + , responseHeaders :: Headers + , responseBody :: Maybe LBS.ByteString } + deriving (Show) + +instance ToJSON HttpResponse where + toJSON r = object [ "version" .= object [ "major" .= toJSON (httpMajor ver) + , "minor" .= toJSON (httpMinor ver)] + , "status" .= object [ "code" .= toJSON (statusCode st) + , "message" .= toJSON (decodeUtf8 $ statusMessage st) ] + , "headers" .= toJSON headersMap + , "body" .= toJSON (decodeUtf8 . LBS.toStrict <$> responseBody r) ] + where + ver = responseHttpVersion r + st = responseStatus r + headersMap = M.fromList $ first original <$> responseHeaders r + + +-- |Replace all references with inlines +resolveReferences :: Swagger -> Swagger +resolveReferences s = everywhere' (mkT resolveSchema) $ everywhere' (mkT resolveParam) s + -- NOTE: we need to use the top-down everywhere variant for this to work as intented + where + resolveParam :: Referenced Param -> Referenced Param + resolveParam i@Inline {} = i + resolveParam (Ref (Reference r)) = maybe (error $ "undefied schema: " <> T.unpack r) Inline + $ M.lookup r $ s ^. parameters + resolveSchema :: Referenced Schema -> Referenced Schema + resolveSchema i@Inline {} = i + resolveSchema (Ref (Reference r)) = maybe (error $ "undefied schema: " <> T.unpack r) Inline + $ M.lookup r $ s ^. definitions + +-- |Transform a reference into a Just value if is inline, Nothing, otherwise +refToMaybe :: Referenced a -> Maybe a +refToMaybe (Inline i) = Just i +refToMaybe (Ref _) = Nothing diff --git a/src/Test/Swagger/Validate.hs b/src/Test/Swagger/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Test/Swagger/Validate.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Test.Swagger.Validate +Description : Exposes functions to validate responses +Copyright : (c) Rodrigo Setti, 2017 +License : BSD3 +Maintainer : rodrigosetti@gmail.com +Stability : experimental +Portability : POSIX + +Exposes some functions to validate responses against a Swagger schema. +There are four functions that can be used depending whether the response +is parsed, if the operation is available (or just the id) +-} +module Test.Swagger.Validate ( parseResponse + , validateResponseBytes + , validateResponseWithOperation + , validateResponse ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Aeson hiding (Result) +import Data.Attoparsec.ByteString hiding (Result, + eitherResult, parse) +import qualified Data.Attoparsec.ByteString.Char8 as AC +import Data.Attoparsec.ByteString.Lazy hiding (Result) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive +import Data.Char (digitToInt) +import Data.Generics +import qualified Data.HashMap.Strict.InsOrd as M +import Data.List +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Swagger +import Data.Swagger.Internal.Schema.Validation +import qualified Data.Text as T +import Data.Text.Encoding +import Network.HTTP.Media +import Network.HTTP.Types +import Test.Swagger.Types + +-- |Validate a response, from a particular operation id, (encoded in a byte-string) +-- against a Swagger schema +validateResponseBytes :: LBS.ByteString -> Swagger -> OperationId -> Either String () +validateResponseBytes input s opId = + case parseResponse input of + Left e -> Left $ "could not parse HTTP response: " <> e + Right response -> validateResponse response s opId + +-- |Validate a response, from a particular operation id against a Swagger schema +validateResponse:: HttpResponse -> Swagger -> OperationId -> Either String () +validateResponse res s opid = + case maybeOp of + Nothing -> Left $ "operation not defined: " <> T.unpack opid + Just operation -> validateResponseWithOperation res s operation + where + maybeOp = listToMaybe $ listify operationMatches s + + operationMatches :: Operation -> Bool + operationMatches o = Just opid == o ^. operationId + +-- |Validate a response, from a particular operation against a Swagger schema +validateResponseWithOperation :: HttpResponse -> Swagger -> Operation -> Either String () +validateResponseWithOperation res s' operation = + do let code = statusCode $ responseStatus res + msr = M.lookup code (operation ^. responses.responses) + <|> operation ^. responses.default_ + + sr <- maybe (fail $ "unspecified status code: " <> show code) pure (msr >>= refToMaybe) + + -- validate headers + forM_ (M.toList $ sr ^. headers) $ uncurry $ \k h -> + do hv <- maybe (fail $ "expected header: " <> T.unpack k) pure + $ lookup (mk k) $ responseHeaders res + validateWithParamSchema' (toJSON hv) $ h ^. paramSchema + + + -- validate body + case (sr ^. schema >>= refToMaybe, responseBody res) of + (Nothing, Nothing) -> pure () -- no response expected, got no response (OK) + (Just _, Nothing) -> fail $ "expected response body: " <> T.unpack (sr ^. description) + (Nothing, Just _) -> fail "unexpected response body" + (Just rs, Just bs) -> + do jsonMime <- maybe (fail "unexpected!") pure $ parseAccept "application/json" + + -- TODO: should default be JSON? + let respMime = fromMaybe jsonMime + (lookup (mk "Content-Type") (responseHeaders res) >>= (parseAccept . encodeUtf8)) + + -- all possible content-types the operation can produce + let mimes = fromMaybe (s ^. produces) $ operation ^. produces + + -- find one mime that matches + matchedMime <- maybe (fail "unexpected content-type") pure + $ find (matches respMime) (getMimeList mimes) + + -- If JSON, validate + -- TODO: validate other non-JSON content-types + when (matches matchedMime jsonMime) $ + do b <- eitherDecode bs + validateWithSchema' b rs + + where + s = resolveReferences s' + + -- TODO: make it support patterns + cfg = defaultConfig + + validateWithSchema' :: Value -> Schema -> Either String () + validateWithSchema' v = resultToEither . runValidation (validateWithSchema v) cfg + + validateWithParamSchema' :: Value -> ParamSchema t -> Either String () + validateWithParamSchema' v = resultToEither . runValidation (validateWithParamSchema v) cfg + + resultToEither :: Result a -> Either String a + resultToEither (Failed es) = Left $ intercalate ", " es + resultToEither (Passed a) = Right a + +-- |Parse a HttpResponse from ByteString +parseResponse :: LBS.ByteString -> Either String HttpResponse +parseResponse = eitherResult . parse responseParser + +responseParser :: Parser HttpResponse +responseParser = do ver <- versionParser "http version" + skipHorizontalSpace1 + status <- statusParser "http status" + void endOfLine + hs <- headerParser `sepBy` endOfLine + body <- try (endOfLine >> endOfLine >> (Just <$> bodyParser)) <|> pure Nothing + endOfInput + pure $ HttpResponse ver status hs body + where + endOfLine = string "\r\n" <|> string "\n" + + versionParser :: Parser HttpVersion + versionParser = choice [ string "HTTP/0.9" >> pure http09 + , string "HTTP/1.0" >> pure http10 + , string "HTTP/1.1" >> pure http11 ] + + statusParser :: Parser Status + statusParser = Status <$> (statusCodeParser <* skipHorizontalSpace1) + <*> takeTill (inClass "\r\n") + + skipHorizontalSpace1 = skipMany1 (skip $ inClass " \t") + skipHorizontalSpace = skipMany (skip $ inClass " \t") + + headerParser :: Parser HttpHeader + headerParser = do key <- BS.pack <$> many1 (satisfy $ notInClass " \t:") + skipHorizontalSpace >> string ":" >> skipHorizontalSpace + val <- BS.pack <$> many1 (satisfy $ notInClass "\r\n") + pure (mk $ decodeUtf8 key, decodeUtf8 val) + + bodyParser :: Parser LBS.ByteString + bodyParser = takeLazyByteString + + statusCodeParser :: Parser Int + statusCodeParser = do a <- digitToInt <$> AC.digit + b <- digitToInt <$> AC.digit + c <- digitToInt <$> AC.digit + pure $ fromIntegral $ a*100 + b*10 + c diff --git a/swagger-test.cabal b/swagger-test.cabal new file mode 100644 --- /dev/null +++ b/swagger-test.cabal @@ -0,0 +1,69 @@ +name: swagger-test +version: 0.1.0 +synopsis: Testing of Swagger APIs +description: This package provides a library and executable tool + that supports testing APIs specified with Swagger. It + allows one to generate arbitrary Swagger requests for any + given specification. +homepage: https://github.com/rodrigosetti/swagger-test +bug-reports: https://github.com/rodrigosetti/swagger-test/issues +license: BSD3 +license-file: LICENSE +author: Rodrigo Setti +maintainer: rodrigosetti@gmail.com +copyright: 2017 Rodrigo Setti. All rights reserved +category: Testing +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +stability: alpha + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Test.Swagger + , Test.Swagger.Gen + , Test.Swagger.Print + , Test.Swagger.Request + , Test.Swagger.Types + , Test.Swagger.Validate + build-depends: base >= 4.7 && < 5 + , QuickCheck == 2.10.* + , aeson + , attoparsec + , binary + , bytestring + , case-insensitive + , filepath + , http-client + , http-client-tls + , http-media + , http-types + , insert-ordered-containers + , lens + , scientific + , swagger2 + , syb + , text + , unordered-containers + , vector + +executable swagger-test + hs-source-dirs: app + main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , bytestring + , swagger-test + , lens + , text + , optparse-applicative + , swagger2 + , aeson + , random + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/rodrigosetti/swagger-test