{-# 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 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) -- |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 -> 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 :: 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 $ (\(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 -- 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 . hostNameAndPort) <$> mHost)] <> [("Content-Type", fst <$> maybeMimeAndBody)] <> [("User-Agent", Just $ "swagger-test/" <> T.pack (showVersion version))] -- use scheme from operation, if defined, or from global 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 -- |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 } = 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