diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ +2.4 +--- + +- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5 +- Tags aren't sorted + (see [#165](https://github.com/GetShopTV/swagger2/issues/165)) +- Schema type is optional + (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164)) +- Take concrete 'Proxy' as argument + (see [#180](https://github.com/GetShopTV/swagger2/pull/180)) +- GHC-8.8 preparations + 2.3.1.1 ------- + - Allow `network-3.0` 2.3.1 diff --git a/examples/hackage.hs b/examples/hackage.hs --- a/examples/hackage.hs +++ b/examples/hackage.hs @@ -27,7 +27,7 @@ usernameSchema <- declareSchemaRef (Proxy :: Proxy Username) useridSchema <- declareSchemaRef (Proxy :: Proxy Int) return $ NamedSchema (Just "UserSummary") $ mempty - & type_ .~ SwaggerObject + & type_ ?~ SwaggerObject & properties .~ [ ("summaryUsername", usernameSchema ) , ("summaryUserid" , useridSchema ) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -181,7 +181,7 @@ -- -- >>> :{ -- 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 @@ -- "{\"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 @@ -- 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 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -29,13 +29,14 @@ import Data.Aeson import qualified Data.Aeson.Types as JSON import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) +import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap +import Data.HashSet.InsOrd (InsOrdHashSet) import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid (Monoid (..)) import Data.Semigroup.Compat (Semigroup (..)) import Data.Scientific (Scientific) -import Data.Set (Set) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text @@ -129,7 +130,7 @@ -- Not all tags that are used by the Operation Object must be declared. -- The tags that are not declared may be organized randomly or based on the tools' logic. -- Each tag name in the list MUST be unique. - , _swaggerTags :: Set Tag + , _swaggerTags :: InsOrdHashSet Tag -- | Additional external documentation. , _swaggerExternalDocs :: Maybe ExternalDocs @@ -251,7 +252,7 @@ data Operation = Operation { -- | A list of tags for API documentation control. -- Tags can be used for logical grouping of operations by resources or any other qualifier. - _operationTags :: Set TagName + _operationTags :: InsOrdHashSet TagName -- | A short summary of what the operation does. -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters. @@ -593,7 +594,7 @@ -- 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 @@ -610,7 +611,7 @@ , _paramSchemaMultipleOf :: Maybe Scientific } deriving (Eq, Show, Generic, Typeable) -deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k) +deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k) data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. @@ -778,6 +779,8 @@ , _tagExternalDocs :: Maybe ExternalDocs } deriving (Eq, Ord, Show, Generic, Data, Typeable) +instance Hashable Tag + instance IsString Tag where fromString s = Tag (fromString s) Nothing Nothing @@ -791,6 +794,8 @@ , _externalDocsUrl :: URL } deriving (Eq, Ord, Show, Generic, Data, Typeable) +instance Hashable ExternalDocs + -- | A simple object to allow referencing other definitions in the specification. -- It can be used to reference parameters and responses that are defined at the top level for reuse. newtype Reference = Reference { getReference :: Text } @@ -804,7 +809,7 @@ instance IsString a => IsString (Referenced a) where fromString = Inline . fromString -newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable) +newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable) data AdditionalProperties = AdditionalPropertiesAllowed Bool @@ -913,6 +918,7 @@ instance SwaggerMonoid Response instance SwaggerMonoid ExternalDocs instance SwaggerMonoid Operation +instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a) instance SwaggerMonoid MimeList deriving instance SwaggerMonoid URL diff --git a/src/Data/Swagger/Internal/AesonUtils.hs b/src/Data/Swagger/Internal/AesonUtils.hs --- a/src/Data/Swagger/Internal/AesonUtils.hs +++ b/src/Data/Swagger/Internal/AesonUtils.hs @@ -44,6 +44,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set import qualified Data.HashMap.Strict.InsOrd as InsOrd +import qualified Data.HashSet.InsOrd as InsOrdHS #if MIN_VERSION_aeson(0,10,0) import Data.Aeson (Encoding, pairs, (.=), Series) @@ -67,10 +68,10 @@ makeLenses ''SwaggerAesonOptions class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where - swaggerAesonOptions :: proxy a -> SwaggerAesonOptions + swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions -- So far we use only default definitions - aesonDefaults :: proxy a -> POP Maybe (Code a) + aesonDefaults :: Proxy a -> POP Maybe (Code a) aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue ------------------------------------------------------------------------------- @@ -85,6 +86,7 @@ instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing instance AesonDefaultValue [a] where defaultValue = Just [] instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty +instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty ------------------------------------------------------------------------------- @@ -144,7 +146,11 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> [Pair] +#if MIN_VERSION_generics_sop(0,5,0) +sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = +#else sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = +#endif sopSwaggerGenericToJSON'' opts fields fieldsInfo defs sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type" @@ -220,7 +226,11 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Parser (SOP I '[xs]) +#if MIN_VERSION_generics_sop(0,5,0) +sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = +#else sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = +#endif SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type" @@ -292,7 +302,11 @@ -> DatatypeInfo '[xs] -> POP Maybe '[xs] -> Series +#if MIN_VERSION_generics_sop(0,5,0) +sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) = +#else sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) = +#endif sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type" diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -59,20 +59,20 @@ -- | 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 @@ -- -- instance ToParamSchema Direction where -- toParamSchema _ = mempty --- & type_ .~ SwaggerString +-- & type_ ?~ SwaggerString -- & enum_ ?~ [ \"Up\", \"Down\" ] -- @ -- @@ -115,22 +115,22 @@ -- -- >>> encode $ toParamSchema (Proxy :: Proxy Integer) -- "{\"type\":\"integer\"}" - toParamSchema :: proxy a -> ParamSchema t - default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t + toParamSchema :: Proxy a -> ParamSchema t + default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t 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 @@ -154,39 +154,39 @@ -- -- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8) -- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" -toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t +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 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 [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 @@ -- "{\"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. @@ -288,11 +288,11 @@ -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color) -- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}" -genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t +genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty class GToParamSchema (f :: * -> *) where - gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t + gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t instance GToParamSchema f => GToParamSchema (D1 d f) where gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f) @@ -310,14 +310,14 @@ gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) class GEnumParamSchema (f :: * -> *) where - genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t + genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy 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 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -111,7 +111,7 @@ -- declareNamedSchema _ = do -- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double) -- return $ NamedSchema (Just \"Coord\") $ mempty --- & type_ .~ SwaggerObject +-- & type_ ?~ SwaggerObject -- & properties .~ -- [ (\"x\", doubleSchema) -- , (\"y\", doubleSchema) @@ -142,13 +142,13 @@ -- together with all used definitions. -- Note that the schema itself is included in definitions -- only if it is recursive (and thus needs its definition in scope). - declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema + declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => - proxy a -> Declare (Definitions Schema) NamedSchema + Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions -- | Convert a type into a schema and declare all used schema definitions. -declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema +declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema declareSchema = fmap _namedSchemaSchema . declareNamedSchema -- | Convert a type into an optionally named schema. @@ -162,7 +162,7 @@ -- Just "Day" -- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema) -- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}" -toNamedSchema :: ToSchema a => proxy a -> NamedSchema +toNamedSchema :: ToSchema a => Proxy a -> NamedSchema toNamedSchema = undeclare . declareNamedSchema -- | Get type's schema name according to its @'ToSchema'@ instance. @@ -172,7 +172,7 @@ -- -- >>> schemaName (Proxy :: Proxy UTCTime) -- Just "UTCTime" -schemaName :: ToSchema a => proxy a -> Maybe T.Text +schemaName :: ToSchema a => Proxy a -> Maybe T.Text schemaName = _namedSchemaName . toNamedSchema -- | Convert a type into a schema. @@ -182,7 +182,7 @@ -- -- >>> encode $ toSchema (Proxy :: Proxy [Day]) -- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}" -toSchema :: ToSchema a => proxy a -> Schema +toSchema :: ToSchema a => Proxy a -> Schema toSchema = _namedSchemaSchema . toNamedSchema -- | Convert a type into a referenced schema if possible. @@ -193,7 +193,7 @@ -- -- >>> encode $ toSchemaRef (Proxy :: Proxy Day) -- "{\"$ref\":\"#/definitions/Day\"}" -toSchemaRef :: ToSchema a => proxy a -> Referenced Schema +toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema toSchemaRef = undeclare . declareSchemaRef -- | Convert a type into a referenced schema if possible @@ -203,7 +203,7 @@ -- Schema definitions are typically declared for every referenced schema. -- If @'declareSchemaRef'@ returns a reference, a corresponding schema -- will be declared (regardless of whether it is recusive or not). -declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema) +declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema) declareSchemaRef proxy = do case toNamedSchema proxy of NamedSchema (Just name) schema -> do @@ -265,7 +265,7 @@ -- -- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema -- when inlining recursive schemas. -toInlinedSchema :: ToSchema a => proxy a -> Schema +toInlinedSchema :: ToSchema a => Proxy a -> Schema toInlinedSchema proxy = inlineAllSchemas defs schema where (defs, schema) = runDeclare (declareSchema proxy) mempty @@ -294,20 +294,20 @@ -- | 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 @@ 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 @@ (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 @@ 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 @@ 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) @@ -410,13 +410,13 @@ names = HashMap.keys o class GToSchema (f :: * -> *) where - gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema + gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema 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 @@ 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 @@ 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 @@ 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 OVERLAPPING_ ToSchema Object where declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty - & type_ .~ SwaggerObject + & type_ ?~ SwaggerObject & description ?~ "Arbitrary JSON object." & additionalProperties ?~ AdditionalPropertiesAllowed True @@ -593,26 +593,26 @@ -- -- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) -- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}" -toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema +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)) -- | Default generic named schema for @'Bounded'@, @'Integral'@ types. -genericToNamedSchemaBoundedIntegral :: forall a d f proxy. +genericToNamedSchemaBoundedIntegral :: forall a d f. ( Bounded a, Integral a , Generic a, Rep a ~ D1 d f, Datatype d) - => SchemaOptions -> proxy a -> NamedSchema + => SchemaOptions -> Proxy a -> NamedSchema genericToNamedSchemaBoundedIntegral opts proxy = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy) -- | Declare a named schema for a @newtype@ wrapper. -genericDeclareNamedSchemaNewtype :: forall proxy a d c s i inner. +genericDeclareNamedSchemaNewtype :: forall a d c s i inner. (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner)))) => SchemaOptions -- ^ How to derive the name. -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type. - -> proxy a + -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner) @@ -629,9 +629,9 @@ -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. -declareSchemaBoundedEnumKeyMapping :: forall map key value proxy. +declareSchemaBoundedEnumKeyMapping :: forall map key value. (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) - => proxy (map key value) -> Declare (Definitions Schema) Schema + => Proxy (map key value) -> Declare (Definitions Schema) Schema declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of ToJSONKeyText keyToText _ -> objectSchema keyToText ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)]) @@ -641,7 +641,7 @@ 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. @@ -657,46 +657,46 @@ -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. -toSchemaBoundedEnumKeyMapping :: forall map key value proxy. +toSchemaBoundedEnumKeyMapping :: forall map key value. (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) - => proxy (map key value) -> Schema + => Proxy (map key value) -> Schema toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping -- | A configurable generic @'Schema'@ creator. genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") => - SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema + SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema genericDeclareSchema = genericDeclareSchemaUnrestricted -- | A configurable generic @'NamedSchema'@ creator. -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@. -genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => - SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema +genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => + SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted -- | A configurable generic @'Schema'@ creator. -- -- Unlike 'genericDeclareSchema' also works for mixed sum types. -- Use with care since some Swagger tools do not support well schemas for mixed sum types. -genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema +genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy -- | A configurable generic @'NamedSchema'@ creator. -- -- Unlike 'genericDeclareNamedSchema' also works for mixed sum types. -- Use with care since some Swagger tools do not support well schemas for mixed sum types. -genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) => - SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema +genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) => + SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. -genericNameSchema :: forall a d f proxy. +genericNameSchema :: forall a d f. (Generic a, Rep a ~ D1 d f, Datatype d) - => SchemaOptions -> proxy a -> Schema -> NamedSchema + => SchemaOptions -> Proxy a -> Schema -> NamedSchema genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) -gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text +gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text gdatatypeSchemaName opts _ = case orig of (c:_) | isAlpha c && isUpper c -> Just (T.pack name) _ -> Nothing @@ -705,24 +705,23 @@ name = datatypeNameModifier opts orig -- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@. -paramSchemaToNamedSchema :: forall a d f proxy. - (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) - => SchemaOptions -> proxy a -> NamedSchema +paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) => + SchemaOptions -> Proxy a -> NamedSchema paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy) -- | Lift a plain @'ParamSchema'@ into a model @'Schema'@. -paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema -paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a) +paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema +paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy nullarySchema :: Schema nullarySchema = mempty - & type_ .~ SwaggerArray + & type_ ?~ SwaggerArray & items ?~ SwaggerItemsArray [] -gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema +gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty -gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema +gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where @@ -756,7 +755,7 @@ recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s -gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema) +gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema) gdeclareSchemaRef opts proxy = do case gtoNamedSchema opts proxy of NamedSchema (Just name) schema -> do @@ -787,12 +786,12 @@ 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]) @@ -820,7 +819,7 @@ where gdeclareNamedSchema = gdeclareNamedSumSchema -gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema +gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema gdeclareNamedSumSchema opts proxy s | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema) | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema @@ -829,29 +828,29 @@ (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema) toStringTag schema = mempty - & type_ .~ SwaggerString + & type_ ?~ SwaggerString & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) type AllNullary = All class GSumToSchema (f :: * -> *) where - gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema + gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g) -gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) => - Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema +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 where tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) -gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) => - SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema +gsumConToSchema :: (GToSchema (C1 c f), Constructor c) => + SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema gsumConToSchema opts proxy schema = do ref <- gdeclareSchemaRef opts proxy return $ gsumConToSchemaWith ref opts proxy schema diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs --- 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.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 +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 @@ 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,25 +333,93 @@ 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 - (SwaggerNull, Null) -> valid - (SwaggerBoolean, Bool _) -> valid - (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) - (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) - (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 + (Just SwaggerNull, Null) -> valid + (Just SwaggerBoolean, Bool _) -> valid + (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) + (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) + (Just SwaggerString, String s) -> sub_ paramSchema (validateString s) + (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) + (Just SwaggerObject, Object o) -> validateObject o + (Nothing, Null) -> valid + (Nothing, Bool _) -> valid + -- Number by default + (Nothing, Number n) -> sub_ paramSchema (validateNumber n) + (Nothing, String s) -> sub_ paramSchema (validateString s) + (Nothing, Array xs) -> sub_ paramSchema (validateArray xs) + (Nothing, Object o) -> validateObject o + param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param validateParamSchemaType :: Value -> Validation (ParamSchema t) () validateParamSchemaType value = withSchema $ \sch -> 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 + (Just SwaggerBoolean, Bool _) -> valid + (Just SwaggerInteger, Number n) -> validateInteger n + (Just SwaggerNumber, Number n) -> validateNumber n + (Just SwaggerString, String s) -> validateString s + (Just SwaggerArray, Array xs) -> validateArray xs + (Nothing, Bool _) -> valid + -- Number by default + (Nothing, Number n) -> validateNumber n + (Nothing, String s) -> validateString s + (Nothing, Array xs) -> validateArray xs (t, _) -> invalid $ "expected JSON value of type " ++ show t + param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param +showType :: (Maybe (SwaggerType t), Value) -> String +showType (Just type_, _) = show type_ +showType (Nothing, Null) = "SwaggerNull" +showType (Nothing, Bool _) = "SwaggerBoolean" +showType (Nothing, Number _) = "SwaggerNumber" +showType (Nothing, String _) = "SwaggerString" +showType (Nothing, Array _) = "SwaggerArray" +showType (Nothing, Object _) = "SwaggerObject" diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -99,10 +99,10 @@ 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/Operation.hs b/src/Data/Swagger/Operation.hs --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -37,6 +37,7 @@ import Data.Data.Lens import Data.List.Compat import Data.Maybe (mapMaybe) +import Data.Proxy import qualified Data.Set as Set import Data.Swagger.Declare @@ -45,6 +46,7 @@ import Data.Swagger.Schema import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import qualified Data.HashSet.InsOrd as InsOrdHS -- $setup -- >>> import Data.Aeson @@ -110,15 +112,15 @@ -- list of tags. applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger applyTagsFor ops ts swag = swag - & ops . tags %~ (<> Set.fromList (map _tagName ts)) - & tags %~ (<> Set.fromList ts) + & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts)) + & tags %~ (<> InsOrdHS.fromList ts) -- | Construct a response with @'Schema'@ while declaring all -- necessary schema definitions. -- -- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty -- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]" -declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response +declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response declareResponse proxy = do s <- declareSchemaRef proxy return (mempty & schema ?~ s) @@ -189,4 +191,3 @@ Nothing -> new -- response name can't be dereferenced, replacing with new response combine (Just (Inline old)) = f old new combine Nothing = new - diff --git a/src/Data/Swagger/Schema/Generator.hs b/src/Data/Swagger/Schema/Generator.hs --- a/src/Data/Swagger/Schema/Generator.hs +++ b/src/Data/Swagger/Schema/Generator.hs @@ -4,47 +4,55 @@ 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 +-- | Note: 'schemaGen' may 'error', if schema type is not specified, +-- and cannot be inferred. schemaGen :: Definitions Schema -> Schema -> Gen Value 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) + -- Gen is not MonadFail + _ -> error "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 +67,14 @@ 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/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: swagger2 -version: 2.3.1.1 +version: 2.4 synopsis: Swagger 2.0 data model category: Web, Swagger @@ -29,7 +29,8 @@ || ==8.0.2 || ==8.2.2 || ==8.4.4 - || ==8.6.2 + || ==8.6.5 + || ==8.8.1 custom-setup setup-depends: @@ -64,7 +65,7 @@ , bytestring >=0.10.4.0 && <0.11 , containers >=0.5.5.1 && <0.7 , template-haskell >=2.9.0.0 && <2.15 - , time >=1.4.2 && <1.9 + , time >=1.4.2 && <1.10 , transformers >=0.3.0.0 && <0.6 build-depends: @@ -77,18 +78,18 @@ , aeson >=1.4.2.0 && <1.5 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint , cookie >=0.4.3 && <0.5 - , generics-sop >=0.3.2.0 && <0.5 - , hashable >=1.2.7.0 && <1.3 - , http-media >=0.7.1.2 && <0.8 - , insert-ordered-containers >=0.2.1.0 && <0.3 + , generics-sop >=0.3.2.0 && <0.6 + , hashable >=1.2.7.0 && <1.4 + , http-media >=0.7.1.2 && <0.9 + , insert-ordered-containers >=0.2.2 && <0.3 , lens >=4.16.1 && <4.18 - , network >=2.6.3.5 && <3.1 + , network >=2.6.3.5 && <3.2 , scientific >=0.3.6.2 && <0.4 , transformers-compat >=0.3 && <0.7 , unordered-containers >=0.2.9.0 && <0.3 , uuid-types >=1.0.3 && <1.1 , vector >=0.12.0.1 && <0.13 - , QuickCheck >=2.10.1 && <2.13 + , QuickCheck >=2.10.1 && <2.14 default-language: Haskell2010 @@ -115,12 +116,12 @@ , time , unordered-containers , vector + , QuickCheck -- test-suite only dependencies build-depends: hspec >=2.5.5 && <2.8 , HUnit >=1.6.0.0 && <1.7 - , QuickCheck >=2.11.3 && <2.13 , quickcheck-instances >=0.3.19 && <0.14 , utf8-string >=1.0.1.1 && <1.1 diff --git a/test/Data/Swagger/Schema/GeneratorSpec.hs b/test/Data/Swagger/Schema/GeneratorSpec.hs --- a/test/Data/Swagger/Schema/GeneratorSpec.hs +++ b/test/Data/Swagger/Schema/GeneratorSpec.hs @@ -103,7 +103,7 @@ instance ToSchema WrongType where declareNamedSchema _ = return . NamedSchema (Just "WrongType") $ mempty - & type_ .~ SwaggerObject + & type_ ?~ SwaggerObject data MissingRequired = MissingRequired @@ -123,7 +123,7 @@ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool) return . NamedSchema (Just "MissingRequired") $ mempty - & type_ .~ SwaggerObject + & type_ ?~ SwaggerObject & properties .~ [("propA", stringSchema) ,("propB", boolSchema) ] @@ -145,7 +145,7 @@ stringSchema <- declareSchemaRef (Proxy :: Proxy String) return . NamedSchema (Just "MissingProperty") $ mempty - & type_ .~ SwaggerObject + & type_ ?~ SwaggerObject & properties .~ [("propC", stringSchema)] & required .~ ["propC"] @@ -163,6 +163,6 @@ 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 --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -248,7 +248,7 @@ 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 --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -12,7 +12,7 @@ import Data.Aeson import Data.Aeson.QQ.Simple import Data.HashMap.Strict (HashMap) -import qualified Data.Set as Set +import qualified Data.HashSet.InsOrd as InsOrdHS import Data.Text (Text) import Data.Swagger @@ -127,7 +127,7 @@ operationExample :: Operation operationExample = mempty - & tags .~ Set.fromList ["pet"] + & tags .~ InsOrdHS.fromList ["pet"] & summary ?~ "Updates a pet in the store with form data" & description ?~ "" & operationId ?~ "updatePetWithForm" @@ -158,7 +158,7 @@ stringSchema :: ParamLocation -> ParamOtherSchema stringSchema loc = mempty & in_ .~ loc - & type_ .~ SwaggerString + & type_ ?~ SwaggerString operationExampleJSON :: Value operationExampleJSON = [aesonQQ| @@ -224,7 +224,7 @@ schemaPrimitiveExample :: Schema schemaPrimitiveExample = mempty - & type_ .~ SwaggerString + & type_ ?~ SwaggerString & format ?~ "email" schemaPrimitiveExampleJSON :: Value @@ -237,14 +237,14 @@ 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 @@ 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 @@ schemaAdditionalExample :: Schema schemaAdditionalExample = mempty - & type_ .~ SwaggerObject + & type_ ?~ SwaggerObject & additionalProperties ?~ AdditionalPropertiesAllowed True schemaAdditionalExampleJSON :: Value @@ -300,13 +300,13 @@ 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 @@ 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 @@ & required ?~ True & schema .~ ParamOther (mempty & in_ .~ ParamQuery - & type_ .~ SwaggerInteger + & type_ ?~ SwaggerInteger & format ?~ "int32" )) , ("limitParam", mempty & name .~ "limit" @@ -409,7 +409,7 @@ & required ?~ True & schema .~ ParamOther (mempty & in_ .~ ParamQuery - & type_ .~ SwaggerInteger + & type_ ?~ SwaggerInteger & format ?~ "int32" )) ] paramsDefinitionExampleJSON :: Value @@ -510,7 +510,7 @@ & at 200 ?~ Inline (mempty & description .~ "OK" & schema ?~ Inline (mempty - & type_ .~ SwaggerObject + & type_ ?~ SwaggerObject & example ?~ [aesonQQ| { "created": 100, @@ -519,9 +519,9 @@ & 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,8 +530,8 @@ & description ?~ "TodoId param" & schema .~ ParamOther (mempty & in_ .~ ParamPath - & type_ .~ SwaggerString ) ] - & tags .~ Set.fromList [ "todo" ] )) + & type_ ?~ SwaggerString ) ] + & tags .~ InsOrdHS.fromList [ "todo" ] )) swaggerExampleJSON :: Value swaggerExampleJSON = [aesonQQ| @@ -1632,14 +1632,14 @@ 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