swagger-test 0.1.0 → 0.2.1
raw patch · 9 files changed
+546/−180 lines, 9 filesdep +asyncdep +blaze-htmldep +containers
Dependencies added: async, blaze-html, containers, directory
Files
- README.md +59/−12
- app/Main.hs +132/−70
- src/Test/Swagger.hs +2/−0
- src/Test/Swagger/Gen.hs +19/−15
- src/Test/Swagger/Print.hs +54/−43
- src/Test/Swagger/Report.hs +211/−0
- src/Test/Swagger/Types.hs +29/−17
- src/Test/Swagger/Validate.hs +27/−18
- swagger-test.cabal +13/−5
README.md view
@@ -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
app/Main.hs view
@@ -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)
src/Test/Swagger.hs view
@@ -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
src/Test/Swagger/Gen.hs view
@@ -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 {} }
src/Test/Swagger/Print.hs view
@@ -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"
+ src/Test/Swagger/Report.hs view
@@ -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
src/Test/Swagger/Types.hs view
@@ -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
src/Test/Swagger/Validate.hs view
@@ -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
swagger-test.cabal view
@@ -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