swagger-test (empty) → 0.1.0
raw patch · 11 files changed
+1117/−0 lines, 11 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed
Dependencies added: QuickCheck, aeson, attoparsec, base, binary, bytestring, case-insensitive, filepath, http-client, http-client-tls, http-media, http-types, insert-ordered-containers, lens, optparse-applicative, random, scientific, swagger-test, swagger2, syb, text, unordered-containers, vector
Files
- LICENSE +30/−0
- README.md +120/−0
- Setup.hs +2/−0
- app/Main.hs +152/−0
- src/Test/Swagger.hs +22/−0
- src/Test/Swagger/Gen.hs +312/−0
- src/Test/Swagger/Print.hs +96/−0
- src/Test/Swagger/Request.hs +50/−0
- src/Test/Swagger/Types.hs +101/−0
- src/Test/Swagger/Validate.hs +163/−0
- swagger-test.cabal +69/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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)
+ src/Test/Swagger.hs view
@@ -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
+ src/Test/Swagger/Gen.hs view
@@ -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
+ src/Test/Swagger/Print.hs view
@@ -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 ()
+ src/Test/Swagger/Request.hs view
@@ -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
+ src/Test/Swagger/Types.hs view
@@ -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
+ src/Test/Swagger/Validate.hs view
@@ -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
+ swagger-test.cabal view
@@ -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