diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -39,39 +39,50 @@ schema. * `request` - generate and make the request, then validates the response (combines generate and validate). + * `report` - high-level command that run several requests concurrently, and + write HTML reports for multiple Swagger schemas. Useful for testing systems + with many Swagger services in a CI server. ```console swagger-test --help ``` ``` -Testing tool for Swagger APIs +Property-based testing tool for Swagger APIs -Usage: swagger-test [-s|--schema FILENAME] COMMAND - Generate Swagger requests and validates responses +Usage: swagger-test COMMAND + Execute one of the commands available depending on your needs 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 + report Run several tests and generate reports + +Run `COMMAND --help` to get command specific options help ``` ### Sub-commands #### Generate +```console +swagger-test generate --help ``` -Usage: swagger-test generate [--seed N] [-o|--operation ID] - [--request-format http|curl|none|json] [-i|--info] - [--size N] - Generate a request +``` +Usage: swagger-test generate [-s|--schema FILENAME] [--seed N] + [-o|--operation ID] + [--request-format http|curl|none|json] + [-i|--info] [--size N] + Generate a random request according to Schema + Available options: + -s,--schema FILENAME swagger JSON schema file to read + from (default: "swagger.json") --seed N specify the seed for the random generator -o,--operation ID specify a operation id to test (default pick randomly) @@ -85,11 +96,18 @@ #### Validate +```console +swagger-test validate --help ``` -Usage: swagger-test validate [FILENAME] (-o|--operation ID) - Validate a response +``` +Usage: swagger-test validate [-s|--schema FILENAME] [FILENAME] + (-o|--operation ID) + Validate a response against Schema + Available options: + -s,--schema FILENAME swagger JSON schema file to read + from (default: "swagger.json") FILENAME http response file to read from (default=stdin) -o,--operation ID specify a operation id to test (default pick randomly) @@ -98,14 +116,21 @@ #### Request +```console +swagger-test request --help ``` -Usage: swagger-test request [--seed N] [-o|--operation ID] + +``` +Usage: swagger-test request [-s|--schema FILENAME] [--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: + -s,--schema FILENAME swagger JSON schema file to read + from (default: "swagger.json") --seed N specify the seed for the random generator -o,--operation ID specify a operation id to test (default pick randomly) @@ -114,6 +139,28 @@ --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 +``` + +#### Report + +```console +swagger-test report --help +``` + +``` +Usage: swagger-test report [--schemas PATH] [--reports PATH] [--tests N] + [--size N] + Run several tests and generate reports + +Available options: + --schemas PATH path to folder with swagger + schemas (default: "schemas") + --reports PATH path to folder to write the HTML + reports (default: "reports") + --tests N number of tests to run (default: 100) --size N control the size of the generated request (default: 30) -h,--help Show this help text diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -10,54 +10,62 @@ -} module Main (main) where -import Control.Lens ((^.)) +import Control.Concurrent.Async +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 qualified Data.ByteString.Lazy as LBS +import Data.List +import Data.Semigroup ((<>)) +import Data.Swagger hiding (Format, info) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Text.Lazy.Builder +import qualified Data.Text.Lazy.IO as LTIO import Options.Applicative -import System.Exit (die) +import System.Directory +import System.Exit (die) +import System.FilePath.Posix import System.Random import Test.Swagger -- |Program options -data Opts = Opts FilePath -- ^Swagger input file - Command +newtype Opts = Opts Command -data Command = Generate (Maybe Seed) +data Command = Generate FilePath -- ^Swagger input file + (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 + Size -- ^size parameter for the generation + | Validate FilePath -- ^Swagger input file + (Maybe FilePath) -- ^read http response from file or stdin OperationId - | Request (Maybe Seed) + | Request FilePath -- ^Swagger input file + (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 + Size -- ^size parameter for the generation + | Report FilePath -- ^where to read the schemas + FilePath -- ^where to write the reports + Int -- ^number of tests to run + Size -- ^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) +opts = Opts <$> 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"))) + (progDesc "Generate, make the request, and validate response")) + <> command "report" (info (report <**> helper) + (progDesc "Run several tests and generate reports"))) where generate :: Parser Command - generate = Generate <$> seedP + generate = Generate <$> schemaFileP + <*> seedP <*> optional operationIdP <*> option (formatReader requestFormats) ( metavar (intercalate "|" (map show requestFormats)) @@ -68,6 +76,13 @@ <*> infoP <*> sizeP + schemaFileP = strOption ( metavar "FILENAME" + <> long "schema" + <> short 's' + <> help "swagger JSON schema file to read from" + <> value "swagger.json" + <> showDefault) + seedP = optional (option auto ( metavar "N" <> help "specify the seed for the random generator" <> long "seed" )) @@ -82,29 +97,49 @@ <> 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" + validate = Validate <$> schemaFileP + <*> optional (strArgument ( metavar "FILENAME" <> help "http response file to read from (default=stdin)" )) <*> operationIdP + request :: Parser Command + request = Request <$> schemaFileP + <*> 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 + + report :: Parser Command + report = Report <$> strOption ( metavar "PATH" + <> long "schemas" + <> help "path to folder with swagger schemas" + <> value "schemas" + <> showDefault) + <*> strOption ( metavar "PATH" + <> long "reports" + <> help "path to folder to write the HTML reports" + <> value "reports" + <> showDefault) + <*> option auto ( metavar "N" + <> long "tests" + <> help "number of tests to run" + <> value 100 + <> showDefault ) + <*> sizeP + operationIdP :: Parser OperationId operationIdP = T.pack <$> strOption (long "operation" <> short 'o' @@ -115,38 +150,65 @@ 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" - +main = do Opts cmd <- customExecParser + (prefs $ disambiguate <> showHelpOnError <> showHelpOnEmpty) + optsInfo + case cmd of + Generate swaggerFile mseed mopid reqFmt renderInfo size -> + do model <- readSwagger swaggerFile + void $ doGenerate model mseed mopid reqFmt renderInfo size + Validate swaggerFile respFile opId -> + do model <- readSwagger swaggerFile + respContents <- maybe LBS.getContents LBS.readFile respFile + case validateResponseBytes respContents model opId of + Left e -> die $ "invalid: " <> e + Right _ -> putStrLn "valid" + Request swaggerFile mseed mopid reqFmt resFmt renderInfo size -> + do model <- readSwagger swaggerFile + (op, req) <- doGenerate model mseed mopid reqFmt renderInfo size + res <- doHttpRequest req + LTIO.putStrLn $ toLazyText $ printResponse resFmt res + case validateResponseWithOperation res model op of + Left e -> die $ "invalid: " <> e + Right _ -> putStrLn "valid" + Report schemasFolder reportFolder nTests size -> + do createDirectoryIfMissing True reportFolder + schemaFiles <- listDirectory schemasFolder + forConcurrently_ schemaFiles $ \schemaFile -> + when (takeExtension schemaFile == ".json") $ do + let schemaFilePath = schemasFolder schemaFile + reportFile = reportFolder schemaFile -<.> "html" + emodel <- eitherDecode <$> LBS.readFile schemaFilePath + case emodel of + Left e -> writeErrorReportFile reportFile $ + "Could not parse " <> schemaFile <> ": " <> e + Right model -> + do reports <- runTests model nTests size + writeReportFile reportFile model reports where + readSwagger :: FilePath -> IO NormalizedSwagger + readSwagger swaggerFile= do contents <- LBS.readFile swaggerFile + case eitherDecode contents of + Left e -> die e >> undefined + Right m -> pure m + optsInfo = info (opts <**> helper) - (fullDesc - <> progDesc "Generate Swagger requests and validates responses" - <> header "Testing tool for Swagger APIs") + ( fullDesc + <> progDesc "Execute one of the commands available depending on your needs" + <> header "Property-based testing tool for Swagger APIs" + <> footer "Run `COMMAND --help` to get command specific options help") - doGenerate :: Swagger -> Maybe Seed -> Maybe OperationId -> Format -> Bool -> Int -> IO (Operation, HttpRequest) + doGenerate :: NormalizedSwagger + -> Maybe Seed + -> Maybe OperationId + -> Format + -> Bool + -> Size + -> IO (Operation, HttpRequest) doGenerate model mseed mopid reqFmt renderInfo size = - do seed <- maybe randomIO pure mseed + do seed <- maybe (abs <$> 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 + LTIO.putStrLn $ toLazyText $ printRequest reqFmt req pure (op, req) diff --git a/src/Test/Swagger.hs b/src/Test/Swagger.hs --- a/src/Test/Swagger.hs +++ b/src/Test/Swagger.hs @@ -13,10 +13,12 @@ , module Test.Swagger.Print , module Test.Swagger.Request , module Test.Swagger.Types + , module Test.Swagger.Report , module Test.Swagger.Validate ) where import Test.Swagger.Gen import Test.Swagger.Print +import Test.Swagger.Report 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 --- a/src/Test/Swagger/Gen.hs +++ b/src/Test/Swagger/Gen.hs @@ -32,9 +32,10 @@ import Data.Swagger import Data.Swagger.Internal (SwaggerKind (..)) import qualified Data.Text as T +import Data.Text.Encoding import qualified Data.Vector as V import Network.HTTP.Types -import System.FilePath.Posix (joinPath) +import System.FilePath.Posix (()) import Test.QuickCheck hiding (Fixed) import Test.QuickCheck.Gen (unGen) import Test.QuickCheck.Random @@ -43,29 +44,29 @@ -- |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 -> NormalizedSwagger -> 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' +requestGenerator :: NormalizedSwagger -> Maybe OperationId -> Gen (Operation, HttpRequest) +requestGenerator ns mopid = + do let s = getSwagger ns 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 ]) + (\(path, item) -> + [ (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 @@ -134,7 +135,7 @@ pure ( operation , HttpRequest (buildHost scheme <$> mHost) method - (T.pack (joinPath [baseP, T.unpack path'])) + (T.pack (baseP T.unpack path')) queryStr randomHeaders' (snd <$> maybeMimeAndBody) ) @@ -157,7 +158,7 @@ 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 + applyPathTemplating ts $ T.replace ("{" <> key <> "}") (urlEncodeText v) p genQuery :: [(T.Text, ParamSchema k, Bool)] -> Gen QueryText genQuery [] = pure [] @@ -167,6 +168,9 @@ let this = (\x -> (key, if T.null x then Nothing else Just x)) <$> v rest <- genQuery ts pure $ this <> rest + + urlEncodeText :: T.Text -> T.Text + urlEncodeText = decodeUtf8 . urlEncode False . encodeUtf8 paramSchemaAndAllowEmpty :: ParamLocation -> Param -> Maybe (T.Text, ParamSchema 'SwaggerKindParamOtherSchema, Bool) paramSchemaAndAllowEmpty loc Param { _paramName = n, _paramSchema = ParamOther pos@ParamOtherSchema {} } diff --git a/src/Test/Swagger/Print.hs b/src/Test/Swagger/Print.hs --- a/src/Test/Swagger/Print.hs +++ b/src/Test/Swagger/Print.hs @@ -5,16 +5,15 @@ , printRequest , printResponse) where -import Control.Monad import Data.Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +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 qualified Data.Text as T import Data.Text.Encoding -import qualified Data.Text.IO as TIO +import Data.Text.Lazy.Builder import Network.HTTP.Types import Test.Swagger.Types @@ -38,34 +37,36 @@ 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 :: Format -> HttpRequest -> Builder +printRequest FormatJSON r = fromUtf8Bytestring $ LBS.toStrict $ encode r +printRequest FormatNone _ = mempty 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 () + fromUtf8Bytestring method + <> fromText " " + <> fromText path + <> fromUtf8Bytestring (renderQuery True $ queryTextToQuery query) + <> fromTextLn " HTTP/1.1" + <> mconcat ((\(k,v) -> fromTextLn $ original k <> ": " <> v) <$> headers) + <> case body of + Just b -> fromText "\n" <> fromUtf8Bytestring (LBS.toStrict b) + Nothing -> mempty 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' + fromText "curl -i" + <> if method /= methodGet + then fromUtf8Bytestring $ " -X " <> method + else mempty + <> fromText " '" + <> fromText (escapeS host') + <> fromText (escape path) + <> fromText (escapeBS $ renderQuery True $ queryTextToQuery query) + <> singleton '\'' + <> mconcat ((\(k,v) -> fromText $ " -H '" <> escape (original k) <> ": " <> escape v <> "'") <$> headers) + <> case body of + Just b -> fromTextLn $ " -d '" <> escapeLBS b <> "'" + Nothing -> singleton '\n' where + host' = fromMaybe "http://localhost" host + escapeLBS :: LBS.ByteString -> T.Text escapeLBS = escapeBS . LBS.toStrict @@ -79,18 +80,28 @@ escapeS = escape . T.pack -- |Print a response according to format -printResponse :: Format -> HttpResponse -> IO () +printResponse :: Format -> HttpResponse -> Builder printResponse FormatCurl _ = error "unsupported format" -printResponse FormatJSON r = TIO.putStrLn $ decodeUtf8 $ LBS.toStrict $ encode r -printResponse FormatNone _ = pure () +printResponse FormatJSON r = fromUtf8Bytestring $ LBS.toStrict $ encode r +printResponse FormatNone _ = mempty 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 () + let ver = responseHttpVersion r + st = responseStatus r + headers = responseHeaders r + in + fromString ("HTTP/" <> show (httpMajor ver) <> "." <> show (httpMinor ver) <> " ") + <> fromString (show (statusCode st) <> " ") + <> fromUtf8BytestringLn (statusMessage st) + <> mconcat ((\(k,v) -> fromTextLn $ original k <> ": " <> v) <$> headers) + <> case responseBody r of + Just b -> fromText "\n" <> fromUtf8Bytestring (LBS.toStrict b) + Nothing -> mempty + +fromUtf8Bytestring :: BS.ByteString -> Builder +fromUtf8Bytestring = fromText . decodeUtf8 + +fromUtf8BytestringLn :: BS.ByteString -> Builder +fromUtf8BytestringLn = fromTextLn . decodeUtf8 + +fromTextLn :: T.Text -> Builder +fromTextLn t = fromText t <> fromText "\n" diff --git a/src/Test/Swagger/Report.hs b/src/Test/Swagger/Report.hs new file mode 100644 --- /dev/null +++ b/src/Test/Swagger/Report.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Test.Swagger.Report +Description : Exposes +Copyright : (c) Rodrigo Setti, 2017 +License : BSD3 +Maintainer : rodrigosetti@gmail.com +Stability : experimental +Portability : POSIX +-} +module Test.Swagger.Report ( TestReport(..) + , isSuccessful + , writeReportFile + , writeErrorReportFile + , runTests) where + +import Control.Concurrent.Async +import Control.Lens ((^.)) +import Control.Monad +import Data.Aeson as J +import qualified Data.ByteString.Lazy as LBS +import Data.List +import Data.Maybe +import qualified Data.Set as S +import Data.Swagger as W +import qualified Data.Text as T +import System.Random +import Test.Swagger.Gen +import Test.Swagger.Print +import Test.Swagger.Request +import Test.Swagger.Types +import Test.Swagger.Validate +import Text.Blaze.Html.Renderer.Utf8 +import Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes as A +import Data.Monoid + + +-- |A description of a particular test run. +data TestReport = TestReport { reportSeed :: Seed + , reportOperation :: Operation + , reportRequest :: HttpRequest + , reportResponse :: HttpResponse + , reportResult :: ValidationResult } + deriving Eq + +instance Ord TestReport where + + compare TestReport { reportSeed=s1, reportOperation=op1 } + TestReport { reportSeed=s2, reportOperation=op2} = + case (op1 ^. operationId, op2 ^. operationId) of + (Nothing, Nothing) -> compare s1 s2 + (x, y) -> compare x y + +-- |Predicate that tells whether or not a report is of a successful validation +isSuccessful :: TestReport -> Bool +isSuccessful TestReport { reportResult = Right _ } = True +isSuccessful _ = False + +isFailure :: TestReport -> Bool +isFailure = not . isSuccessful + +instance ToJSON TestReport where + toJSON (TestReport seed op req res vr) = J.object [ "seed" .= toJSON seed + , "operation" .= toJSON (op ^. operationId) + , "request" .= toJSON req + , "response" .= toJSON res + , "error" .= either toJSON (const Null) vr ] + +-- |Run n tests for a 'Swagger' schema +runTests :: NormalizedSwagger -> Int -> Size -> IO [TestReport] +runTests model n siz = + replicateConcurrently n $ + do seed <- abs <$> randomIO + let (op, req) = generateRequest seed siz model Nothing + res <- doHttpRequest req + let vr = validateResponseWithOperation res model op + pure $ TestReport seed op req res vr + +-- |Write a report file containing just a single error message. This is to be +-- used if we find an error before being able to run any test (parsing schema, +-- etc.) +writeErrorReportFile :: FilePath -> String -> IO () +writeErrorReportFile fp = LBS.writeFile fp . renderHtml . errorReport "Error" + +-- |Write a report file containing a header description about the 'Swagger' +-- schema, then a section about each 'Operation', how many tests were performed, +-- general stats (# failures/successes) and request/response details for failures. +writeReportFile :: FilePath -> NormalizedSwagger -> [TestReport] -> IO () +writeReportFile fp m = LBS.writeFile fp . renderHtml . report m + +errorReport :: String -> String -> Html +errorReport tit err = + docTypeHtml $ do + H.head $ + H.title $ toHtml tit + body $ do + h1 $ toHtml tit + p ! class_ "error" $ toHtml err + +report :: NormalizedSwagger -> [TestReport] -> Html +report model reps = + reportHeader model $ do + let total = length reps + totalFailures = length $ filter isFailure reps + + dl ! class_ "header-stats" $ do + dtdd "total number of tests" total + dtdd "total number of failures" totalFailures + + -- group reports by operations + let reportGroups = groupBy (\x y -> reportOperation x == reportOperation y) + $ sort reps + H.div ! class_ "operations" $ do + h2 "Operations" + ul ! class_ "operations-menu" $ + forM_ reportGroups $ \case + (TestReport { reportOperation=Operation { _operationOperationId=Just opid } }:_) -> + li $ a ! href (toValue $ "#" <> opid) $ toHtml opid + _ -> pure () + forM_ reportGroups $ \case + [] -> error "this shouldn't happen" + gr@(TestReport { reportOperation=op }:_) -> + do hr + let total' = length gr + failing = filter isFailure gr + totalFailures' = length failing + opid = fromMaybe "" $ op ^. operationId + h3 ! A.id (toValue opid) + $ a ! href ("#" <> toValue opid) + $ "Operation " <> toHtml opid + dl ! class_ "operation-header" $ do + forM_ (op ^. W.summary) $ \s -> + unless (T.null s) + $ dtdd "summary" s + forM_ (op ^. description) $ \d -> + unless (T.null d) + $ dtdd "description" d + unless (S.null $ op ^. tags) $ + dtdd "tags" + $ T.intercalate " ," $ S.toList $ op ^. tags + forM_ (op ^. deprecated) $ \d -> + dtdd "deprecated" d + dtdd "number of tests" total' + dtdd "number of failures" totalFailures' + unless (null failing) $ + H.div ! class_ "failures" $ do + h3 "Failure details" + forM_ failing $ \r -> do + let thisId = toValue opid <> toValue (reportSeed r) + h4 ! A.id thisId $ + a ! href ("#" <> thisId) + $ "Seed " <> toHtml (reportSeed r) + H.div ! class_ "http-request" $ do + let thisId' = toValue opid <> toValue (reportSeed r) <> "-req" + h5 ! A.id thisId' $ + a ! href ("#" <> thisId') + $ "HTTP Request" + code $ pre $ toHtml $ printRequest FormatHttp $ reportRequest r + H.div ! class_ "http-response" $ do + let thisId' = toValue opid <> toValue (reportSeed r) <> "-res" + h5 ! A.id thisId' $ + a ! href ("#" <> thisId') + $ "HTTP Response" + code $ pre $ toHtml $ printResponse FormatHttp $ reportResponse r + let thisId' = toValue opid <> toValue (reportSeed r) <> "-err" + h5 ! A.id thisId' $ + a ! href ("#" <> thisId') + $ "Error" + pre $ either toHtml (const "none") $ reportResult r + + +dtdd :: (ToMarkup a) => Html -> a -> Html +dtdd x y = dt x >> dd (toHtml y) + +reportHeader :: NormalizedSwagger -> Html -> Html +reportHeader model inner = + docTypeHtml $ do + let s = getSwagger model + schemaTitle = toHtml $ s ^. info . W.title + H.head $ do + H.title schemaTitle + H.style "dl {\ + \ margin: 0;\ + \}\ + \dl:after {\ + \ content: '.';\ + \ display: block;\ + \ clear: both;\ + \ visibility: hidden;\ + \ overflow: hidden;\ + \ height: 0;\ + \}\ + \dt {\ + \ font-weight: bold;\ + \ text-align: right;\ + \ float: left;\ + \ clear: left;\ + \ width: 15%;\ + \ margin-bottom: 1em;\ + \}\ + \dd {\ + \ margin-left: 17%;\ + \ margin-bottom: 1em;\ + \}" + body $ do + h1 schemaTitle + forM_ (s ^. info.description) $ \d -> + p ! class_ "schema-description" $ toHtml d + H.div ! class_ "report-body" $ inner diff --git a/src/Test/Swagger/Types.hs b/src/Test/Swagger/Types.hs --- a/src/Test/Swagger/Types.hs +++ b/src/Test/Swagger/Types.hs @@ -13,12 +13,14 @@ -} module Test.Swagger.Types (FullyQualifiedHost , Seed + , Size + , NormalizedSwagger + , getSwagger , OperationId , HttpHeader , Headers , HttpRequest(..) , HttpResponse(..) - , resolveReferences , refToMaybe) where import Control.Arrow @@ -29,7 +31,7 @@ import qualified Data.Text as T import Data.Text.Encoding import Network.HTTP.Types -import Control.Lens ((^.)) +import Control.Lens hiding ((.=)) import Data.Generics import qualified Data.HashMap.Strict.InsOrd as M import Data.Monoid ((<>)) @@ -39,6 +41,7 @@ type FullyQualifiedHost = String type Seed = Int +type Size = Int type OperationId = T.Text type HttpHeader = (CI T.Text, T.Text) @@ -50,7 +53,7 @@ , requestQuery :: QueryText , requestHeaders :: Headers , requestBody :: Maybe LBS.ByteString } - deriving (Show) + deriving (Eq, Show) instance ToJSON HttpRequest where toJSON r = object [ "host" .= toJSON (requestHost r) @@ -66,7 +69,7 @@ , responseStatus :: Status , responseHeaders :: Headers , responseBody :: Maybe LBS.ByteString } - deriving (Show) + deriving (Eq, Show) instance ToJSON HttpResponse where toJSON r = object [ "version" .= object [ "major" .= toJSON (httpMajor ver) @@ -80,20 +83,29 @@ st = responseStatus r headersMap = M.fromList $ first original <$> responseHeaders r +newtype NormalizedSwagger = Normalized { getSwagger :: Swagger } --- |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 +instance FromJSON NormalizedSwagger where + + parseJSON = fmap (Normalized . resolveReferences . prependBase) . parseJSON + where + prependBase :: Swagger -> Swagger + prependBase s = + maybe s (`prependPath` s) (s ^. basePath) & basePath .~ Nothing + + -- |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 diff --git a/src/Test/Swagger/Validate.hs b/src/Test/Swagger/Validate.hs --- a/src/Test/Swagger/Validate.hs +++ b/src/Test/Swagger/Validate.hs @@ -13,6 +13,7 @@ is parsed, if the operation is available (or just the id) -} module Test.Swagger.Validate ( parseResponse + , ValidationResult , validateResponseBytes , validateResponseWithOperation , validateResponse ) where @@ -42,49 +43,53 @@ import Network.HTTP.Types import Test.Swagger.Types +type ValidationResult = Either String () + -- |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 :: LBS.ByteString -> NormalizedSwagger -> OperationId -> ValidationResult 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:: HttpResponse -> NormalizedSwagger -> OperationId -> ValidationResult 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 + maybeOp = listToMaybe $ listify operationMatches $ getSwagger 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 = +validateResponseWithOperation :: HttpResponse -> NormalizedSwagger -> Operation -> ValidationResult +validateResponseWithOperation res ns 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) + sr <- maybe (Left $ "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 + do hv <- maybe (Left $ "expected header: " <> T.unpack k) pure $ lookup (mk k) $ responseHeaders res - validateWithParamSchema' (toJSON hv) $ h ^. paramSchema - + let jhv = fromMaybe (toJSON hv) $ decodeStrict $ encodeUtf8 hv + withPrefix ("invalid " <> T.unpack k <> " header value: " <> T.unpack hv) + $ validateWithParamSchema' jhv $ 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" + (Nothing, Just bs) | LBS.null bs -> pure () -- no response expected, got no response (OK) + (Just _, Nothing) -> Left $ "expected response body: " <> T.unpack (sr ^. description) + (Nothing, Just _) -> Left "unexpected response body" (Just rs, Just bs) -> - do jsonMime <- maybe (fail "unexpected!") pure $ parseAccept "application/json" + do jsonMime <- maybe (Left "unexpected!") pure $ parseAccept "application/json" -- TODO: should default be JSON? let respMime = fromMaybe jsonMime @@ -94,25 +99,29 @@ let mimes = fromMaybe (s ^. produces) $ operation ^. produces -- find one mime that matches - matchedMime <- maybe (fail "unexpected content-type") pure + matchedMime <- maybe (Left "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 + do b <- withPrefix "Could not parse body" $ eitherDecode bs + withPrefix "invalid body" $ validateWithSchema' b rs where - s = resolveReferences s' + s = getSwagger ns -- TODO: make it support patterns cfg = defaultConfig - validateWithSchema' :: Value -> Schema -> Either String () + withPrefix :: String -> Either String a -> Either String a + withPrefix p (Left e) = Left $ p <> ": " <> e + withPrefix _ v = v + + validateWithSchema' :: Value -> Schema -> ValidationResult validateWithSchema' v = resultToEither . runValidation (validateWithSchema v) cfg - validateWithParamSchema' :: Value -> ParamSchema t -> Either String () + validateWithParamSchema' :: Value -> ParamSchema t -> ValidationResult validateWithParamSchema' v = resultToEither . runValidation (validateWithParamSchema v) cfg resultToEither :: Result a -> Either String a diff --git a/swagger-test.cabal b/swagger-test.cabal --- a/swagger-test.cabal +++ b/swagger-test.cabal @@ -1,5 +1,5 @@ name: swagger-test -version: 0.1.0 +version: 0.2.1 synopsis: Testing of Swagger APIs description: This package provides a library and executable tool that supports testing APIs specified with Swagger. It @@ -25,16 +25,20 @@ exposed-modules: Test.Swagger , Test.Swagger.Gen , Test.Swagger.Print + , Test.Swagger.Report , Test.Swagger.Request , Test.Swagger.Types , Test.Swagger.Validate build-depends: base >= 4.7 && < 5 , QuickCheck == 2.10.* , aeson + , async , attoparsec , binary + , blaze-html , bytestring , case-insensitive + , containers , filepath , http-client , http-client-tls @@ -42,6 +46,7 @@ , http-types , insert-ordered-containers , lens + , random , scientific , swagger2 , syb @@ -54,14 +59,17 @@ main-is: Main.hs ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base + , aeson + , async , bytestring - , swagger-test + , directory + , filepath , lens - , text , optparse-applicative - , swagger2 - , aeson , random + , swagger-test + , swagger2 + , text default-language: Haskell2010 source-repository head