73de316 · typeable/openapi3

git.iko.soy/typeable/openapi3

on master help sign in

Implement schemas for sum types

73de316Maxim Koltsov6 years ago

src/Data/Swagger.hs+1−33

compare with master

unifiedsplit

@@ -289,39 +289,7 @@ import Data.Swagger.Internal

289-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person)

290-- {"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}},"type":"object"}

291--

292−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a

292+-- TODO mention oneOf

293−-- schema for basic enums like

294−--

295−-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic

296−-- >>> instance ToSchema SampleEnum

297−-- >>> instance ToJSON SampleEnum

298−--

299−-- and for sum types that have constructors with values

300−--

301−-- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic

302−-- >>> instance ToSchema SampleSumType

303−-- >>> instance ToJSON SampleSumType

304−--

305−-- we can not derive a valid schema for a mix of the above. The following will result in a type error

306−--

307−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic

308−-- >>> instance ToSchema BadMixedType

309−-- ...

310−-- ... error:

311−-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType

312−-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).

313−-- ... Swagger does not have a good representation for these types.

314−-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema

315−-- ... that matches aeson's Generic-based toJSON,

316−-- ... but that's not supported by some Swagger tools.

317−-- ...

318−-- ... In the instance declaration for ‘ToSchema BadMixedType’

319−--

320−-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':

321−--

322−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic

323−-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

324−-- >>> instance ToJSON BadMixedType

325--

293--

326

294

327-- $manipulation

295-- $manipulation

src/Data/Swagger/Internal/Schema.hs+78−47

@@ -22,12 +22,13 @@ module Data.Swagger.Internal.Schema where

22import Prelude ()

23import Prelude.Compat

25−import Control.Lens

25+import Control.Lens hiding (allOf)

26import Data.Data.Lens (template)

28import Control.Monad

29import Control.Monad.Writer

30−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))

30+import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..),

31+ ToJSONKeyFunction (..), Value (..))

31import Data.Char

32import Data.Char

32import Data.Data (Data)

33import Data.Data (Data)

33import Data.Foldable (traverse_)

34import Data.Foldable (traverse_)

@@ -41,6 +42,7 @@ import Data.IntSet (IntSet)

41import Data.IntMap (IntMap)

42import Data.IntMap (IntMap)

42import Data.List.NonEmpty.Compat (NonEmpty)

43import Data.List.NonEmpty.Compat (NonEmpty)

43import Data.Map (Map)

44import Data.Map (Map)

45+import Data.Maybe (fromMaybe)

44import Data.Proxy

46import Data.Proxy

45import Data.Scientific (Scientific)

47import Data.Scientific (Scientific)

46import Data.Fixed (Fixed, HasResolution, Pico)

48import Data.Fixed (Fixed, HasResolution, Pico)

@@ -135,7 +137,7 @@ class ToSchema a where

135 -- Note that the schema itself is included in definitions

137 -- Note that the schema itself is included in definitions

136 -- only if it is recursive (and thus needs its definition in scope).

138 -- only if it is recursive (and thus needs its definition in scope).

137 declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema

139 declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema

138− default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

140+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) =>

139 Proxy a -> Declare (Definitions Schema) NamedSchema

141 Proxy a -> Declare (Definitions Schema) NamedSchema

140 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

142 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

141

143

@@ -443,7 +445,9 @@ instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain

443instance ToSchema a => ToSchema (Maybe a) where

445instance ToSchema a => ToSchema (Maybe a) where

444 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

446 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

445

447

446−instance (ToSchema a, ToSchema b) => ToSchema (Either a b)

448+instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where

449+ -- To match Aeson instance

450+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField }

447

451

448instance ToSchema () where

452instance ToSchema () where

449 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)

453 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)

@@ -637,32 +641,17 @@ toSchemaBoundedEnumKeyMapping :: forall map key value.

637toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

641toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

638

642

639-- | A configurable generic @'Schema'@ creator.

643-- | A configurable generic @'Schema'@ creator.

640−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>

644+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) =>

641 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema

645 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema

642−genericDeclareSchema = genericDeclareSchemaUnrestricted

646+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy

643

647

644-- | A configurable generic @'NamedSchema'@ creator.

648-- | A configurable generic @'NamedSchema'@ creator.

645-- This function applied to @'defaultSchemaOptions'@

649-- This function applied to @'defaultSchemaOptions'@

646-- is used as the default for @'declareNamedSchema'@

650-- is used as the default for @'declareNamedSchema'@

647-- when the type is an instance of @'Generic'@.

651-- when the type is an instance of @'Generic'@.

648−genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

652+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>

649 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema

653 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema

650−genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

651−

652−-- | A configurable generic @'Schema'@ creator.

653−--

654−-- Unlike 'genericDeclareSchema' also works for mixed sum types.

655−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

656−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema

657−genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy

658−

659−-- | A configurable generic @'NamedSchema'@ creator.

660−--

661−-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.

662−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

663−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>

664− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema

665−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

654+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

666

655

667-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.

656-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.

668genericNameSchema :: forall a d f.

657genericNameSchema :: forall a d f.

@@ -791,56 +780,98 @@ instance ( GSumToSchema f

791 , GSumToSchema g

780 , GSumToSchema g

792 ) => GToSchema (f :+: g)

781 ) => GToSchema (f :+: g)

793 where

782 where

783+ -- Aeson does not unwrap unary record in sum types.

794− gdeclareNamedSchema = gdeclareNamedSumSchema

784+ gdeclareNamedSchema opts p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s

795

785

796gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

786gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

797−gdeclareNamedSumSchema opts proxy s

787+gdeclareNamedSumSchema opts proxy _

798− | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)

788+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas)

799− | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema

789+ | otherwise = do

790+ (schemas, _) <- runWriterT declareSumSchema

791+ return $ unnamed $ mempty

792+ & type_ ?~ SwaggerObject

793+ & oneOf ?~ (snd <$> schemas)

800 where

794 where

801− declareSumSchema = gsumToSchema opts proxy s

795+ declareSumSchema = gsumToSchema opts proxy

802− (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)

796+ (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)

803

797

804− toStringTag schema = mempty

798+ toStringTag schemas = mempty

805 & type_ ?~ SwaggerString

799 & type_ ?~ SwaggerString

806− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)

800+ & enum_ ?~ map (String . fst) sumSchemas

807

801

808type AllNullary = All

802type AllNullary = All

809

803

810class GSumToSchema (f :: * -> *) where

804class GSumToSchema (f :: * -> *) where

811− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

805+ gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)]

812

806

813instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where

807instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where

808+ gsumToSchema opts _ =

814− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)

809+ (<>) <$> gsumToSchema opts (Proxy :: Proxy f) <*> gsumToSchema opts (Proxy :: Proxy g)

815

810

811+-- | Convert one component of the sum to schema, to be later combined with @oneOf@.

816gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>

812gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>

817− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema

813+ Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema)

818−gsumConToSchemaWith ref opts _ schema = schema

814+gsumConToSchemaWith ref opts _ = (tag, schema)

819− & type_ ?~ SwaggerObject

820− & properties . at tag ?~ ref

821− & maxProperties ?~ 1

822− & minProperties ?~ 1

823 where

815 where

816+ schema = case sumEncoding opts of

817+ TaggedObject tagField contentsField ->

818+ case ref of

819+ -- If subschema is an object and constructor is a record, we add tag directly

820+ -- to the record, as Aeson does it.

821+ Just (Inline sub) | sub ^. type_ == Just SwaggerObject && isRecord -> Inline $ sub

822+ & required <>~ [T.pack tagField]

823+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])

824+

825+ -- If it is not a record, we need to put subschema into "contents" field.

826+ _ | not isRecord -> Inline $ mempty

827+ & type_ ?~ SwaggerObject

828+ & required .~ [T.pack tagField]

829+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])

830+ -- If constructor is nullary, there is no content.

831+ & case ref of

832+ Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField])

833+ Nothing -> id

834+

835+ -- In the remaining cases we combine "tag" object and "contents" object using allOf.

836+ _ -> Inline $ mempty

837+ & type_ ?~ SwaggerObject

838+ & allOf ?~ [Inline $ mempty

839+ & type_ ?~ SwaggerObject

840+ & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])

841+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])]

842+ & if isRecord

843+ then allOf . _Just <>~ [refOrNullary]

844+ else allOf . _Just <>~ [Inline $ mempty & type_ ?~ SwaggerObject & properties . at (T.pack contentsField) ?~ refOrNullary]

845+ UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.

846+ ObjectWithSingleField -> Inline $ mempty

847+ & type_ ?~ SwaggerObject

848+ & required .~ [tag]

849+ & properties . at tag ?~ refOrNullary

850+ TwoElemArray -> error "unrepresentable in OpenAPI 3"

851+

824 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))

852 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))

853+ isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)

854+ refOrNullary = fromMaybe (Inline nullarySchema) ref

855+ refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) ref

825

856

826gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>

857gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>

827− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema

858+ SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)]

828−gsumConToSchema opts proxy schema = do

859+gsumConToSchema opts proxy = do

829 ref <- gdeclareSchemaRef opts proxy

860 ref <- gdeclareSchemaRef opts proxy

830− return $ gsumConToSchemaWith ref opts proxy schema

861+ return [gsumConToSchemaWith (Just ref) opts proxy]

831

862

832instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where

863instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where

833− gsumToSchema opts proxy schema = do

864+ gsumToSchema opts proxy = do

834 tell (All False)

865 tell (All False)

835− lift $ gsumConToSchema opts proxy schema

866+ lift $ gsumConToSchema opts proxy

836

867

837instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where

868instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where

838− gsumToSchema opts proxy schema = do

869+ gsumToSchema opts proxy = do

839 tell (All False)

870 tell (All False)

840− lift $ gsumConToSchema opts proxy schema

871+ lift $ gsumConToSchema opts proxy

841

872

842instance Constructor c => GSumToSchema (C1 c U1) where

873instance Constructor c => GSumToSchema (C1 c U1) where

843− gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy

874+ gsumToSchema opts proxy = pure $ (:[]) $ gsumConToSchemaWith Nothing opts proxy

844

875

845data Proxy2 a b = Proxy2

876data Proxy2 a b = Proxy2

846

877

src/Data/Swagger/Internal/Schema/Validation.hs+34−18

@@ -12,6 +12,7 @@

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TemplateHaskell #-}

14{-# LANGUAGE UndecidableInstances #-}

15+{-# LANGUAGE ViewPatterns #-}

15-- |

16-- |

16-- Module: Data.Swagger.Internal.Schema.Validation

17-- Module: Data.Swagger.Internal.Schema.Validation

@@ -26,8 +27,8 @@ import Prelude ()

26import Prelude.Compat

27import Prelude.Compat

28import Control.Applicative

29import Control.Applicative

29−import Control.Lens

30+import Control.Lens hiding (allOf)

30−import Control.Monad (when)

31+import Control.Monad (forM, forM_, when)

32import Data.Aeson hiding (Result)

33import Data.Aeson hiding (Result)

33import Data.Aeson.Encode.Pretty (encodePretty)

34import Data.Aeson.Encode.Pretty (encodePretty)

@@ -473,22 +474,37 @@ inferParamSchemaTypes sch = concat

473

474

474validateSchemaType :: Value -> Validation Schema ()

475validateSchemaType :: Value -> Validation Schema ()

475validateSchemaType value = withSchema $ \sch ->

476validateSchemaType value = withSchema $ \sch ->

477+ case sch of

478+ (view oneOf -> Just variants) -> do

479+ res <- forM variants $ \var ->

480+ (True <$ validateWithSchemaRef var value) <|> (return False)

481+ case length $ filter id res of

482+ 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show value

483+ 1 -> valid

484+ _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show value

485+ (view allOf -> Just variants) -> do

486+ -- Default semantics for Validation Monad will abort when at least one

487+ -- variant does not match.

488+ forM_ variants $ \var ->

489+ validateWithSchemaRef var value

490+

491+ _ ->

476− case (sch ^. type_, value) of

492+ case (sch ^. type_, value) of

477− (Just SwaggerNull, Null) -> valid

493+ (Just SwaggerNull, Null) -> valid

478− (Just SwaggerBoolean, Bool _) -> valid

494+ (Just SwaggerBoolean, Bool _) -> valid

479− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

495+ (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

480− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

496+ (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

481− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)

497+ (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)

482− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

498+ (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

483− (Just SwaggerObject, Object o) -> validateObject o

499+ (Just SwaggerObject, Object o) -> validateObject o

484− (Nothing, Null) -> valid

500+ (Nothing, Null) -> valid

485− (Nothing, Bool _) -> valid

501+ (Nothing, Bool _) -> valid

486− -- Number by default

502+ -- Number by default

487− (Nothing, Number n) -> sub_ paramSchema (validateNumber n)

503+ (Nothing, Number n) -> sub_ paramSchema (validateNumber n)

488− (Nothing, String s) -> sub_ paramSchema (validateString s)

504+ (Nothing, String s) -> sub_ paramSchema (validateString s)

489− (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)

505+ (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)

490− (Nothing, Object o) -> validateObject o

506+ (Nothing, Object o) -> validateObject o

491− bad -> invalid $ "expected JSON value of type " ++ showType bad

507+ bad -> invalid $ "expected JSON value of type " ++ showType bad

492

508

493validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

509validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

494validateParamSchemaType value = withSchema $ \sch ->

510validateParamSchemaType value = withSchema $ \sch ->

src/Data/Swagger/Schema.hs−4

@@ -32,10 +32,6 @@ module Data.Swagger.Schema (

32 paramSchemaToNamedSchema,

33 paramSchemaToSchema,

35− -- ** Unrestricted versions

36− genericDeclareNamedSchemaUnrestricted,

37− genericDeclareSchemaUnrestricted,

38−

39 -- * Schema templates

35 -- * Schema templates

40 passwordSchema,

36 passwordSchema,

41 binarySchema,

37 binarySchema,

src/Data/Swagger/Schema/Generator.hs+6−4

@@ -30,6 +30,8 @@ import Test.QuickCheck.Property

30schemaGen :: Definitions Schema -> Schema -> Gen Value

31schemaGen _ schema

32 | Just cases <- schema ^. paramSchema . enum_ = elements cases

33+schemaGen defns schema

34+ | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants)

33schemaGen defns schema =

35schemaGen defns schema =

34 case schema ^. type_ of

36 case schema ^. type_ of

35 Nothing ->

37 Nothing ->

@@ -94,10 +96,10 @@ schemaGen defns schema =

94 _ -> return []

96 _ -> return []

95 x <- sequence $ gens <> additionalGens

97 x <- sequence $ gens <> additionalGens

96 return . Object $ M.toHashMap x

98 return . Object $ M.toHashMap x

97− where

99+

98− dereference :: Definitions a -> Referenced a -> a

100+dereference :: Definitions a -> Referenced a -> a

99− dereference _ (Inline a) = a

101+dereference _ (Inline a) = a

100− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

102+dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

101

103

102genValue :: (ToSchema a) => Proxy a -> Gen Value

104genValue :: (ToSchema a) => Proxy a -> Gen Value

103genValue p =

105genValue p =

src/Data/Swagger/SchemaOptions.hs+5−1

@@ -22,6 +22,8 @@ data SchemaOptions = SchemaOptions

22 , allNullaryToStringTag :: Bool

23 -- | Hide the field name when a record constructor has only one field, like a newtype.

24 , unwrapUnaryRecords :: Bool

25+ -- | Specifies how to encode constructors of a sum datatype.

26+ , sumEncoding :: Aeson.SumEncoding

25 }

27 }

27-- | Default encoding @'SchemaOptions'@.

29-- | Default encoding @'SchemaOptions'@.

@@ -33,6 +35,7 @@ data SchemaOptions = SchemaOptions

33-- , 'datatypeNameModifier' = id

35-- , 'datatypeNameModifier' = id

34-- , 'allNullaryToStringTag' = True

36-- , 'allNullaryToStringTag' = True

35-- , 'unwrapUnaryRecords' = False

37-- , 'unwrapUnaryRecords' = False

38+-- , 'sumEncoding' = 'Aeson.defaultTaggedObject'

36-- }

39-- }

37-- @

40-- @

38defaultSchemaOptions :: SchemaOptions

41defaultSchemaOptions :: SchemaOptions

@@ -42,6 +45,7 @@ defaultSchemaOptions = SchemaOptions

42 , datatypeNameModifier = id

45 , datatypeNameModifier = id

43 , allNullaryToStringTag = True

46 , allNullaryToStringTag = True

44 , unwrapUnaryRecords = False

47 , unwrapUnaryRecords = False

48+ , sumEncoding = Aeson.defaultTaggedObject

45 }

49 }

47-- | Convert 'Aeson.Options' to 'SchemaOptions'.

51-- | Convert 'Aeson.Options' to 'SchemaOptions'.

@@ -56,7 +60,6 @@ defaultSchemaOptions = SchemaOptions

56-- Note that these fields have no effect on `SchemaOptions`:

60-- Note that these fields have no effect on `SchemaOptions`:

57--

61--

58-- * 'Aeson.omitNothingFields'

62-- * 'Aeson.omitNothingFields'

59−-- * 'Aeson.sumEncoding'

60-- * 'Aeson.tagSingleConstructors'

63-- * 'Aeson.tagSingleConstructors'

61--

64--

62-- The rest is defined as in 'defaultSchemaOptions'.

65-- The rest is defined as in 'defaultSchemaOptions'.

@@ -69,4 +72,5 @@ fromAesonOptions opts = defaultSchemaOptions

69 , constructorTagModifier = Aeson.constructorTagModifier opts

72 , constructorTagModifier = Aeson.constructorTagModifier opts

70 , allNullaryToStringTag = Aeson.allNullaryToStringTag opts

73 , allNullaryToStringTag = Aeson.allNullaryToStringTag opts

71 , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts

74 , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts

75+ , sumEncoding = Aeson.sumEncoding opts

72 }

76 }

test/Data/Swagger/CommonTestTypes.hs+305−92

@@ -271,106 +271,192 @@ instance ToSchema Character

271characterSchemaJSON :: Value

272characterSchemaJSON = [aesonQQ|

273{

274− "type": "object",

274+ "oneOf": [

275− "properties":

276 {

275 {

277− "PC": { "$ref": "#/components/schemas/Player" },

276+ "required": [

278− "NPC":

277+ "tag",

279− {

278+ "contents"

279+ ],

280− "type": "object",

280+ "type": "object",

281− "properties":

281+ "properties": {

282− {

282+ "tag": {

283− "npcName": { "type": "string" },

283+ "type": "string",

284+ "enum": [

285+ "PC"

286+ ]

287+ },

288+ "contents": {

284− "npcPosition": { "$ref": "#/components/schemas/Point" }

289+ "$ref": "#/components/schemas/Player"

285− },

286− "required": ["npcName", "npcPosition"]

287 }

290 }

291+ }

288 },

292 },

289− "maxProperties": 1,

293+ {

290− "minProperties": 1

294+ "required": [

295+ "npcName",

296+ "npcPosition",

297+ "tag"

298+ ],

299+ "type": "object",

300+ "properties": {

301+ "tag": {

302+ "type": "string",

303+ "enum": [

304+ "NPC"

305+ ]

306+ },

307+ "npcPosition": {

308+ "$ref": "#/components/schemas/Point"

309+ },

310+ "npcName": {

311+ "type": "string"

312+ }

313+ }

314+ }

315+ ],

316+ "type": "object"

291}

317}

318+

292|]

319|]

293

320

294characterInlinedSchemaJSON :: Value

321characterInlinedSchemaJSON :: Value

295characterInlinedSchemaJSON = [aesonQQ|

322characterInlinedSchemaJSON = [aesonQQ|

296{

323{

297− "type": "object",

324+ "oneOf": [

298− "properties":

299 {

325 {

326+ "required": [

327+ "tag",

328+ "contents"

329+ ],

330+ "type": "object",

331+ "properties": {

332+ "tag": {

333+ "type": "string",

334+ "enum": [

300− "PC":

335+ "PC"

301− {

336+ ]

337+ },

338+ "contents": {

339+ "required": [

340+ "position"

341+ ],

302 "type": "object",

342 "type": "object",

303− "properties":

343+ "properties": {

304− {

305− "position":

344+ "position": {

306− {

307− "type": "object",

308− "properties":

309− {

310− "x": { "type": "number", "format": "double" },

311− "y": { "type": "number", "format": "double" }

312− },

313− "required": ["x", "y"]

345+ "required": [

346+ "x",

347+ "y"

348+ ],

349+ "type": "object",

350+ "properties": {

351+ "x": {

352+ "format": "double",

353+ "type": "number"

354+ },

355+ "y": {

356+ "format": "double",

357+ "type": "number"

314 }

358 }

359+ }

315− },

360+ }

361+ }

362+ }

363+ }

364+ },

365+ {

316− "required": ["position"]

366+ "required": [

367+ "npcName",

368+ "npcPosition",

369+ "tag"

370+ ],

371+ "type": "object",

372+ "properties": {

373+ "tag": {

374+ "type": "string",

375+ "enum": [

376+ "NPC"

377+ ]

317 },

378 },

318− "NPC":

379+ "npcPosition": {

319− {

380+ "required": [

381+ "x",

382+ "y"

383+ ],

320 "type": "object",

384 "type": "object",

321− "properties":

385+ "properties": {

322− {

386+ "x": {

323− "npcName": { "type": "string" },

324− "npcPosition":

325− {

326− "type": "object",

327− "properties":

328− {

329− "x": { "type": "number", "format": "double" },

387+ "format": "double",

330− "y": { "type": "number", "format": "double" }

388+ "type": "number"

331− },

332− "required": ["x", "y"]

333− }

334 },

389 },

390+ "y": {

391+ "format": "double",

392+ "type": "number"

393+ }

394+ }

395+ },

335− "required": ["npcName", "npcPosition"]

396+ "npcName": {

397+ "type": "string"

336 }

398 }

399+ }

337− },

400+ }

338− "maxProperties": 1,

401+ ],

339− "minProperties": 1

402+ "type": "object"

340}

403}

341|]

404|]

342

405

343characterInlinedPlayerSchemaJSON :: Value

406characterInlinedPlayerSchemaJSON :: Value

344characterInlinedPlayerSchemaJSON = [aesonQQ|

407characterInlinedPlayerSchemaJSON = [aesonQQ|

345{

408{

346− "type": "object",

409+ "oneOf": [

347− "properties":

348 {

410 {

349− "PC":

411+ "required": [

350− {

412+ "tag",

413+ "contents"

414+ ],

351− "type": "object",

415+ "type": "object",

352− "properties":

416+ "properties": {

353− {

417+ "tag": {

354− "position":

418+ "type": "string",

355− {

419+ "enum": [

356− "$ref": "#/components/schemas/Point"

420+ "PC"

357− }

421+ ]

358− },

359− "required": ["position"]

360 },

422 },

361− "NPC":

423+ "contents": {

362− {

424+ "required": [

425+ "position"

426+ ],

363 "type": "object",

427 "type": "object",

364− "properties":

428+ "properties": {

365− {

429+ "position": {

366− "npcName": { "type": "string" },

367− "npcPosition": { "$ref": "#/components/schemas/Point" }

430+ "$ref": "#/components/schemas/Point"

368− },

431+ }

369− "required": ["npcName", "npcPosition"]

432+ }

370 }

433 }

434+ }

371 },

435 },

372− "maxProperties": 1,

436+ {

373− "minProperties": 1

437+ "required": [

438+ "npcName",

439+ "npcPosition",

440+ "tag"

441+ ],

442+ "type": "object",

443+ "properties": {

444+ "tag": {

445+ "type": "string",

446+ "enum": [

447+ "NPC"

448+ ]

449+ },

450+ "npcPosition": {

451+ "$ref": "#/components/schemas/Point"

452+ },

453+ "npcName": {

454+ "type": "string"

455+ }

456+ }

457+ }

458+ ],

459+ "type": "object"

374}

460}

375|]

461|]

376

462

@@ -542,42 +628,169 @@ data Light

542 deriving (Generic)

628 deriving (Generic)

543

629

544instance ToSchema Light where

630instance ToSchema Light where

545− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

631+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

546 { unwrapUnaryRecords = True }

632 { unwrapUnaryRecords = True }

547

633

548lightSchemaJSON :: Value

634lightSchemaJSON :: Value

549lightSchemaJSON = [aesonQQ|

635lightSchemaJSON = [aesonQQ|

550{

636{

637+ "oneOf": [

638+ {

639+ "required": [

640+ "tag"

641+ ],

551− "type": "object",

642+ "type": "object",

552− "properties":

643+ "properties": {

644+ "tag": {

645+ "type": "string",

646+ "enum": [

647+ "NoLight"

648+ ]

649+ }

650+ }

651+ },

553 {

652 {

554− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

653+ "required": [

654+ "tag",

655+ "contents"

656+ ],

657+ "type": "object",

658+ "properties": {

659+ "tag": {

660+ "type": "string",

661+ "enum": [

662+ "LightFreq"

663+ ]

664+ },

665+ "contents": {

666+ "format": "double",

555− "LightFreq": { "type": "number", "format": "double" },

667+ "type": "number"

668+ }

669+ }

670+ },

671+ {

672+ "required": [

673+ "tag",

674+ "contents"

675+ ],

676+ "type": "object",

677+ "properties": {

678+ "tag": {

679+ "type": "string",

680+ "enum": [

681+ "LightColor"

682+ ]

683+ },

684+ "contents": {

556− "LightColor": { "$ref": "#/components/schemas/Color" },

685+ "$ref": "#/components/schemas/Color"

557− "LightWaveLength": { "type": "number", "format": "double" }

686+ }

687+ }

558 },

688 },

559− "maxProperties": 1,

689+ {

560− "minProperties": 1

690+ "required": [

691+ "waveLength",

692+ "tag"

693+ ],

694+ "type": "object",

695+ "properties": {

696+ "tag": {

697+ "type": "string",

698+ "enum": [

699+ "LightWaveLength"

700+ ]

701+ },

702+ "waveLength": {

703+ "format": "double",

704+ "type": "number"

705+ }

706+ }

707+ }

708+ ],

709+ "type": "object"

561}

710}

562|]

711|]

563

712

564lightInlinedSchemaJSON :: Value

713lightInlinedSchemaJSON :: Value

565lightInlinedSchemaJSON = [aesonQQ|

714lightInlinedSchemaJSON = [aesonQQ|

566{

715{

567− "type": "object",

716+ "oneOf": [

568− "properties":

569 {

717 {

570− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

718+ "required": [

571− "LightFreq": { "type": "number", "format": "double" },

719+ "tag"

572− "LightColor":

720+ ],

573− {

721+ "type": "object",

722+ "properties": {

723+ "tag": {

574 "type": "string",

724 "type": "string",

575− "enum": ["Red", "Green", "Blue"]

725+ "enum": [

726+ "NoLight"

727+ ]

728+ }

729+ }

730+ },

731+ {

732+ "required": [

733+ "tag",

734+ "contents"

735+ ],

736+ "type": "object",

737+ "properties": {

738+ "tag": {

739+ "type": "string",

740+ "enum": [

741+ "LightFreq"

742+ ]

576 },

743 },

744+ "contents": {

577− "LightWaveLength": { "type": "number", "format": "double" }

745+ "format": "double",

746+ "type": "number"

747+ }

748+ }

578 },

749 },

579− "maxProperties": 1,

750+ {

580− "minProperties": 1

751+ "required": [

752+ "tag",

753+ "contents"

754+ ],

755+ "type": "object",

756+ "properties": {

757+ "tag": {

758+ "type": "string",

759+ "enum": [

760+ "LightColor"

761+ ]

762+ },

763+ "contents": {

764+ "type": "string",

765+ "enum": [

766+ "Red",

767+ "Green",

768+ "Blue"

769+ ]

770+ }

771+ }

772+ },

773+ {

774+ "required": [

775+ "waveLength",

776+ "tag"

777+ ],

778+ "type": "object",

779+ "properties": {

780+ "tag": {

781+ "type": "string",

782+ "enum": [

783+ "LightWaveLength"

784+ ]

785+ },

786+ "waveLength": {

787+ "format": "double",

788+ "type": "number"

789+ }

790+ }

791+ }

792+ ],

793+ "type": "object"

581}

794}

582|]

795|]

583

796

test/Data/Swagger/Schema/ValidationSpec.hs+2−2

@@ -188,10 +188,10 @@ instance Arbitrary MyRoseTree where

188data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)

189

190instance ToSchema Light where

191− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

191+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = ObjectWithSingleField }

192

193instance ToJSON Light where

194− toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

194+ toJSON = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = ObjectWithSingleField }

195

196instance Arbitrary Light where

197 arbitrary = oneof