swagger2 2.3.1.1 → 2.4
raw patch · 15 files changed
+334/−220 lines, 15 filesdep ~QuickCheckdep ~basedep ~base-compat-batteries
Dependency ranges changed: QuickCheck, base, base-compat-batteries, generics-sop, hashable, insert-ordered-containers, lens, network, template-haskell, time
Files
- CHANGELOG.md +13/−0
- examples/hackage.hs +1/−1
- src/Data/Swagger.hs +3/−3
- src/Data/Swagger/Internal.hs +12/−6
- src/Data/Swagger/Internal/AesonUtils.hs +16/−2
- src/Data/Swagger/Internal/ParamSchema.hs +27/−27
- src/Data/Swagger/Internal/Schema.hs +69/−70
- src/Data/Swagger/Internal/Schema/Validation.hs +117/−45
- src/Data/Swagger/Lens.hs +4/−4
- src/Data/Swagger/Operation.hs +5/−4
- src/Data/Swagger/Schema/Generator.hs +22/−14
- swagger2.cabal +11/−10
- test/Data/Swagger/Schema/GeneratorSpec.hs +4/−4
- test/Data/Swagger/Schema/ValidationSpec.hs +1/−1
- test/Data/SwaggerSpec.hs +29/−29
CHANGELOG.md view
@@ -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
examples/hackage.hs view
@@ -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 )
src/Data/Swagger.hs view
@@ -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'@
src/Data/Swagger/Internal.hs view
@@ -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
src/Data/Swagger/Internal/AesonUtils.hs view
@@ -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"
src/Data/Swagger/Internal/ParamSchema.hs view
@@ -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)))
src/Data/Swagger/Internal/Schema.hs view
@@ -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
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -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"
src/Data/Swagger/Lens.hs view
@@ -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_
src/Data/Swagger/Operation.hs view
@@ -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-
src/Data/Swagger/Schema/Generator.hs view
@@ -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
swagger2.cabal view
@@ -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
test/Data/Swagger/Schema/GeneratorSpec.hs view
@@ -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"]
test/Data/Swagger/Schema/ValidationSpec.hs view
@@ -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
test/Data/SwaggerSpec.hs view
@@ -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