diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index e08f0d4..53d11d6 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 4abfe8b..cd1b553 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 :: SwaggerType t + , _paramSchemaType :: Maybe (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 d482b47..ff56f42 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 fe5d9ed..f127604 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 141dc19..e8986fd 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module: Data.Swagger.Internal.Schema.Validation -- Copyright: (c) 2015 GetShopTV @@ -20,28 +22,30 @@ -- Validate JSON values with Swagger Schema. module Data.Swagger.Internal.Schema.Validation where -import Control.Applicative -import Control.Lens -import Control.Monad (when) +import Control.Applicative +import Control.Lens +import Control.Monad (when) -import Data.Aeson hiding (Result) -import Data.Foldable (traverse_, for_, sequenceA_) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap +import Data.Aeson hiding (Result) +import Data.Foldable (for_, sequenceA_, + traverse_) +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 qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap -import Data.Monoid -import Data.Proxy -import Data.Scientific (Scientific, isInteger) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Vector (Vector) -import qualified Data.Vector as Vector - -import Data.Swagger.Declare -import Data.Swagger.Internal -import Data.Swagger.Internal.Schema -import Data.Swagger.Lens +import Data.List (intercalate) +import Data.Monoid +import Data.Proxy +import Data.Scientific (Scientific, isInteger) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as Vector + +import Data.Swagger.Declare +import Data.Swagger.Internal +import Data.Swagger.Internal.Schema +import Data.Swagger.Lens -- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value. -- This can be used with QuickCheck to ensure those instances are coherent: @@ -320,8 +324,8 @@ validateObject o = withSchema $ \sch -> validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v unknownProperty :: Text -> Validation s a - unknownProperty name = invalid $ - "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema" + unknownProperty pname = invalid $ + "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema" validateEnum :: Value -> Validation (ParamSchema t) () validateEnum value = do @@ -329,9 +333,67 @@ validateEnum value = do when (value `notElem` xs) $ invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value) +-- | Infer schema type based on used properties. +-- +-- This is like 'inferParamSchemaTypes', but also works for objects: +-- +-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}" +-- Just [SwaggerObject] +inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema] +inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ + [ SwaggerObject | any ($ sch) + [ has (additionalProperties._Just) + , has (maxProperties._Just) + , has (minProperties._Just) + , has (properties.folded) + , has (required.folded) ] ] + +-- | Infer schema type based on used properties. +-- +-- >>> 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) + [ has (items._Just) + , has (maxItems._Just) + , has (minItems._Just) + , has (uniqueItems._Just) ] ] + , [ SwaggerInteger | any ($ sch) + [ has (exclusiveMaximum._Just) + , has (exclusiveMinimum._Just) + , has (maximum_._Just) + , has (minimum_._Just) + , has (multipleOf._Just) ] ] + , [ SwaggerString | any ($ sch) + [ has (maxLength._Just) + , has (minLength._Just) + , has (pattern._Just) ] ] + ] + validateSchemaType :: Value -> Validation Schema () validateSchemaType value = withSchema $ \sch -> - case (sch ^. type_, value) of + 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 (SwaggerNull, Null) -> valid (SwaggerBoolean, Bool _) -> valid (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) @@ -339,15 +401,26 @@ validateSchemaType value = withSchema $ \sch -> (SwaggerString, String s) -> sub_ paramSchema (validateString s) (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) (SwaggerObject, Object o) -> validateObject o - (t, _) -> invalid $ "expected JSON value of type " ++ show t + _ -> invalid $ "expected JSON value of type " ++ show t validateParamSchemaType :: Value -> Validation (ParamSchema t) () validateParamSchemaType value = withSchema $ \sch -> - case (sch ^. type_, value) of + 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 (SwaggerBoolean, Bool _) -> valid (SwaggerInteger, Number n) -> validateInteger n (SwaggerNumber, Number n) -> validateNumber n (SwaggerString, String s) -> validateString s (SwaggerArray, Array xs) -> validateArray xs - (t, _) -> invalid $ "expected JSON value of type " ++ show t + _ -> invalid $ "expected JSON value of type " ++ show t diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index f442f81..e82bd3f 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 (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_ +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_ -- 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 b315c41..e09c11a 100644 --- a/src/Data/Swagger/Schema/Generator.hs +++ b/src/Data/Swagger/Schema/Generator.hs @@ -4,24 +4,25 @@ 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 qualified Data.Text as T -import qualified Data.Vector as V -import Test.QuickCheck (arbitrary) +import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes) +import qualified Data.Text as T +import qualified Data.Vector as V +import Test.QuickCheck (arbitrary) import Test.QuickCheck.Gen import Test.QuickCheck.Property @@ -30,21 +31,25 @@ schemaGen _ schema | Just cases <- schema ^. paramSchema . enum_ = elements cases schemaGen defns schema = case schema ^. type_ of - SwaggerBoolean -> Bool <$> elements [True, False] - SwaggerNull -> pure Null - SwaggerNumber + 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 | Just min <- schema ^. minimum_ , Just max <- schema ^. maximum_ -> Number . fromFloatDigits <$> choose (toRealFloat min, toRealFloat max :: Double) | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double) - SwaggerInteger + Just SwaggerInteger | Just min <- schema ^. minimum_ , Just max <- schema ^. maximum_ -> Number . fromInteger <$> choose (truncate min, truncate max) | otherwise -> Number . fromInteger <$> arbitrary - SwaggerArray + Just SwaggerArray | Just 0 <- schema ^. maxLength -> pure $ Array V.empty | Just items <- schema ^. items -> case items of @@ -59,14 +64,14 @@ schemaGen defns schema = SwaggerItemsArray refs -> let itemGens = schemaGen defns . dereference defns <$> refs in fmap (Array . V.fromList) $ sequence itemGens - SwaggerString -> do + Just 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 - SwaggerObject -> do + Just 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 edf296e..9cf06be 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 fb0d817..6d43c99 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 57d34c1..3569b25 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