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 hiding (version)
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 ((</>))
import Test.QuickCheck hiding (Fixed)
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random
import Test.Swagger.Types
import Paths_swagger_test (version)
import Data.Version (showVersion)
generateRequest :: Seed -> Size -> NormalizedSwagger -> Maybe OperationId -> (Operation, HttpRequest)
generateRequest seed size model mopid =
let gen = mkQCGen seed
in unGen (requestGenerator model mopid) gen size
requestGenerator :: NormalizedSwagger -> Maybe OperationId -> Gen (Operation, HttpRequest)
requestGenerator ns mopid =
do let s = getSwagger ns
baseP = fromMaybe "/" $ s ^. basePath
mHost = s ^. host
let availableOps :: [(FilePath, PathItem, Method, Operation)]
availableOps = catMaybes $ mconcat $
(\(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)
(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
let params = catMaybes $ refToMaybe <$> (item ^. parameters) <> (operation ^. parameters)
(requiredParams, notRequiredParams) = partition paramIsRequired params
selectedOptionalParams <- sublistOf notRequiredParams
let finalParams = requiredParams <> selectedOptionalParams
let pathParams = catMaybes (paramSchemaAndAllowEmpty ParamPath <$> finalParams)
path' <- applyPathTemplating pathParams $ T.pack path
let queryParams = catMaybes $ paramSchemaAndAllowEmpty ParamQuery <$> finalParams
queryStr <- genQuery queryParams
let headerParams = catMaybes (paramSchemaAndAllowEmpty ParamHeader <$> finalParams)
randomHeaders <- genQuery headerParams
let formDataParams = catMaybes $ paramSchemaAndAllowEmpty ParamFormData <$> finalParams
maybeMimeAndBody <-
if null formDataParams
then do
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 . hostNameAndPort) <$> mHost)]
<> [("Content-Type", fst <$> maybeMimeAndBody)]
<> [("User-Agent", Just $ "swagger-test/" <> T.pack (showVersion version))]
scheme <- elements $ fromMaybe [schemeForPort $ view port =<< mHost] (operation ^. schemes <|> s ^. schemes)
pure ( operation
, HttpRequest (buildHost scheme <$> mHost)
method
(T.pack (baseP </> T.unpack path'))
queryStr
randomHeaders'
(snd <$> maybeMimeAndBody) )
where
schemeForPort (Just 80) = Http
schemeForPort (Just 443) = Https
schemeForPort _ = Http
buildHost :: Scheme -> Host -> String
buildHost sc h = schemeToHttpPrefix sc <> hostNameAndPort h
hostNameAndPort :: Host -> String
hostNameAndPort h = (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 <> "}") (urlEncodeText 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
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 {} }
| loc == pos ^. in_ = Just ( n
, pos ^. paramSchema
, (loc == ParamQuery || loc == ParamFormData)
&& fromMaybe False (pos ^. allowEmptyValue))
| otherwise = Nothing
paramSchemaAndAllowEmpty _ Param { _paramSchema = ParamBody _ } = Nothing
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
paramGen :: ParamSchema a -> Bool -> Gen Value
paramGen ParamSchema { _paramSchemaEnum=Just values} allowEmpty = elements $ values <> [Null | allowEmpty]
paramGen ParamSchema { _paramSchemaType=SwaggerString } allowEmpty = genJString allowEmpty
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]
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)
paramGen ParamSchema { _paramSchemaType=SwaggerFile } allowEmpty = genJString allowEmpty
paramGen ParamSchema { _paramSchemaType=SwaggerNull } _ = pure Null
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 :: 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
genJSON :: Schema -> Gen Value
genJSON Schema { _schemaAllOf = Just ss } =
let ss' = catMaybes $ refToMaybe <$> ss
in foldl merge Null <$> mapM genJSON ss'
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