Use discriminator to parse correct union type

openapi3-code-generator/src/OpenAPI/Generate/Model.hs

@@ -244,7 +244,7 @@ defineModelForSchemaConcreteIgnoreEnum strategy schemaName schema = do
           anyOfNull = null $ OAS.schemaObjectAnyOf schema
        in case (allOfNull, oneOfNull, anyOfNull) of
             (False, _, _) -> OAM.nested "allOf" $ defineAllOfSchema schemaName schemaDescription $ OAS.schemaObjectAllOf schema
-            (_, False, _) -> OAM.nested "oneOf" $ typeAliasing $ defineOneOfSchema schemaName schemaDescription $ OAS.schemaObjectOneOf schema
+            (_, False, _) -> OAM.nested "oneOf" $ typeAliasing $ defineOneOfSchema schemaName schemaDescription (OAS.schemaObjectOneOf schema) $ OAS.schemaObjectDiscriminator schema
             (_, _, False) -> OAM.nested "anyOf" $ defineAnyOfSchema strategy schemaName schemaDescription $ OAS.schemaObjectAnyOf schema
             _ -> defineObjectModelForSchema strategy schemaName schema
     _ ->
@@ -350,7 +350,7 @@ defineAnyOfSchema strategy schemaName description schemas = do
       addDependencies newDependencies $ defineAllOfSchema schemaName description (fmap OAT.Concrete schemasWithoutRequired)
     else do
       OAM.logTrace "anyOf does contain at least one schema which is not of type object and will therefore be defined as oneOf"
-      createAlias schemaName description strategy $ defineOneOfSchema schemaName description schemas
+      createAlias schemaName description strategy $ defineOneOfSchema schemaName description schemas Nothing
 
 --    this would be the correct implementation
 --    but it generates endless loop because some implementations use anyOf as a oneOf
@@ -369,18 +369,19 @@ defineAnyOfSchema strategy schemaName description schemas = do
 --
 -- creates types for all the subschemas and then creates an adt with constructors for the different
 -- subschemas. Constructors are numbered
-defineOneOfSchema :: Text -> Text -> [OAS.Schema] -> OAM.Generator TypeWithDeclaration
-defineOneOfSchema schemaName description allSchemas = do
+defineOneOfSchema :: Text -> Text -> [OAS.Schema] -> Maybe OAS.DiscriminatorObject -> OAM.Generator TypeWithDeclaration
+defineOneOfSchema schemaName description allSchemas discriminator = do
   when (null allSchemas) $ OAM.logWarning "oneOf does not contain any sub-schemas and will therefore be defined as a void type"
   settings <- OAM.getSettings
   let haskellifyConstructor = haskellifyName (OAO.settingConvertToCamelCase settings) True
+      haskellifyPartialConstructor = haskellifyText (OAO.settingConvertToCamelCase settings) True
       name = haskellifyConstructor $ schemaName <> "Variants"
       fixedValueStrategy = OAO.settingFixedValueStrategy settings
       (otherSchemas, fixedValueSchemas, singleFieldedSchemas) =
         let (s', fixedValue) = extractSchemasWithFixedValues fixedValueStrategy allSchemas
             (s'', singleFielded) = extractSchemasWithSingleField s'
          in (s'', fixedValue, singleFielded)
-      defineSingleFielded field = defineModelForSchemaNamed (schemaName <> haskellifyText (OAO.settingConvertToCamelCase settings) True field)
+      defineSingleFielded field = defineModelForSchemaNamed $ schemaName <> haskellifyPartialConstructor field
       indexedSchemas = zip otherSchemas ([1 ..] :: [Integer])
       defineIndexed schema index = defineModelForSchemaNamed (schemaName <> "OneOf" <> T.pack (show index)) schema
   OAM.logInfo $ "Define as oneOf named '" <> T.pack (nameBase name) <> "'"
@@ -416,32 +417,71 @@ defineOneOfSchema schemaName description allSchemas = do
       e = varE patternName
       fromJsonFn =
         let paramName = mkName "val"
-            body = do
-              constructorNames' <- sequence constructorNames
-              let resultExpr =
-                    foldr
-                      ( \constructorName expr ->
-                          [|($(varE constructorName) <$> Aeson.fromJSON $(varE paramName)) <|> $expr|]
-                      )
-                      [|Aeson.Error "No variant matched"|]
-                      constructorNames'
-                  parserExpr =
-                    [|
-                      case $resultExpr of
-                        Aeson.Success $p -> pure $e
-                        Aeson.Error $p -> fail $e
-                      |]
-              case fixedValueSchemas of
-                [] -> parserExpr
-                _ ->
-                  multiIfE $
-                    fmap
-                      ( \value ->
-                          let constructorName = createConstructorNameForSchemaWithFixedValue value
-                           in normalGE [|$(varE paramName) == $(liftAesonValue value)|] [|pure $(varE constructorName)|]
-                      )
-                      fixedValueSchemas
-                      <> [normalGE [|otherwise|] parserExpr]
+            body =
+              case discriminator of
+                Just disc -> do
+                  let fnArgName = mkName "obj"
+                      discriminatorPropertyName = mkName "propertyName"
+                      nonFixedSchemas = zip ([1 ..] :: [Integer]) $ do
+                        schema <- allSchemas
+                        guard $ E.isLeft $ extractSchemaWithFixedValue FixedValueStrategyExclude schema
+                        pure schema
+                      schemaLookupFromRef = Map.fromList $ do
+                        (n, schema) <- nonFixedSchemas
+                        case schema of
+                          OAT.Reference ref -> [(ref, (n, getSchemaNameFromReference ref))]
+                          OAT.Concrete _ -> []
+                      oneOfSchemaRefs = do
+                        (ref, (_, name')) <- Map.toList schemaLookupFromRef
+                        pure (name', ref)
+                      propertyNamesWithReferences = maybe oneOfSchemaRefs Map.toList $ OAS.discriminatorObjectMapping disc
+                  let mkMatchedCase (propName, fullRef) =
+                        case Map.lookup fullRef schemaLookupFromRef of
+                          Nothing -> []
+                          Just (n, caseName) -> do
+                            let suffix = if OAO.settingUseNumberedVariantConstructors settings then "Variant" <> T.pack (show n) else ""
+                                parseConstructor constructorName = [|($(varE constructorName) <$> Aeson.parseJSON $(varE paramName))|]
+                            [match (litP $ stringL $ T.unpack propName) (normalB [|$(parseConstructor $ haskellifyConstructor $ schemaName <> haskellifyPartialConstructor caseName <> suffix)|]) []]
+                      matchedCases = propertyNamesWithReferences >>= mkMatchedCase
+                      unmatchedCase = match (varP $ mkName "_unmatched") (normalB [|fail "No match for discriminator property"|]) []
+                      propertyCases = matchedCases <> [unmatchedCase]
+                      getDiscProp = [|$(varE fnArgName) Aeson..:? $(stringE $ T.unpack $ OAS.discriminatorObjectPropertyName disc)|]
+                      annotatedDiscriminatorPropertyName = [|$(varE discriminatorPropertyName) :: Text|]
+                      withObjectLamda =
+                        [|
+                          do
+                            result <- $getDiscProp
+                            case result of
+                              Nothing -> fail "Object lacks discriminator property"
+                              Just $(varP discriminatorPropertyName) ->
+                                $(caseE annotatedDiscriminatorPropertyName propertyCases)
+                          |]
+                  [|Aeson.withObject $(stringE $ T.unpack schemaName) $(lam1E (varP fnArgName) withObjectLamda) $(varE paramName)|]
+                Nothing -> do
+                  constructorNames' <- sequence constructorNames
+                  let resultExpr =
+                        foldr
+                          ( \constructorName expr -> [|($(varE constructorName) <$> Aeson.fromJSON $(varE paramName)) <|> $expr|]
+                          )
+                          [|Aeson.Error "No variant matched"|]
+                          constructorNames'
+                      parserExpr =
+                        [|
+                          case $resultExpr of
+                            Aeson.Success $p -> pure $e
+                            Aeson.Error $p -> fail $e
+                          |]
+                  case fixedValueSchemas of
+                    [] -> parserExpr
+                    _ ->
+                      multiIfE $
+                        fmap
+                          ( \value ->
+                              let constructorName = createConstructorNameForSchemaWithFixedValue value
+                               in normalGE [|$(varE paramName) == $(liftAesonValue value)|] [|pure $(varE constructorName)|]
+                          )
+                          fixedValueSchemas
+                          <> [normalGE [|otherwise|] parserExpr]
          in funD
               (mkName "parseJSON")
               [ clause

openapi3-code-generator/src/OpenAPI/Generate/Types/Schema.hs

@@ -175,15 +175,15 @@ instance FromJSON SchemaType where
 
 data DiscriminatorObject = DiscriminatorObject
   { discriminatorObjectPropertyName :: Text,
-    discriminatorObjectMapping :: Map.Map Text Text
+    discriminatorObjectMapping :: Maybe (Map.Map Text Text)
   }
   deriving (Show, Eq, Ord, Generic)
 
 instance FromJSON DiscriminatorObject where
   parseJSON = withObject "DiscriminatorObject" $ \o ->
     DiscriminatorObject
       <$> o .: "propertyName"
-      <*> o .:? "mapping" .!= Map.empty
+      <*> o .:? "mapping" .!= Nothing
 
 data ConcreteValue
   = StringDefaultValue Text

specifications/z_complex_self_made_example.yml

@@ -172,6 +172,28 @@ paths:
             application/json:
               schema:
                 $ref: "#/components/schemas/Dog"
+  /pet/withdiscriminator:
+    get:
+      description: Operation that references a component with a discriminator key
+      operationId: withDiscriminator
+      responses:
+        '200':
+          description: successful operation
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Fish"
+  /pet/withdiscriminatorwithoutmapping:
+    get:
+      description: Operation that references a component with a discriminator key (without mapping)
+      operationId: withDiscriminatorWithoutMapping
+      responses:
+        '200':
+          description: successful operation
+          content:
+            application/json:
+              schema:
+                $ref: "#/components/schemas/Lizard"
 components:
   schemas:
     PetByAge:
@@ -309,6 +331,70 @@ components:
           type: boolean
         age:
           type: integer
+    Fish:
+      type: object
+      oneOf:
+        - $ref: '#/components/schemas/Guppie'
+        - $ref: '#/components/schemas/Minnow'
+        - $ref: '#/components/schemas/Shark'
+      discriminator:
+        propertyName: fishType
+        mapping:
+          guppie: '#/components/schemas/Guppie'
+          minnow: '#/components/schemas/Minnow'
+          shark: '#/components/schemas/Shark'
+    Guppie:
+      type: object
+      properties:
+        color:
+          type: string
+        fishType:
+          type: string
+      required:
+        - fishType
+    Minnow:
+      type: object
+      properties:
+        color:
+          type: string
+        fishType:
+          type: string
+      required:
+        - fishType
+    Shark:
+      type: object
+      properties:
+        teethRemaining:
+          type: integer
+        fishType:
+          type: string
+      required:
+        - fishType
+    Lizard:
+      type: object
+      oneOf:
+        - $ref: '#/components/schemas/gecko'
+        - $ref: '#/components/schemas/gilaMonster'
+      discriminator:
+        propertyName: discriminatorTag
+    gecko:
+      type: object
+      properties:
+        hasTail:
+          type: boolean
+        discriminatorTag:
+          type: string
+      required:
+        - discriminatorTag
+    gilaMonster:
+      type: object
+      properties:
+        hasTail:
+          type: boolean
+        discriminatorTag:
+          type: string
+      required:
+        - discriminatorTag
     Mischling:
       allOf: # Combines the main `Pet` schema with `Cat`-specific properties
         - $ref: '#/components/schemas/Dog'

testing/golden-output/openapi.cabal

@@ -12,21 +12,30 @@ library
       OpenAPI.Operations.NoParam
       OpenAPI.Operations.SingleParam
       OpenAPI.Operations.SingleParamWithFixedEnum
+      OpenAPI.Operations.WithDiscriminator
+      OpenAPI.Operations.WithDiscriminatorWithoutMapping
       OpenAPI.Operations.Patch_pets
       OpenAPI.Operations.ShowPetById
       OpenAPI.Types
       OpenAPI.TypeAlias
       OpenAPI.Types.Cat
       OpenAPI.Types.CoverType
       OpenAPI.Types.Dog
+      OpenAPI.Types.Fish
+      OpenAPI.Types.Guppie
+      OpenAPI.Types.Lizard
+      OpenAPI.Types.Minnow
       OpenAPI.Types.Mischling
       OpenAPI.Types.PetByAge
       OpenAPI.Types.PetByType
+      OpenAPI.Types.Shark
       OpenAPI.Types.Test6
       OpenAPI.Types.Test7
       OpenAPI.Types.Test8
       OpenAPI.Types.Test9
       OpenAPI.Types.Value
+      OpenAPI.Types.Gecko
+      OpenAPI.Types.GilaMonster
       OpenAPI.Configuration
       OpenAPI.SecuritySchemes
       OpenAPI.Common

testing/golden-output/src/OpenAPI.hs

@@ -7,21 +7,30 @@ module OpenAPI (
   module OpenAPI.Operations.NoParam,
   module OpenAPI.Operations.SingleParam,
   module OpenAPI.Operations.SingleParamWithFixedEnum,
+  module OpenAPI.Operations.WithDiscriminator,
+  module OpenAPI.Operations.WithDiscriminatorWithoutMapping,
   module OpenAPI.Operations.Patch_pets,
   module OpenAPI.Operations.ShowPetById,
   module OpenAPI.Types,
   module OpenAPI.TypeAlias,
   module OpenAPI.Types.Cat,
   module OpenAPI.Types.CoverType,
   module OpenAPI.Types.Dog,
+  module OpenAPI.Types.Fish,
+  module OpenAPI.Types.Guppie,
+  module OpenAPI.Types.Lizard,
+  module OpenAPI.Types.Minnow,
   module OpenAPI.Types.Mischling,
   module OpenAPI.Types.PetByAge,
   module OpenAPI.Types.PetByType,
+  module OpenAPI.Types.Shark,
   module OpenAPI.Types.Test6,
   module OpenAPI.Types.Test7,
   module OpenAPI.Types.Test8,
   module OpenAPI.Types.Test9,
   module OpenAPI.Types.Value,
+  module OpenAPI.Types.Gecko,
+  module OpenAPI.Types.GilaMonster,
   module OpenAPI.Configuration,
   module OpenAPI.SecuritySchemes,
   module OpenAPI.Common,
@@ -32,21 +41,30 @@ import OpenAPI.Operations.MultiParamWithFixedEnum
 import OpenAPI.Operations.NoParam
 import OpenAPI.Operations.SingleParam
 import OpenAPI.Operations.SingleParamWithFixedEnum
+import OpenAPI.Operations.WithDiscriminator
+import OpenAPI.Operations.WithDiscriminatorWithoutMapping
 import OpenAPI.Operations.Patch_pets
 import OpenAPI.Operations.ShowPetById
 import OpenAPI.Types
 import OpenAPI.TypeAlias
 import OpenAPI.Types.Cat
 import OpenAPI.Types.CoverType
 import OpenAPI.Types.Dog
+import OpenAPI.Types.Fish
+import OpenAPI.Types.Guppie
+import OpenAPI.Types.Lizard
+import OpenAPI.Types.Minnow
 import OpenAPI.Types.Mischling
 import OpenAPI.Types.PetByAge
 import OpenAPI.Types.PetByType
+import OpenAPI.Types.Shark
 import OpenAPI.Types.Test6
 import OpenAPI.Types.Test7
 import OpenAPI.Types.Test8
 import OpenAPI.Types.Test9
 import OpenAPI.Types.Value
+import OpenAPI.Types.Gecko
+import OpenAPI.Types.GilaMonster
 import OpenAPI.Configuration
 import OpenAPI.SecuritySchemes
 import OpenAPI.Common