From fa8cb0a63bd4ac1478c1a6bb6fd0119172f3b304 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 25 Apr 2019 11:50:33 +0300 Subject: [PATCH] Revert "Make schema type optional and infer it when validating" This reverts commit 7d8bbfc384b1609288a3ae1442e2ab156b164714. --- src/Data/Swagger.hs | 6 +- src/Data/Swagger/Internal.hs | 2 +- src/Data/Swagger/Internal/ParamSchema.hs | 42 +++++++------- src/Data/Swagger/Internal/Schema.hs | 56 +++++++++---------- .../Swagger/Internal/Schema/Validation.hs | 51 +++-------------- src/Data/Swagger/Lens.hs | 8 +-- src/Data/Swagger/Schema/Generator.hs | 33 +++++------ test/Data/Swagger/Schema/GeneratorSpec.hs | 8 +-- test/Data/Swagger/Schema/ValidationSpec.hs | 2 +- test/Data/SwaggerSpec.hs | 52 ++++++++--------- 10 files changed, 110 insertions(+), 150 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 53d11d6..e08f0d4 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -181,7 +181,7 @@ import Data.Swagger.Internal -- -- >>> :{ -- encode $ (mempty :: Swagger) --- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ] +-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ] -- & paths .~ -- [ ("/user", mempty & get ?~ (mempty -- & produces ?~ MimeList ["application/json"] @@ -204,7 +204,7 @@ import Data.Swagger.Internal -- "{\"description\":\"No content\"}" -- >>> :{ -- encode $ (mempty :: Schema) --- & type_ ?~ SwaggerBoolean +-- & type_ .~ SwaggerBoolean -- & description ?~ "To be or not to be" -- :} -- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}" @@ -213,7 +213,7 @@ import Data.Swagger.Internal -- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it. -- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@: -- --- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber +-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber -- "{\"type\":\"number\"}" -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@ diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index cd1b553..4abfe8b 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -593,7 +593,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. _paramSchemaDefault :: Maybe Value - , _paramSchemaType :: Maybe (SwaggerType t) + , _paramSchemaType :: SwaggerType t , _paramSchemaFormat :: Maybe Format , _paramSchemaItems :: Maybe (SwaggerItems t) , _paramSchemaMaximum :: Maybe Scientific diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index ff56f42..d482b47 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -59,20 +59,20 @@ import GHC.TypeLits (TypeError, ErrorMessage(..)) -- | Default schema for binary data (any sequence of octets). binaryParamSchema :: ParamSchema t binaryParamSchema = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "binary" -- | Default schema for binary data (base64 encoded). byteParamSchema :: ParamSchema t byteParamSchema = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "byte" -- | Default schema for password string. -- @"password"@ format is used to hint UIs the input needs to be obscured. passwordParamSchema :: ParamSchema t passwordParamSchema = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "password" -- | Convert a type into a plain @'ParamSchema'@. @@ -88,7 +88,7 @@ passwordParamSchema = mempty -- -- instance ToParamSchema Direction where -- toParamSchema _ = mempty --- & type_ ?~ SwaggerString +-- & type_ .~ SwaggerString -- & enum_ ?~ [ \"Up\", \"Down\" ] -- @ -- @@ -120,17 +120,17 @@ class ToParamSchema a where toParamSchema = genericToParamSchema defaultSchemaOptions instance OVERLAPPING_ ToParamSchema String where - toParamSchema _ = mempty & type_ ?~ SwaggerString + toParamSchema _ = mempty & type_ .~ SwaggerString instance ToParamSchema Bool where - toParamSchema _ = mempty & type_ ?~ SwaggerBoolean + toParamSchema _ = mempty & type_ .~ SwaggerBoolean instance ToParamSchema Integer where - toParamSchema _ = mempty & type_ ?~ SwaggerInteger + toParamSchema _ = mempty & type_ .~ SwaggerInteger instance ToParamSchema Natural where toParamSchema _ = mempty - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & minimum_ ?~ 0 & exclusiveMinimum ?~ False @@ -156,37 +156,37 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral -- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t toParamSchemaBoundedIntegral _ = mempty - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & minimum_ ?~ fromInteger (toInteger (minBound :: a)) & maximum_ ?~ fromInteger (toInteger (maxBound :: a)) instance ToParamSchema Char where toParamSchema _ = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & maxLength ?~ 1 & minLength ?~ 1 instance ToParamSchema Scientific where - toParamSchema _ = mempty & type_ ?~ SwaggerNumber + toParamSchema _ = mempty & type_ .~ SwaggerNumber instance HasResolution a => ToParamSchema (Fixed a) where toParamSchema _ = mempty - & type_ ?~ SwaggerNumber + & type_ .~ SwaggerNumber & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a)) instance ToParamSchema Double where toParamSchema _ = mempty - & type_ ?~ SwaggerNumber + & type_ .~ SwaggerNumber & format ?~ "double" instance ToParamSchema Float where toParamSchema _ = mempty - & type_ ?~ SwaggerNumber + & type_ .~ SwaggerNumber & format ?~ "float" timeParamSchema :: String -> ParamSchema t timeParamSchema fmt = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ T.pack fmt -- | Format @"date"@ corresponds to @yyyy-mm-dd@ format. @@ -222,12 +222,12 @@ instance ToParamSchema TL.Text where instance ToParamSchema Version where toParamSchema _ = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & pattern ?~ "^\\d+(\\.\\d+)*$" instance ToParamSchema SetCookie where toParamSchema _ = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString #if __GLASGOW_HASKELL__ < 800 @@ -254,7 +254,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t instance ToParamSchema a => ToParamSchema [a] where toParamSchema _ = mempty - & type_ ?~ SwaggerArray + & type_ .~ SwaggerArray & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a)) instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a]) @@ -274,12 +274,12 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where -- "{\"type\":\"string\",\"enum\":[\"_\"]}" instance ToParamSchema () where toParamSchema _ = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & enum_ ?~ ["_"] instance ToParamSchema UUID where toParamSchema _ = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "uuid" -- | A configurable generic @'ParamSchema'@ creator. @@ -317,7 +317,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) instance Constructor c => GEnumParamSchema (C1 c U1) where genumParamSchema opts _ s = s - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & enum_ %~ addEnumValue tag where tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index f127604..fe5d9ed 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -111,7 +111,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema -- declareNamedSchema _ = do -- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double) -- return $ NamedSchema (Just \"Coord\") $ mempty --- & type_ ?~ SwaggerObject +-- & type_ .~ SwaggerObject -- & properties .~ -- [ (\"x\", doubleSchema) -- , (\"y\", doubleSchema) @@ -294,20 +294,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs -- | Default schema for binary data (any sequence of octets). binarySchema :: Schema binarySchema = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "binary" -- | Default schema for binary data (base64 encoded). byteSchema :: Schema byteSchema = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "byte" -- | Default schema for password string. -- @"password"@ format is used to hint UIs the input needs to be obscured. passwordSchema :: Schema passwordSchema = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "password" -- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. @@ -333,12 +333,12 @@ sketchSchema = sketch . toJSON sketch js@(Bool _) = go js sketch js = go js & example ?~ js - go Null = mempty & type_ ?~ SwaggerNull - go (Bool _) = mempty & type_ ?~ SwaggerBoolean - go (String _) = mempty & type_ ?~ SwaggerString - go (Number _) = mempty & type_ ?~ SwaggerNumber + go Null = mempty & type_ .~ SwaggerNull + go (Bool _) = mempty & type_ .~ SwaggerBoolean + go (String _) = mempty & type_ .~ SwaggerString + go (Number _) = mempty & type_ .~ SwaggerNumber go (Array xs) = mempty - & type_ ?~ SwaggerArray + & type_ .~ SwaggerArray & items ?~ case ischema of Just s -> SwaggerItemsObject (Inline s) _ -> SwaggerItemsArray (map Inline ys) @@ -350,7 +350,7 @@ sketchSchema = sketch . toJSON (z:_) | allSame -> Just z _ -> Nothing go (Object o) = mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & required .~ HashMap.keys o & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) @@ -373,24 +373,24 @@ sketchSchema = sketch . toJSON sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON where - go Null = mempty & type_ ?~ SwaggerNull + go Null = mempty & type_ .~ SwaggerNull go js@(Bool _) = mempty - & type_ ?~ SwaggerBoolean + & type_ .~ SwaggerBoolean & enum_ ?~ [js] go js@(String s) = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & maxLength ?~ fromIntegral (T.length s) & minLength ?~ fromIntegral (T.length s) & pattern ?~ s & enum_ ?~ [js] go js@(Number n) = mempty - & type_ ?~ SwaggerNumber + & type_ .~ SwaggerNumber & maximum_ ?~ n & minimum_ ?~ n & multipleOf ?~ n & enum_ ?~ [js] go js@(Array xs) = mempty - & type_ ?~ SwaggerArray + & type_ .~ SwaggerArray & maxItems ?~ fromIntegral sz & minItems ?~ fromIntegral sz & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs)) @@ -400,7 +400,7 @@ sketchStrictSchema = go . toJSON sz = length xs allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs)) go js@(Object o) = mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & required .~ names & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) & maxProperties ?~ fromIntegral (length names) @@ -416,7 +416,7 @@ instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where declareNamedSchema _ = do ref <- declareSchemaRef (Proxy :: Proxy a) return $ unnamed $ mempty - & type_ ?~ SwaggerArray + & type_ .~ SwaggerArray & items ?~ SwaggerItemsObject ref instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema @@ -466,7 +466,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f timeSchema :: T.Text -> Schema timeSchema fmt = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ fmt -- | Format @"date"@ corresponds to @yyyy-mm-dd@ format. @@ -528,7 +528,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where declareObjectMapSchema = do schema <- declareSchemaRef (Proxy :: Proxy v) return $ unnamed $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & additionalProperties ?~ AdditionalPropertiesSchema schema instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where @@ -540,7 +540,7 @@ instance ToSchema a => ToSchema (Map String a) where declareNamedSchema _ = do schema <- declareSchemaRef (Proxy :: Proxy a) return $ unnamed $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & additionalProperties ?~ schema instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a)) @@ -554,7 +554,7 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = instance OVERLAPPING_ ToSchema Object where declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & description ?~ "Arbitrary JSON object." & additionalProperties ?~ AdditionalPropertiesAllowed True @@ -595,7 +595,7 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar -- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}" toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema toSchemaBoundedIntegral _ = mempty - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & minimum_ ?~ fromInteger (toInteger (minBound :: a)) & maximum_ ?~ fromInteger (toInteger (maxBound :: a)) @@ -641,7 +641,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o let allKeys = [minBound..maxBound :: key] mkPair k = (keyToText k, valueRef) return $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ InsOrdHashMap.fromList (map mkPair allKeys) -- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys. @@ -715,7 +715,7 @@ paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy nullarySchema :: Schema nullarySchema = mempty - & type_ ?~ SwaggerArray + & type_ .~ SwaggerArray & items ?~ SwaggerItemsArray [] gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema @@ -786,12 +786,12 @@ withFieldSchema opts _ isRequiredField schema = do return $ if T.null fname then schema - & type_ ?~ SwaggerArray + & type_ .~ SwaggerArray & items %~ appendItem ref & maxItems %~ Just . maybe 1 (+1) -- increment maxItems & minItems %~ Just . maybe 1 (+1) -- increment minItems else schema - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties . at fname ?~ ref & if isRequiredField then required %~ (++ [fname]) @@ -828,7 +828,7 @@ gdeclareNamedSumSchema opts proxy s (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema) toStringTag schema = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) type AllNullary = All @@ -842,7 +842,7 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) => Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema gsumConToSchemaWith ref opts _ schema = schema - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties . at tag ?~ ref & maxProperties ?~ 1 & minProperties ?~ 1 diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index e8986fd..ffc6d91 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} @@ -33,7 +32,6 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified "unordered-containers" Data.HashSet as HashSet -import Data.List (intercalate) import Data.Monoid import Data.Proxy import Data.Scientific (Scientific, isInteger) @@ -324,8 +322,8 @@ validateObject o = withSchema $ \sch -> validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v unknownProperty :: Text -> Validation s a - unknownProperty pname = invalid $ - "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema" + unknownProperty name = invalid $ + "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema" validateEnum :: Value -> Validation (ParamSchema t) () validateEnum value = do @@ -335,10 +333,8 @@ validateEnum value = do -- | Infer schema type based on used properties. -- --- This is like 'inferParamSchemaTypes', but also works for objects: --- --- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}" --- Just [SwaggerObject] +-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}" +-- Just [SwaggerString] inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema] inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ [ SwaggerObject | any ($ sch) @@ -352,15 +348,6 @@ inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ -- -- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}" -- Just [SwaggerString] --- --- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}" --- Just [SwaggerArray] --- --- From numeric properties 'SwaggerInteger' type is inferred. --- If you want 'SwaggerNumber' instead, you must specify it explicitly. --- --- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}" --- Just [SwaggerInteger] inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t] inferParamSchemaTypes sch = concat [ [ SwaggerArray | any ($ sch) @@ -382,18 +369,7 @@ inferParamSchemaTypes sch = concat validateSchemaType :: Value -> Validation Schema () validateSchemaType value = withSchema $ \sch -> - case sch ^. type_ of - Just explicitType -> validateSchemaTypeAs explicitType value - Nothing -> - case inferSchemaTypes sch of - [t] -> validateSchemaTypeAs t value - [] -> invalid $ "unable to infer type for schema, please provide type explicitly" - ts -> invalid $ "unable to infer type for schema, possible candidates: " ++ intercalate ", " (map show ts) - -validateSchemaTypeAs - :: SwaggerType 'SwaggerKindSchema -> Value -> Validation Schema () -validateSchemaTypeAs t value = - case (t, value) of + case (sch ^. type_, value) of (SwaggerNull, Null) -> valid (SwaggerBoolean, Bool _) -> valid (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) @@ -401,26 +377,15 @@ validateSchemaTypeAs t value = (SwaggerString, String s) -> sub_ paramSchema (validateString s) (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) (SwaggerObject, Object o) -> validateObject o - _ -> invalid $ "expected JSON value of type " ++ show t + (t, _) -> invalid $ "expected JSON value of type " ++ show t validateParamSchemaType :: Value -> Validation (ParamSchema t) () validateParamSchemaType value = withSchema $ \sch -> - case sch ^. type_ of - Just explicitType -> validateParamSchemaTypeAs explicitType value - Nothing -> - case inferParamSchemaTypes sch of - [t] -> validateParamSchemaTypeAs t value - [] -> invalid $ "unable to infer type for schema, please provide type explicitly" - ts -> invalid $ "unable to infer type for schema, possible candidates: " ++ intercalate ", " (map show ts) - -validateParamSchemaTypeAs - :: SwaggerType t -> Value -> Validation (ParamSchema t) () -validateParamSchemaTypeAs t value = - case (t, value) of + case (sch ^. type_, value) of (SwaggerBoolean, Bool _) -> valid (SwaggerInteger, Number n) -> validateInteger n (SwaggerNumber, Number n) -> validateNumber n (SwaggerString, String s) -> validateString s (SwaggerArray, Array xs) -> validateArray xs - _ -> invalid $ "expected JSON value of type " ++ show t + (t, _) -> invalid $ "expected JSON value of type " ++ show t diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index e82bd3f..f442f81 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -99,10 +99,10 @@ instance At Operation where at n = responses . at n instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema -- HasType instances -instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_ -instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ -instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ -instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_ +instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_ +instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_ +instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_ +instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_ -- HasDefault instances instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_ diff --git a/src/Data/Swagger/Schema/Generator.hs b/src/Data/Swagger/Schema/Generator.hs index e09c11a..b315c41 100644 --- a/src/Data/Swagger/Schema/Generator.hs +++ b/src/Data/Swagger/Schema/Generator.hs @@ -4,25 +4,24 @@ module Data.Swagger.Schema.Generator where -import Prelude () +import Prelude () import Prelude.Compat import Control.Lens.Operators -import Control.Monad (filterM) +import Control.Monad (filterM) import Data.Aeson import Data.Aeson.Types -import qualified Data.HashMap.Strict.InsOrd as M +import qualified Data.HashMap.Strict.InsOrd as M import Data.Maybe import Data.Maybe import Data.Proxy import Data.Scientific -import qualified Data.Set as S +import qualified Data.Set as S import Data.Swagger import Data.Swagger.Declare -import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes) -import qualified Data.Text as T -import qualified Data.Vector as V -import Test.QuickCheck (arbitrary) +import qualified Data.Text as T +import qualified Data.Vector as V +import Test.QuickCheck (arbitrary) import Test.QuickCheck.Gen import Test.QuickCheck.Property @@ -31,25 +30,21 @@ schemaGen _ schema | Just cases <- schema ^. paramSchema . enum_ = elements cases schemaGen defns schema = case schema ^. type_ of - Nothing -> - case inferSchemaTypes schema of - [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType) - _ -> fail "unable to infer schema type" - Just SwaggerBoolean -> Bool <$> elements [True, False] - Just SwaggerNull -> pure Null - Just SwaggerNumber + SwaggerBoolean -> Bool <$> elements [True, False] + SwaggerNull -> pure Null + SwaggerNumber | Just min <- schema ^. minimum_ , Just max <- schema ^. maximum_ -> Number . fromFloatDigits <$> choose (toRealFloat min, toRealFloat max :: Double) | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double) - Just SwaggerInteger + SwaggerInteger | Just min <- schema ^. minimum_ , Just max <- schema ^. maximum_ -> Number . fromInteger <$> choose (truncate min, truncate max) | otherwise -> Number . fromInteger <$> arbitrary - Just SwaggerArray + SwaggerArray | Just 0 <- schema ^. maxLength -> pure $ Array V.empty | Just items <- schema ^. items -> case items of @@ -64,14 +59,14 @@ schemaGen defns schema = SwaggerItemsArray refs -> let itemGens = schemaGen defns . dereference defns <$> refs in fmap (Array . V.fromList) $ sequence itemGens - Just SwaggerString -> do + SwaggerString -> do size <- getSize let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength length <- choose (minLength', max minLength' maxLength') str <- vectorOf length arbitrary return . String $ T.pack str - Just SwaggerObject -> do + SwaggerObject -> do size <- getSize let props = dereference defns <$> schema ^. properties reqKeys = S.fromList $ schema ^. required diff --git a/test/Data/Swagger/Schema/GeneratorSpec.hs b/test/Data/Swagger/Schema/GeneratorSpec.hs index 9cf06be..edf296e 100644 --- a/test/Data/Swagger/Schema/GeneratorSpec.hs +++ b/test/Data/Swagger/Schema/GeneratorSpec.hs @@ -103,7 +103,7 @@ instance FromJSON WrongType where instance ToSchema WrongType where declareNamedSchema _ = return . NamedSchema (Just "WrongType") $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject data MissingRequired = MissingRequired @@ -123,7 +123,7 @@ instance ToSchema MissingRequired where boolSchema <- declareSchemaRef (Proxy :: Proxy Bool) return . NamedSchema (Just "MissingRequired") $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ [("propA", stringSchema) ,("propB", boolSchema) ] @@ -145,7 +145,7 @@ instance ToSchema MissingProperty where stringSchema <- declareSchemaRef (Proxy :: Proxy String) return . NamedSchema (Just "MissingProperty") $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ [("propC", stringSchema)] & required .~ ["propC"] @@ -163,6 +163,6 @@ instance ToSchema WrongPropType where boolSchema <- declareSchemaRef (Proxy :: Proxy Bool) return . NamedSchema (Just "WrongPropType") $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ [("propE", boolSchema)] & required .~ ["propE"] diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs index 6d43c99..fb0d817 100644 --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -248,7 +248,7 @@ instance ToJSON FreeForm where instance ToSchema FreeForm where declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & additionalProperties ?~ AdditionalPropertiesAllowed True instance Arbitrary FreeForm where diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs index 3569b25..57d34c1 100644 --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -158,7 +158,7 @@ operationExample = mempty stringSchema :: ParamLocation -> ParamOtherSchema stringSchema loc = mempty & in_ .~ loc - & type_ ?~ SwaggerString + & type_ .~ SwaggerString operationExampleJSON :: Value operationExampleJSON = [aesonQQ| @@ -224,7 +224,7 @@ operationExampleJSON = [aesonQQ| schemaPrimitiveExample :: Schema schemaPrimitiveExample = mempty - & type_ ?~ SwaggerString + & type_ .~ SwaggerString & format ?~ "email" schemaPrimitiveExampleJSON :: Value @@ -237,14 +237,14 @@ schemaPrimitiveExampleJSON = [aesonQQ| schemaSimpleModelExample :: Schema schemaSimpleModelExample = mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & required .~ [ "name" ] & properties .~ - [ ("name", Inline (mempty & type_ ?~ SwaggerString)) + [ ("name", Inline (mempty & type_ .~ SwaggerString)) , ("address", Ref (Reference "Address")) , ("age", Inline $ mempty & minimum_ ?~ 0 - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & format ?~ "int32" ) ] schemaSimpleModelExampleJSON :: Value @@ -272,8 +272,8 @@ schemaSimpleModelExampleJSON = [aesonQQ| schemaModelDictExample :: Schema schemaModelDictExample = mempty - & type_ ?~ SwaggerObject - & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString)) + & type_ .~ SwaggerObject + & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ .~ SwaggerString)) schemaModelDictExampleJSON :: Value schemaModelDictExampleJSON = [aesonQQ| @@ -287,7 +287,7 @@ schemaModelDictExampleJSON = [aesonQQ| schemaAdditionalExample :: Schema schemaAdditionalExample = mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & additionalProperties ?~ AdditionalPropertiesAllowed True schemaAdditionalExampleJSON :: Value @@ -300,13 +300,13 @@ schemaAdditionalExampleJSON = [aesonQQ| schemaWithExampleExample :: Schema schemaWithExampleExample = mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ [ ("id", Inline $ mempty - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & format ?~ "int64" ) , ("name", Inline $ mempty - & type_ ?~ SwaggerString) ] + & type_ .~ SwaggerString) ] & required .~ [ "name" ] & example ?~ [aesonQQ| { @@ -345,19 +345,19 @@ schemaWithExampleExampleJSON = [aesonQQ| definitionsExample :: HashMap Text Schema definitionsExample = [ ("Category", mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ [ ("id", Inline $ mempty - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & format ?~ "int64") - , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) + , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) , ("Tag", mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ [ ("id", Inline $ mempty - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & format ?~ "int64") - , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ] + , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ] definitionsExampleJSON :: Value definitionsExampleJSON = [aesonQQ| @@ -401,7 +401,7 @@ paramsDefinitionExample = & required ?~ True & schema .~ ParamOther (mempty & in_ .~ ParamQuery - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & format ?~ "int32" )) , ("limitParam", mempty & name .~ "limit" @@ -409,7 +409,7 @@ paramsDefinitionExample = & required ?~ True & schema .~ ParamOther (mempty & in_ .~ ParamQuery - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & format ?~ "int32" )) ] paramsDefinitionExampleJSON :: Value @@ -510,7 +510,7 @@ swaggerExample = mempty & at 200 ?~ Inline (mempty & description .~ "OK" & schema ?~ Inline (mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & example ?~ [aesonQQ| { "created": 100, @@ -519,9 +519,9 @@ swaggerExample = mempty & description ?~ "This is some real Todo right here" & properties .~ [ ("created", Inline $ mempty - & type_ ?~ SwaggerInteger + & type_ .~ SwaggerInteger & format ?~ "int32") - , ("description", Inline (mempty & type_ ?~ SwaggerString))])) + , ("description", Inline (mempty & type_ .~ SwaggerString))])) & produces ?~ MimeList [ "application/json" ] & parameters .~ [ Inline $ mempty @@ -530,7 +530,7 @@ swaggerExample = mempty & description ?~ "TodoId param" & schema .~ ParamOther (mempty & in_ .~ ParamPath - & type_ ?~ SwaggerString ) ] + & type_ .~ SwaggerString ) ] & tags .~ Set.fromList [ "todo" ] )) swaggerExampleJSON :: Value @@ -1632,14 +1632,14 @@ petstoreExampleJSON = [aesonQQ| compositionSchemaExample :: Schema compositionSchemaExample = mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & Data.Swagger.allOf ?~ [ Ref (Reference "Other") , Inline (mempty - & type_ ?~ SwaggerObject + & type_ .~ SwaggerObject & properties .~ [ ("greet", Inline $ mempty - & type_ ?~ SwaggerString) ]) + & type_ .~ SwaggerString) ]) ] compositionSchemaExampleJSON :: Value