git.iko.soy/typeable/openapi3
on master help sign in
Make schema type optional and infer it when validating
commit7d8bbfc384b1609288a3ae1442e2ab156b164714 authorNickolay Kudasov <nickolay.kudasov@gmail.com> dateThu 23 Aug 2018, 11:26 (8 years ago) parent0d54ac1
10 files changed+150−110
compare with master
unifiedsplit
src/Data/Swagger.hs+3−3 src/Data/Swagger/Internal.hs+1−1 src/Data/Swagger/Internal/ParamSchema.hs+21−21 src/Data/Swagger/Internal/Schema.hs+28−28 src/Data/Swagger/Internal/Schema/Validation.hs+43−8 src/Data/Swagger/Lens.hs+4−4 src/Data/Swagger/Schema/Generator.hs+19−14 test/Data/Swagger/Schema/GeneratorSpec.hs+4−4 test/Data/Swagger/Schema/ValidationSpec.hs+1−1 test/Data/SwaggerSpec.hs+26−26
src/Data/Swagger.hs+3−3
@@ -181,7 +181,7 @@ import Data.Swagger.Internal
181181--
182182-- >>> :{
183183-- encode $ (mempty :: Swagger)
184−-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
184+-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
185185-- & paths .~
186186-- [ ("/user", mempty & get ?~ (mempty
187187-- & produces ?~ MimeList ["application/json"]
@@ -204,7 +204,7 @@ import Data.Swagger.Internal
204204-- "{\"description\":\"No content\"}"
205205-- >>> :{
206206-- encode $ (mempty :: Schema)
207−-- & type_ .~ SwaggerBoolean
207+-- & type_ ?~ SwaggerBoolean
208208-- & description ?~ "To be or not to be"
209209-- :}
210210-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
@@ -213,7 +213,7 @@ import Data.Swagger.Internal
213213-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
214214-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
215215--
216−-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
216+-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
217217-- "{\"type\":\"number\"}"
218218--
219219-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
src/Data/Swagger/Internal.hs+1−1
@@ -593,7 +593,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
593593 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
594594 _paramSchemaDefault :: Maybe Value
595595
596− , _paramSchemaType :: SwaggerType t
596+ , _paramSchemaType :: Maybe (SwaggerType t)
597597 , _paramSchemaFormat :: Maybe Format
598598 , _paramSchemaItems :: Maybe (SwaggerItems t)
599599 , _paramSchemaMaximum :: Maybe Scientific
src/Data/Swagger/Internal/ParamSchema.hs+21−21
@@ -59,20 +59,20 @@ import GHC.TypeLits (TypeError, ErrorMessage(..))
5959-- | Default schema for binary data (any sequence of octets).
6060binaryParamSchema :: ParamSchema t
6161binaryParamSchema = mempty
62− & type_ .~ SwaggerString
62+ & type_ ?~ SwaggerString
6363 & format ?~ "binary"
6464
6565-- | Default schema for binary data (base64 encoded).
6666byteParamSchema :: ParamSchema t
6767byteParamSchema = mempty
68− & type_ .~ SwaggerString
68+ & type_ ?~ SwaggerString
6969 & format ?~ "byte"
7070
7171-- | Default schema for password string.
7272-- @"password"@ format is used to hint UIs the input needs to be obscured.
7373passwordParamSchema :: ParamSchema t
7474passwordParamSchema = mempty
75− & type_ .~ SwaggerString
75+ & type_ ?~ SwaggerString
7676 & format ?~ "password"
7777
7878-- | Convert a type into a plain @'ParamSchema'@.
@@ -88,7 +88,7 @@ passwordParamSchema = mempty
8888--
8989-- instance ToParamSchema Direction where
9090-- toParamSchema _ = mempty
91−-- & type_ .~ SwaggerString
91+-- & type_ ?~ SwaggerString
9292-- & enum_ ?~ [ \"Up\", \"Down\" ]
9393-- @
9494--
@@ -120,17 +120,17 @@ class ToParamSchema a where
120120 toParamSchema = genericToParamSchema defaultSchemaOptions
121121
122122instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ .~ SwaggerString
123+ toParamSchema _ = mempty & type_ ?~ SwaggerString
124124
125125instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ .~ SwaggerBoolean
126+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
127127
128128instance ToParamSchema Integer where
129− toParamSchema _ = mempty & type_ .~ SwaggerInteger
129+ toParamSchema _ = mempty & type_ ?~ SwaggerInteger
130130
131131instance ToParamSchema Natural where
132132 toParamSchema _ = mempty
133− & type_ .~ SwaggerInteger
133+ & type_ ?~ SwaggerInteger
134134 & minimum_ ?~ 0
135135 & exclusiveMinimum ?~ False
136136
@@ -156,37 +156,37 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
156156-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157157toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
158158toParamSchemaBoundedIntegral _ = mempty
159− & type_ .~ SwaggerInteger
159+ & type_ ?~ SwaggerInteger
160160 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161161 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162162
163163instance ToParamSchema Char where
164164 toParamSchema _ = mempty
165− & type_ .~ SwaggerString
165+ & type_ ?~ SwaggerString
166166 & maxLength ?~ 1
167167 & minLength ?~ 1
168168
169169instance ToParamSchema Scientific where
170− toParamSchema _ = mempty & type_ .~ SwaggerNumber
170+ toParamSchema _ = mempty & type_ ?~ SwaggerNumber
171171
172172instance HasResolution a => ToParamSchema (Fixed a) where
173173 toParamSchema _ = mempty
174− & type_ .~ SwaggerNumber
174+ & type_ ?~ SwaggerNumber
175175 & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
176176
177177instance ToParamSchema Double where
178178 toParamSchema _ = mempty
179− & type_ .~ SwaggerNumber
179+ & type_ ?~ SwaggerNumber
180180 & format ?~ "double"
181181
182182instance ToParamSchema Float where
183183 toParamSchema _ = mempty
184− & type_ .~ SwaggerNumber
184+ & type_ ?~ SwaggerNumber
185185 & format ?~ "float"
186186
187187timeParamSchema :: String -> ParamSchema t
188188timeParamSchema fmt = mempty
189− & type_ .~ SwaggerString
189+ & type_ ?~ SwaggerString
190190 & format ?~ T.pack fmt
191191
192192-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -222,12 +222,12 @@ instance ToParamSchema TL.Text where
222222
223223instance ToParamSchema Version where
224224 toParamSchema _ = mempty
225− & type_ .~ SwaggerString
225+ & type_ ?~ SwaggerString
226226 & pattern ?~ "^\\d+(\\.\\d+)*$"
227227
228228instance ToParamSchema SetCookie where
229229 toParamSchema _ = mempty
230− & type_ .~ SwaggerString
230+ & type_ ?~ SwaggerString
231231
232232
233233#if __GLASGOW_HASKELL__ < 800
@@ -254,7 +254,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t
254254
255255instance ToParamSchema a => ToParamSchema [a] where
256256 toParamSchema _ = mempty
257− & type_ .~ SwaggerArray
257+ & type_ ?~ SwaggerArray
258258 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
259259
260260instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -274,12 +274,12 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
274274-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
275275instance ToParamSchema () where
276276 toParamSchema _ = mempty
277− & type_ .~ SwaggerString
277+ & type_ ?~ SwaggerString
278278 & enum_ ?~ ["_"]
279279
280280instance ToParamSchema UUID where
281281 toParamSchema _ = mempty
282− & type_ .~ SwaggerString
282+ & type_ ?~ SwaggerString
283283 & format ?~ "uuid"
284284
285285-- | A configurable generic @'ParamSchema'@ creator.
@@ -317,7 +317,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g)
317317
318318instance Constructor c => GEnumParamSchema (C1 c U1) where
319319 genumParamSchema opts _ s = s
320− & type_ .~ SwaggerString
320+ & type_ ?~ SwaggerString
321321 & enum_ %~ addEnumValue tag
322322 where
323323 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
src/Data/Swagger/Internal/Schema.hs+28−28
@@ -111,7 +111,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
111111-- declareNamedSchema _ = do
112112-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113113-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ .~ SwaggerObject
114+-- & type_ ?~ SwaggerObject
115115-- & properties .~
116116-- [ (\"x\", doubleSchema)
117117-- , (\"y\", doubleSchema)
@@ -294,20 +294,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
294294-- | Default schema for binary data (any sequence of octets).
295295binarySchema :: Schema
296296binarySchema = mempty
297− & type_ .~ SwaggerString
297+ & type_ ?~ SwaggerString
298298 & format ?~ "binary"
299299
300300-- | Default schema for binary data (base64 encoded).
301301byteSchema :: Schema
302302byteSchema = mempty
303− & type_ .~ SwaggerString
303+ & type_ ?~ SwaggerString
304304 & format ?~ "byte"
305305
306306-- | Default schema for password string.
307307-- @"password"@ format is used to hint UIs the input needs to be obscured.
308308passwordSchema :: Schema
309309passwordSchema = mempty
310− & type_ .~ SwaggerString
310+ & type_ ?~ SwaggerString
311311 & format ?~ "password"
312312
313313-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -333,12 +333,12 @@ sketchSchema = sketch . toJSON
333333 sketch js@(Bool _) = go js
334334 sketch js = go js & example ?~ js
335335
336− go Null = mempty & type_ .~ SwaggerNull
337− go (Bool _) = mempty & type_ .~ SwaggerBoolean
338− go (String _) = mempty & type_ .~ SwaggerString
339− go (Number _) = mempty & type_ .~ SwaggerNumber
336+ go Null = mempty & type_ ?~ SwaggerNull
337+ go (Bool _) = mempty & type_ ?~ SwaggerBoolean
338+ go (String _) = mempty & type_ ?~ SwaggerString
339+ go (Number _) = mempty & type_ ?~ SwaggerNumber
340340 go (Array xs) = mempty
341− & type_ .~ SwaggerArray
341+ & type_ ?~ SwaggerArray
342342 & items ?~ case ischema of
343343 Just s -> SwaggerItemsObject (Inline s)
344344 _ -> SwaggerItemsArray (map Inline ys)
@@ -350,7 +350,7 @@ sketchSchema = sketch . toJSON
350350 (z:_) | allSame -> Just z
351351 _ -> Nothing
352352 go (Object o) = mempty
353− & type_ .~ SwaggerObject
353+ & type_ ?~ SwaggerObject
354354 & required .~ HashMap.keys o
355355 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
356356
@@ -373,24 +373,24 @@ sketchSchema = sketch . toJSON
373373sketchStrictSchema :: ToJSON a => a -> Schema
374374sketchStrictSchema = go . toJSON
375375 where
376− go Null = mempty & type_ .~ SwaggerNull
376+ go Null = mempty & type_ ?~ SwaggerNull
377377 go js@(Bool _) = mempty
378− & type_ .~ SwaggerBoolean
378+ & type_ ?~ SwaggerBoolean
379379 & enum_ ?~ [js]
380380 go js@(String s) = mempty
381− & type_ .~ SwaggerString
381+ & type_ ?~ SwaggerString
382382 & maxLength ?~ fromIntegral (T.length s)
383383 & minLength ?~ fromIntegral (T.length s)
384384 & pattern ?~ s
385385 & enum_ ?~ [js]
386386 go js@(Number n) = mempty
387− & type_ .~ SwaggerNumber
387+ & type_ ?~ SwaggerNumber
388388 & maximum_ ?~ n
389389 & minimum_ ?~ n
390390 & multipleOf ?~ n
391391 & enum_ ?~ [js]
392392 go js@(Array xs) = mempty
393− & type_ .~ SwaggerArray
393+ & type_ ?~ SwaggerArray
394394 & maxItems ?~ fromIntegral sz
395395 & minItems ?~ fromIntegral sz
396396 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -400,7 +400,7 @@ sketchStrictSchema = go . toJSON
400400 sz = length xs
401401 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
402402 go js@(Object o) = mempty
403− & type_ .~ SwaggerObject
403+ & type_ ?~ SwaggerObject
404404 & required .~ names
405405 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
406406 & maxProperties ?~ fromIntegral (length names)
@@ -416,7 +416,7 @@ instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
416416 declareNamedSchema _ = do
417417 ref <- declareSchemaRef (Proxy :: Proxy a)
418418 return $ unnamed $ mempty
419− & type_ .~ SwaggerArray
419+ & type_ ?~ SwaggerArray
420420 & items ?~ SwaggerItemsObject ref
421421
422422instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
@@ -466,7 +466,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
466466
467467timeSchema :: T.Text -> Schema
468468timeSchema fmt = mempty
469− & type_ .~ SwaggerString
469+ & type_ ?~ SwaggerString
470470 & format ?~ fmt
471471
472472-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -528,7 +528,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
528528 declareObjectMapSchema = do
529529 schema <- declareSchemaRef (Proxy :: Proxy v)
530530 return $ unnamed $ mempty
531− & type_ .~ SwaggerObject
531+ & type_ ?~ SwaggerObject
532532 & additionalProperties ?~ AdditionalPropertiesSchema schema
533533
534534instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
@@ -540,7 +540,7 @@ instance ToSchema a => ToSchema (Map String a) where
540540 declareNamedSchema _ = do
541541 schema <- declareSchemaRef (Proxy :: Proxy a)
542542 return $ unnamed $ mempty
543− & type_ .~ SwaggerObject
543+ & type_ ?~ SwaggerObject
544544 & additionalProperties ?~ schema
545545
546546instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -554,7 +554,7 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =
554554
555555instance OVERLAPPING_ ToSchema Object where
556556 declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
557− & type_ .~ SwaggerObject
557+ & type_ ?~ SwaggerObject
558558 & description ?~ "Arbitrary JSON object."
559559 & additionalProperties ?~ AdditionalPropertiesAllowed True
560560
@@ -595,7 +595,7 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar
595595-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
596596toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
597597toSchemaBoundedIntegral _ = mempty
598− & type_ .~ SwaggerInteger
598+ & type_ ?~ SwaggerInteger
599599 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
600600 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
601601
@@ -641,7 +641,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
641641 let allKeys = [minBound..maxBound :: key]
642642 mkPair k = (keyToText k, valueRef)
643643 return $ mempty
644− & type_ .~ SwaggerObject
644+ & type_ ?~ SwaggerObject
645645 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
646646
647647-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
@@ -715,7 +715,7 @@ paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
715715
716716nullarySchema :: Schema
717717nullarySchema = mempty
718− & type_ .~ SwaggerArray
718+ & type_ ?~ SwaggerArray
719719 & items ?~ SwaggerItemsArray []
720720
721721gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
@@ -786,12 +786,12 @@ withFieldSchema opts _ isRequiredField schema = do
786786 return $
787787 if T.null fname
788788 then schema
789− & type_ .~ SwaggerArray
789+ & type_ ?~ SwaggerArray
790790 & items %~ appendItem ref
791791 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
792792 & minItems %~ Just . maybe 1 (+1) -- increment minItems
793793 else schema
794− & type_ .~ SwaggerObject
794+ & type_ ?~ SwaggerObject
795795 & properties . at fname ?~ ref
796796 & if isRequiredField
797797 then required %~ (++ [fname])
@@ -828,7 +828,7 @@ gdeclareNamedSumSchema opts proxy s
828828 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
829829
830830 toStringTag schema = mempty
831− & type_ .~ SwaggerString
831+ & type_ ?~ SwaggerString
832832 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
833833
834834type AllNullary = All
@@ -842,7 +842,7 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
842842gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
843843 Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
844844gsumConToSchemaWith ref opts _ schema = schema
845− & type_ .~ SwaggerObject
845+ & type_ ?~ SwaggerObject
846846 & properties . at tag ?~ ref
847847 & maxProperties ?~ 1
848848 & minProperties ?~ 1
src/Data/Swagger/Internal/Schema/Validation.hs+43−8
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -Wall #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE DeriveFunctor #-}
34{-# LANGUAGE FlexibleInstances #-}
@@ -32,6 +33,7 @@ import Data.HashMap.Strict (HashMap)
3233import qualified Data.HashMap.Strict as HashMap
3334import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
3435import qualified "unordered-containers" Data.HashSet as HashSet
36+import Data.List (intercalate)
3537import Data.Monoid
3638import Data.Proxy
3739import Data.Scientific (Scientific, isInteger)
@@ -322,8 +324,8 @@ validateObject o = withSchema $ \sch ->
322324 validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
323325
324326 unknownProperty :: Text -> Validation s a
325− unknownProperty name = invalid $
326− "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema"
327+ unknownProperty pname = invalid $
328+ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"
327329
328330validateEnum :: Value -> Validation (ParamSchema t) ()
329331validateEnum value = do
@@ -333,8 +335,10 @@ validateEnum value = do
333335
334336-- | Infer schema type based on used properties.
335337--
336−-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
337−-- Just [SwaggerString]
338+-- This is like 'inferParamSchemaTypes', but also works for objects:
339+--
340+-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
341+-- Just [SwaggerObject]
338342inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]
339343inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++
340344 [ SwaggerObject | any ($ sch)
@@ -348,6 +352,15 @@ inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++
348352--
349353-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
350354-- Just [SwaggerString]
355+--
356+-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
357+-- Just [SwaggerArray]
358+--
359+-- From numeric properties 'SwaggerInteger' type is inferred.
360+-- If you want 'SwaggerNumber' instead, you must specify it explicitly.
361+--
362+-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
363+-- Just [SwaggerInteger]
351364inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]
352365inferParamSchemaTypes sch = concat
353366 [ [ SwaggerArray | any ($ sch)
@@ -369,7 +382,18 @@ inferParamSchemaTypes sch = concat
369382
370383validateSchemaType :: Value -> Validation Schema ()
371384validateSchemaType value = withSchema $ \sch ->
372− case (sch ^. type_, value) of
385+ case sch ^. type_ of
386+ Just explicitType -> validateSchemaTypeAs explicitType value
387+ Nothing ->
388+ case inferSchemaTypes sch of
389+ [t] -> validateSchemaTypeAs t value
390+ [] -> invalid $ "unable to infer type for schema, please provide type explicitly"
391+ ts -> invalid $ "unable to infer type for schema, possible candidates: " ++ intercalate ", " (map show ts)
392+
393+validateSchemaTypeAs
394+ :: SwaggerType 'SwaggerKindSchema -> Value -> Validation Schema ()
395+validateSchemaTypeAs t value =
396+ case (t, value) of
373397 (SwaggerNull, Null) -> valid
374398 (SwaggerBoolean, Bool _) -> valid
375399 (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
@@ -377,15 +401,26 @@ validateSchemaType value = withSchema $ \sch ->
377401 (SwaggerString, String s) -> sub_ paramSchema (validateString s)
378402 (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
379403 (SwaggerObject, Object o) -> validateObject o
380− (t, _) -> invalid $ "expected JSON value of type " ++ show t
404+ _ -> invalid $ "expected JSON value of type " ++ show t
381405
382406validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
383407validateParamSchemaType value = withSchema $ \sch ->
384− case (sch ^. type_, value) of
408+ case sch ^. type_ of
409+ Just explicitType -> validateParamSchemaTypeAs explicitType value
410+ Nothing ->
411+ case inferParamSchemaTypes sch of
412+ [t] -> validateParamSchemaTypeAs t value
413+ [] -> invalid $ "unable to infer type for schema, please provide type explicitly"
414+ ts -> invalid $ "unable to infer type for schema, possible candidates: " ++ intercalate ", " (map show ts)
415+
416+validateParamSchemaTypeAs
417+ :: SwaggerType t -> Value -> Validation (ParamSchema t) ()
418+validateParamSchemaTypeAs t value =
419+ case (t, value) of
385420 (SwaggerBoolean, Bool _) -> valid
386421 (SwaggerInteger, Number n) -> validateInteger n
387422 (SwaggerNumber, Number n) -> validateNumber n
388423 (SwaggerString, String s) -> validateString s
389424 (SwaggerArray, Array xs) -> validateArray xs
390− (t, _) -> invalid $ "expected JSON value of type " ++ show t
425+ _ -> invalid $ "expected JSON value of type " ++ show t
391426
src/Data/Swagger/Lens.hs+4−4
@@ -99,10 +99,10 @@ instance At Operation where at n = responses . at n
9999instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
100100
101101-- HasType instances
102−instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_
103−instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_
104−instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_
105−instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_
102+instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_
103+instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
104+instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
105+instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_
106106
107107-- HasDefault instances
108108instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
src/Data/Swagger/Schema/Generator.hs+19−14
@@ -4,24 +4,25 @@
44
55module Data.Swagger.Schema.Generator where
66
7−import Prelude ()
7+import Prelude ()
88import Prelude.Compat
99
1010import Control.Lens.Operators
11−import Control.Monad (filterM)
11+import Control.Monad (filterM)
1212import Data.Aeson
1313import Data.Aeson.Types
14−import qualified Data.HashMap.Strict.InsOrd as M
14+import qualified Data.HashMap.Strict.InsOrd as M
1515import Data.Maybe
1616import Data.Maybe
1717import Data.Proxy
1818import Data.Scientific
19−import qualified Data.Set as S
19+import qualified Data.Set as S
2020import Data.Swagger
2121import Data.Swagger.Declare
22−import qualified Data.Text as T
23−import qualified Data.Vector as V
24−import Test.QuickCheck (arbitrary)
22+import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)
23+import qualified Data.Text as T
24+import qualified Data.Vector as V
25+import Test.QuickCheck (arbitrary)
2526import Test.QuickCheck.Gen
2627import Test.QuickCheck.Property
2728
@@ -30,21 +31,25 @@ schemaGen _ schema
3031 | Just cases <- schema ^. paramSchema . enum_ = elements cases
3132schemaGen defns schema =
3233 case schema ^. type_ of
33− SwaggerBoolean -> Bool <$> elements [True, False]
34− SwaggerNull -> pure Null
35− SwaggerNumber
34+ Nothing ->
35+ case inferSchemaTypes schema of
36+ [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
37+ _ -> fail "unable to infer schema type"
38+ Just SwaggerBoolean -> Bool <$> elements [True, False]
39+ Just SwaggerNull -> pure Null
40+ Just SwaggerNumber
3641 | Just min <- schema ^. minimum_
3742 , Just max <- schema ^. maximum_ ->
3843 Number . fromFloatDigits <$>
3944 choose (toRealFloat min, toRealFloat max :: Double)
4045 | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
41− SwaggerInteger
46+ Just SwaggerInteger
4247 | Just min <- schema ^. minimum_
4348 , Just max <- schema ^. maximum_ ->
4449 Number . fromInteger <$>
4550 choose (truncate min, truncate max)
4651 | otherwise -> Number . fromInteger <$> arbitrary
47− SwaggerArray
52+ Just SwaggerArray
4853 | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
4954 | Just items <- schema ^. items ->
5055 case items of
@@ -59,14 +64,14 @@ schemaGen defns schema =
5964 SwaggerItemsArray refs ->
6065 let itemGens = schemaGen defns . dereference defns <$> refs
6166 in fmap (Array . V.fromList) $ sequence itemGens
62− SwaggerString -> do
67+ Just SwaggerString -> do
6368 size <- getSize
6469 let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
6570 let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
6671 length <- choose (minLength', max minLength' maxLength')
6772 str <- vectorOf length arbitrary
6873 return . String $ T.pack str
69− SwaggerObject -> do
74+ Just SwaggerObject -> do
7075 size <- getSize
7176 let props = dereference defns <$> schema ^. properties
7277 reqKeys = S.fromList $ schema ^. required
test/Data/Swagger/Schema/GeneratorSpec.hs+4−4
@@ -103,7 +103,7 @@ instance FromJSON WrongType where
103103instance ToSchema WrongType where
104104 declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105105 mempty
106− & type_ .~ SwaggerObject
106+ & type_ ?~ SwaggerObject
107107
108108
109109data MissingRequired = MissingRequired
@@ -123,7 +123,7 @@ instance ToSchema MissingRequired where
123123 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124124 return . NamedSchema (Just "MissingRequired") $
125125 mempty
126− & type_ .~ SwaggerObject
126+ & type_ ?~ SwaggerObject
127127 & properties .~ [("propA", stringSchema)
128128 ,("propB", boolSchema)
129129 ]
@@ -145,7 +145,7 @@ instance ToSchema MissingProperty where
145145 stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146146 return . NamedSchema (Just "MissingProperty") $
147147 mempty
148− & type_ .~ SwaggerObject
148+ & type_ ?~ SwaggerObject
149149 & properties .~ [("propC", stringSchema)]
150150 & required .~ ["propC"]
151151
@@ -163,6 +163,6 @@ instance ToSchema WrongPropType where
163163 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164164 return . NamedSchema (Just "WrongPropType") $
165165 mempty
166− & type_ .~ SwaggerObject
166+ & type_ ?~ SwaggerObject
167167 & properties .~ [("propE", boolSchema)]
168168 & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hs+1−1
@@ -248,7 +248,7 @@ instance ToJSON FreeForm where
248248
249249instance ToSchema FreeForm where
250250 declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
251− & type_ .~ SwaggerObject
251+ & type_ ?~ SwaggerObject
252252 & additionalProperties ?~ AdditionalPropertiesAllowed True
253253
254254instance Arbitrary FreeForm where
test/Data/SwaggerSpec.hs+26−26
@@ -158,7 +158,7 @@ operationExample = mempty
158158 stringSchema :: ParamLocation -> ParamOtherSchema
159159 stringSchema loc = mempty
160160 & in_ .~ loc
161− & type_ .~ SwaggerString
161+ & type_ ?~ SwaggerString
162162
163163operationExampleJSON :: Value
164164operationExampleJSON = [aesonQQ|
@@ -224,7 +224,7 @@ operationExampleJSON = [aesonQQ|
224224
225225schemaPrimitiveExample :: Schema
226226schemaPrimitiveExample = mempty
227− & type_ .~ SwaggerString
227+ & type_ ?~ SwaggerString
228228 & format ?~ "email"
229229
230230schemaPrimitiveExampleJSON :: Value
@@ -237,14 +237,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
237237
238238schemaSimpleModelExample :: Schema
239239schemaSimpleModelExample = mempty
240− & type_ .~ SwaggerObject
240+ & type_ ?~ SwaggerObject
241241 & required .~ [ "name" ]
242242 & properties .~
243− [ ("name", Inline (mempty & type_ .~ SwaggerString))
243+ [ ("name", Inline (mempty & type_ ?~ SwaggerString))
244244 , ("address", Ref (Reference "Address"))
245245 , ("age", Inline $ mempty
246246 & minimum_ ?~ 0
247− & type_ .~ SwaggerInteger
247+ & type_ ?~ SwaggerInteger
248248 & format ?~ "int32" ) ]
249249
250250schemaSimpleModelExampleJSON :: Value
@@ -272,8 +272,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
272272
273273schemaModelDictExample :: Schema
274274schemaModelDictExample = mempty
275− & type_ .~ SwaggerObject
276− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ .~ SwaggerString))
275+ & type_ ?~ SwaggerObject
276+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
277277
278278schemaModelDictExampleJSON :: Value
279279schemaModelDictExampleJSON = [aesonQQ|
@@ -287,7 +287,7 @@ schemaModelDictExampleJSON = [aesonQQ|
287287
288288schemaAdditionalExample :: Schema
289289schemaAdditionalExample = mempty
290− & type_ .~ SwaggerObject
290+ & type_ ?~ SwaggerObject
291291 & additionalProperties ?~ AdditionalPropertiesAllowed True
292292
293293schemaAdditionalExampleJSON :: Value
@@ -300,13 +300,13 @@ schemaAdditionalExampleJSON = [aesonQQ|
300300
301301schemaWithExampleExample :: Schema
302302schemaWithExampleExample = mempty
303− & type_ .~ SwaggerObject
303+ & type_ ?~ SwaggerObject
304304 & properties .~
305305 [ ("id", Inline $ mempty
306− & type_ .~ SwaggerInteger
306+ & type_ ?~ SwaggerInteger
307307 & format ?~ "int64" )
308308 , ("name", Inline $ mempty
309− & type_ .~ SwaggerString) ]
309+ & type_ ?~ SwaggerString) ]
310310 & required .~ [ "name" ]
311311 & example ?~ [aesonQQ|
312312 {
@@ -345,19 +345,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
345345definitionsExample :: HashMap Text Schema
346346definitionsExample =
347347 [ ("Category", mempty
348− & type_ .~ SwaggerObject
348+ & type_ ?~ SwaggerObject
349349 & properties .~
350350 [ ("id", Inline $ mempty
351− & type_ .~ SwaggerInteger
351+ & type_ ?~ SwaggerInteger
352352 & format ?~ "int64")
353− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
353+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
354354 , ("Tag", mempty
355− & type_ .~ SwaggerObject
355+ & type_ ?~ SwaggerObject
356356 & properties .~
357357 [ ("id", Inline $ mempty
358− & type_ .~ SwaggerInteger
358+ & type_ ?~ SwaggerInteger
359359 & format ?~ "int64")
360− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
360+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
361361
362362definitionsExampleJSON :: Value
363363definitionsExampleJSON = [aesonQQ|
@@ -401,7 +401,7 @@ paramsDefinitionExample =
401401 & required ?~ True
402402 & schema .~ ParamOther (mempty
403403 & in_ .~ ParamQuery
404− & type_ .~ SwaggerInteger
404+ & type_ ?~ SwaggerInteger
405405 & format ?~ "int32" ))
406406 , ("limitParam", mempty
407407 & name .~ "limit"
@@ -409,7 +409,7 @@ paramsDefinitionExample =
409409 & required ?~ True
410410 & schema .~ ParamOther (mempty
411411 & in_ .~ ParamQuery
412− & type_ .~ SwaggerInteger
412+ & type_ ?~ SwaggerInteger
413413 & format ?~ "int32" )) ]
414414
415415paramsDefinitionExampleJSON :: Value
@@ -510,7 +510,7 @@ swaggerExample = mempty
510510 & at 200 ?~ Inline (mempty
511511 & description .~ "OK"
512512 & schema ?~ Inline (mempty
513− & type_ .~ SwaggerObject
513+ & type_ ?~ SwaggerObject
514514 & example ?~ [aesonQQ|
515515 {
516516 "created": 100,
@@ -519,9 +519,9 @@ swaggerExample = mempty
519519 & description ?~ "This is some real Todo right here"
520520 & properties .~
521521 [ ("created", Inline $ mempty
522− & type_ .~ SwaggerInteger
522+ & type_ ?~ SwaggerInteger
523523 & format ?~ "int32")
524− , ("description", Inline (mempty & type_ .~ SwaggerString))]))
524+ , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
525525 & produces ?~ MimeList [ "application/json" ]
526526 & parameters .~
527527 [ Inline $ mempty
@@ -530,7 +530,7 @@ swaggerExample = mempty
530530 & description ?~ "TodoId param"
531531 & schema .~ ParamOther (mempty
532532 & in_ .~ ParamPath
533− & type_ .~ SwaggerString ) ]
533+ & type_ ?~ SwaggerString ) ]
534534 & tags .~ Set.fromList [ "todo" ] ))
535535
536536swaggerExampleJSON :: Value
@@ -1632,14 +1632,14 @@ petstoreExampleJSON = [aesonQQ|
16321632
16331633compositionSchemaExample :: Schema
16341634compositionSchemaExample = mempty
1635− & type_ .~ SwaggerObject
1635+ & type_ ?~ SwaggerObject
16361636 & Data.Swagger.allOf ?~ [
16371637 Ref (Reference "Other")
16381638 , Inline (mempty
1639− & type_ .~ SwaggerObject
1639+ & type_ ?~ SwaggerObject
16401640 & properties .~
16411641 [ ("greet", Inline $ mempty
1642− & type_ .~ SwaggerString) ])
1642+ & type_ ?~ SwaggerString) ])
16431643 ]
16441644
16451645compositionSchemaExampleJSON :: Value