From 0d8f5546d2d44fba314b58c2b6659162774b9dc7 Mon Sep 17 00:00:00 2001 From: Nebula Lavelle Date: Wed, 14 Aug 2024 13:22:51 -0400 Subject: [PATCH] Support for schemas with OpenAPI 3 validators The new `Validator` associated type and `FleeceValidator` superclass constraint on the `Fleece` class allow extensions to validation beyond lifting Haskell functions. I added a class called `OpenApi3Validator` to the `json-fleece-openapi3` package that captures most of the OpenAPI 3 validations. `Fleece` instances can implement the `OpenApi3Validator` class on their associated `Validator` type to gain access to static information associated with the validations. The intent is that downstream users will leverage the additional information to generate richer OpenAPI schemas based on their Fleece schemas. There is a new constraint called `FleeceOpenApi3` that includes the `OpenApi3Validator` constraint on the `Fleece` instance's `Validator`. It is exported by the `json-fleece-openapi3` package, along with associated schemas that use the constraint. The schemas serve as a drop-in replacement for those in `Fleece.Core.Schemas`. They use the methods on `OpenApi3Validator` to implement their validations. I didn't add support for the `pattern` validation because I don't have good sense of what regex library to use. --- .../json-fleece-aeson-beeline.cabal | 2 +- json-fleece-aeson-beeline/package.yaml | 2 +- json-fleece-aeson/json-fleece-aeson.cabal | 7 +- json-fleece-aeson/package.yaml | 10 +- json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs | 2 +- json-fleece-aeson/src/Fleece/Aeson/Decoder.hs | 10 +- json-fleece-aeson/src/Fleece/Aeson/Encoder.hs | 11 +- .../src/Fleece/Aeson/EncoderDecoder.hs | 15 +- json-fleece-core/json-fleece-core.cabal | 3 +- json-fleece-core/package.yaml | 2 +- json-fleece-core/src/Fleece/Core.hs | 19 +- json-fleece-core/src/Fleece/Core/AnyJSON.hs | 5 +- json-fleece-core/src/Fleece/Core/Class.hs | 12 +- json-fleece-core/src/Fleece/Core/Schemas.hs | 97 +- json-fleece-core/src/Fleece/Core/Validator.hs | 57 + .../json-fleece-examples.cabal | 4 +- json-fleece-examples/package.yaml | 4 +- json-fleece-examples/src/Fleece/Examples.hs | 7 +- json-fleece-hermes/json-fleece-hermes.cabal | 9 +- json-fleece-hermes/package.yaml | 5 +- json-fleece-hermes/src/Fleece/Hermes.hs | 9 +- .../json-fleece-markdown.cabal | 5 +- json-fleece-markdown/package.yaml | 5 +- .../src/Fleece/Markdown/FleeceInstance.hs | 7 +- .../examples/star-trek/package.yaml | 2 +- .../examples/star-trek/stack.yaml | 2 + .../examples/star-trek/star-trek.cabal | 2 +- .../examples/test-cases/package.yaml | 2 +- .../examples/test-cases/stack.yaml | 2 + .../examples/test-cases/test-cases.cabal | 2 +- .../json-fleece-openapi3.cabal | 10 +- json-fleece-openapi3/package.yaml | 8 +- json-fleece-openapi3/src/Fleece/OpenApi3.hs | 1380 +---------------- .../src/Fleece/OpenApi3/CodeGen.hs | 1378 ++++++++++++++++ .../src/Fleece/OpenApi3/Schemas.hs | 6 + .../OpenApi3/Schemas/OpenApi3Validator.hs | 135 ++ .../src/Fleece/OpenApi3/Schemas/Schemas.hs | 209 +++ .../json-fleece-pretty-print.cabal | 7 +- json-fleece-pretty-print/package.yaml | 5 +- .../src/Fleece/PrettyPrint.hs | 9 +- .../examples/uber/package.yaml | 2 +- json-fleece-swagger2/examples/uber/stack.yaml | 2 + json-fleece-swagger2/examples/uber/uber.cabal | 2 +- .../json-fleece-swagger2.cabal | 4 +- json-fleece-swagger2/package.yaml | 4 +- 45 files changed, 1969 insertions(+), 1513 deletions(-) create mode 100644 json-fleece-core/src/Fleece/Core/Validator.hs create mode 100644 json-fleece-openapi3/src/Fleece/OpenApi3/CodeGen.hs create mode 100644 json-fleece-openapi3/src/Fleece/OpenApi3/Schemas.hs create mode 100644 json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/OpenApi3Validator.hs create mode 100644 json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/Schemas.hs diff --git a/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal b/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal index 0b9c0f2a..ff708b4e 100644 --- a/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal +++ b/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal @@ -37,7 +37,7 @@ library , beeline-http-client >=0.2 && <0.9 , bytestring ==0.11.* , http-client ==0.7.* - , json-fleece-aeson >=0.1 && <0.4 + , json-fleece-aeson >=0.1 && <0.5 default-language: Haskell2010 if flag(strict) ghc-options: -Weverything -Werror -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-missing-deriving-strategies -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-unticked-promoted-constructors diff --git a/json-fleece-aeson-beeline/package.yaml b/json-fleece-aeson-beeline/package.yaml index abce5e12..cda43d93 100644 --- a/json-fleece-aeson-beeline/package.yaml +++ b/json-fleece-aeson-beeline/package.yaml @@ -49,10 +49,10 @@ when: library: source-dirs: src dependencies: - - json-fleece-aeson >= 0.1 && < 0.4 - beeline-http-client >= 0.2 && < 0.9 - bytestring >= 0.11 && < 0.12 - http-client >= 0.7 && < 0.8 + - json-fleece-aeson >= 0.1 && < 0.5 exposed-modules: - Fleece.Aeson.Beeline diff --git a/json-fleece-aeson/json-fleece-aeson.cabal b/json-fleece-aeson/json-fleece-aeson.cabal index 49093d1b..7e182476 100644 --- a/json-fleece-aeson/json-fleece-aeson.cabal +++ b/json-fleece-aeson/json-fleece-aeson.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-aeson -version: 0.3.5.0 +version: 0.4.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -41,7 +41,8 @@ library , base >=4.7 && <5 , bytestring ==0.11.* , containers ==0.6.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* + , json-fleece-openapi3 ==0.5.* , shrubbery ==0.2.* , text >=1.2 && <2.1 , vector >=0.12 && <0.14 @@ -66,7 +67,7 @@ test-suite json-fleece-aeson-test , containers ==0.6.* , hedgehog , json-fleece-aeson - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-examples , scientific >=0.3.7 && <0.4 , shrubbery ==0.2.* diff --git a/json-fleece-aeson/package.yaml b/json-fleece-aeson/package.yaml index 5fba15dd..b5fa28f0 100644 --- a/json-fleece-aeson/package.yaml +++ b/json-fleece-aeson/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-aeson -version: 0.3.5.0 +version: 0.4.0.0 github: "flipstone/json-fleece/json-fleece-aeson" license: BSD3 author: "Author name here" @@ -16,14 +16,14 @@ copyright: "2023 Author name here" description: Please see the README on GitHub at dependencies: -- base >= 4.7 && < 5 - aeson >= 2.0 && < 2.2 +- base >= 4.7 && < 5 - bytestring >= 0.11 && < 0.12 - containers >= 0.6 && < 0.7 -- json-fleece-core >= 0.7 && < 0.8 +- json-fleece-core >= 0.8 && < 0.9 +- shrubbery >= 0.2 && < 0.3 - text >= 1.2 && < 2.1 - vector >= 0.12 && < 0.14 -- shrubbery >= 0.2 && < 0.3 flags: strict: @@ -58,6 +58,8 @@ library: - Fleece.Aeson - Fleece.Aeson.Decoder - Fleece.Aeson.Encoder + dependencies: + - json-fleece-openapi3 >= 0.5 && < 0.6 tests: json-fleece-aeson-test: diff --git a/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs b/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs index 5f726153..49d119ef 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs @@ -14,7 +14,7 @@ import qualified Fleece.Core as FC aesonValue :: FC.Fleece schema => schema Aeson.Value aesonValue = - FC.transform valueToAnyJSON anyJSONToValue FC.anyJSON + FC.validate (FC.transform valueToAnyJSON anyJSONToValue) FC.anyJSON anyJSONToValue :: FC.AnyJSON -> Aeson.Value anyJSONToValue = diff --git a/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs b/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs index 433bf1f0..60572bc2 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,6 +9,7 @@ module Fleece.Aeson.Decoder ( Decoder (..) + , FC.Validator (DecoderValidator) , decode , decodeStrict , fromValue @@ -30,6 +32,7 @@ import Shrubbery (type (@=)) import qualified Shrubbery import qualified Fleece.Core as FC +import qualified Fleece.OpenApi3 as FleeceOpenApi3 data Decoder a = Decoder FC.Name (Aeson.Value -> AesonTypes.Parser a) @@ -71,6 +74,9 @@ instance FC.Fleece Decoder where newtype TaggedUnionMembers Decoder allTags _handledTags = TaggedUnionMembers (Map.Map T.Text (Aeson.Object -> AesonTypes.Parser (Shrubbery.TaggedUnion allTags))) + newtype Validator Decoder a b = DecoderValidator (FC.StandardValidator a b) + deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator) + schemaName (Decoder name _parseValue) = name @@ -172,10 +178,10 @@ instance FC.Fleece Decoder where <> " enum: " <> show textValue - validateNamed name _uncheck check (Decoder _unvalidatedName parseValue) = + validateNamed name validator (Decoder _unvalidatedName parseValue) = Decoder name $ \jsonValue -> do uncheckedValue <- parseValue jsonValue - case check uncheckedValue of + case FC.check validator uncheckedValue of Right checkedValue -> pure checkedValue Left err -> fail $ "Error validating " <> FC.nameToString name <> ": " <> err diff --git a/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs b/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs index 1932bf30..87b33340 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,6 +10,7 @@ module Fleece.Aeson.Encoder ( Encoder (..) + , FC.Validator (EncoderValidator) , encode , encodeStrict ) where @@ -28,6 +31,7 @@ import Shrubbery (type (@=)) import qualified Shrubbery import qualified Fleece.Core as FC +import qualified Fleece.OpenApi3 as FleeceOpenApi3 data Encoder a = Encoder FC.Name (a -> Aeson.Encoding) @@ -56,6 +60,9 @@ instance FC.Fleece Encoder where newtype TaggedUnionMembers Encoder _allTags handledTags = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTags (T.Text, Aeson.Series)) + newtype Validator Encoder a b = EncoderValidator (FC.StandardValidator a b) + deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator) + schemaName (Encoder name _toEncoding) = name @@ -128,8 +135,8 @@ instance FC.Fleece Encoder where boundedEnumNamed name toText = Encoder name (Aeson.toEncoding . toText) - validateNamed name uncheck _check (Encoder _unvalidatedName toEncoding) = - Encoder name (toEncoding . uncheck) + validateNamed name validator (Encoder _unvalidatedName toEncoding) = + Encoder name (toEncoding . FC.uncheck validator) unionNamed name (UnionMembers builder) = let diff --git a/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs b/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs index ebc42c97..8d258a33 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs @@ -1,12 +1,14 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} module Fleece.Aeson.EncoderDecoder ( EncoderDecoder (..) ) where -import Fleece.Aeson.Decoder (Decoder) -import Fleece.Aeson.Encoder (Encoder) +import Fleece.Aeson.Decoder (Decoder, Validator (DecoderValidator)) +import Fleece.Aeson.Encoder (Encoder, Validator (EncoderValidator)) import qualified Fleece.Core as FC +import qualified Fleece.OpenApi3 as FleeceOpenApi3 data EncoderDecoder a = EncoderDecoder { encoder :: Encoder a @@ -39,6 +41,9 @@ instance FC.Fleece EncoderDecoder where , taggedUnionMembersDecoder :: FC.TaggedUnionMembers Decoder allTags handledTags } + newtype Validator EncoderDecoder a b = EncoderDecoderValidator (FC.StandardValidator a b) + deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator) + schemaName = FC.schemaName . encoder number = @@ -127,10 +132,10 @@ instance FC.Fleece EncoderDecoder where FC.additional (objectDecoder object) (additionalFieldsDecoder addFields) } - validateNamed name uncheck check itemEncoderDecoder = + validateNamed name (EncoderDecoderValidator validator) itemEncoderDecoder = EncoderDecoder - { encoder = FC.validateNamed name uncheck check $ encoder itemEncoderDecoder - , decoder = FC.validateNamed name uncheck check $ decoder itemEncoderDecoder + { encoder = FC.validateNamed name (EncoderValidator validator) $ encoder itemEncoderDecoder + , decoder = FC.validateNamed name (DecoderValidator validator) $ decoder itemEncoderDecoder } boundedEnumNamed name toText = diff --git a/json-fleece-core/json-fleece-core.cabal b/json-fleece-core/json-fleece-core.cabal index 674422ba..eaf7887e 100644 --- a/json-fleece-core/json-fleece-core.cabal +++ b/json-fleece-core/json-fleece-core.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-core -version: 0.7.0.0 +version: 0.8.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -33,6 +33,7 @@ library Fleece.Core.Name Fleece.Core.Schemas other-modules: + Fleece.Core.Validator Paths_json_fleece_core hs-source-dirs: src diff --git a/json-fleece-core/package.yaml b/json-fleece-core/package.yaml index 6f850936..d421b17e 100644 --- a/json-fleece-core/package.yaml +++ b/json-fleece-core/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-core -version: 0.7.0.0 +version: 0.8.0.0 github: "flipstone/json-fleece/json-fleece-core" license: BSD3 author: "Author name here" diff --git a/json-fleece-core/src/Fleece/Core.hs b/json-fleece-core/src/Fleece/Core.hs index 698b993d..58490a54 100644 --- a/json-fleece-core/src/Fleece/Core.hs +++ b/json-fleece-core/src/Fleece/Core.hs @@ -37,8 +37,6 @@ module Fleece.Core , nullable , validate , validateNamed - , transform - , transformNamed , coerceSchema , coerceSchemaNamed @@ -129,9 +127,26 @@ module Fleece.Core , autoQualifiedName , nameToString , annotateName + , defaultSchemaName + + -- * Validators + , Validator + , FleeceValidator + , mkValidator + , check + , uncheck + , mapUncheck + , mapCheck + , compose + , coercion + , transform + , identity + , StandardValidator + , NoOpValidator (..) ) where import Fleece.Core.AnyJSON import Fleece.Core.Class import Fleece.Core.Name import Fleece.Core.Schemas +import Fleece.Core.Validator diff --git a/json-fleece-core/src/Fleece/Core/AnyJSON.hs b/json-fleece-core/src/Fleece/Core/AnyJSON.hs index 9201be42..3e6d2981 100644 --- a/json-fleece-core/src/Fleece/Core/AnyJSON.hs +++ b/json-fleece-core/src/Fleece/Core/AnyJSON.hs @@ -38,7 +38,8 @@ import Fleece.Core.Class , (#|) ) import Fleece.Core.Name (unqualifiedName) -import Fleece.Core.Schemas (list, transform, unionMember) +import Fleece.Core.Schemas (list, unionMember, validate) +import Fleece.Core.Validator (transform) newtype AnyJSON = AnyJSON @@ -150,7 +151,7 @@ handleAnyJSON handleText handleBool handleNumber handleArray handleObject handle anyJSON :: Fleece schema => schema AnyJSON anyJSON = - transform (\(AnyJSON u) -> u) AnyJSON $ + validate (transform (\(AnyJSON u) -> u) AnyJSON) $ unionNamed (unqualifiedName "AnyJSON") $ unionMember text #| unionMember boolean diff --git a/json-fleece-core/src/Fleece/Core/Class.hs b/json-fleece-core/src/Fleece/Core/Class.hs index 3483ae44..cf9315b5 100644 --- a/json-fleece-core/src/Fleece/Core/Class.hs +++ b/json-fleece-core/src/Fleece/Core/Class.hs @@ -11,6 +11,7 @@ module Fleece.Core.Class , Object , UnionMembers , TaggedUnionMembers + , Validator , schemaName , text , number @@ -53,13 +54,15 @@ import Shrubbery (BranchIndex, Tag, TagIndex, TagType, TaggedTypes, TaggedUnion, import Shrubbery.TypeList (Append, Length) import Fleece.Core.Name (Name) +import Fleece.Core.Validator (FleeceValidator) -class Fleece schema where +class FleeceValidator (Validator schema) => Fleece schema where data Object schema :: Type -> Type -> Type data Field schema :: Type -> Type -> Type data AdditionalFields schema :: Type -> Type -> Type data UnionMembers schema :: [Type] -> [Type] -> Type data TaggedUnionMembers schema :: [Tag] -> [Tag] -> Type + data Validator schema :: Type -> Type -> Type schemaName :: schema a -> Name @@ -118,10 +121,9 @@ class Fleece schema where validateNamed :: Name -> - (a -> b) -> - (b -> Either String a) -> - (schema b) -> - (schema a) + Validator schema a b -> + schema a -> + schema b boundedEnumNamed :: (Bounded a, Enum a) => diff --git a/json-fleece-core/src/Fleece/Core/Schemas.hs b/json-fleece-core/src/Fleece/Core/Schemas.hs index 29d6a06e..62a9fb15 100644 --- a/json-fleece-core/src/Fleece/Core/Schemas.hs +++ b/json-fleece-core/src/Fleece/Core/Schemas.hs @@ -42,8 +42,6 @@ module Fleece.Core.Schemas , boundedIntegralNumberNamed , unboundedIntegralNumber , unboundedIntegralNumberNamed - , transform - , transformNamed , coerceSchema , coerceSchemaNamed , eitherOf @@ -60,7 +58,7 @@ module Fleece.Core.Schemas import qualified Data.Attoparsec.Text as AttoText import qualified Data.Attoparsec.Time as AttoTime -import Data.Coerce (Coercible, coerce) +import Data.Coerce (Coercible) import qualified Data.Int as I import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map @@ -85,6 +83,7 @@ import Fleece.Core.Class , Object , TaggedUnionMembers , UnionMembers + , Validator , additionalFields , array , boundedEnumNamed @@ -113,6 +112,7 @@ import Fleece.Core.Name , nameUnqualified , unqualifiedName ) +import Fleece.Core.Validator (FleeceValidator (mkValidator), coercion, transform) eitherOf :: forall schema a b. @@ -165,10 +165,9 @@ eitherOfNamed name leftSchema rightSchema = unionMember leftSchema #| unionMember rightSchema in - transformNamed + validateNamed name - toUnion - fromUnion + (transform toUnion fromUnion) unionSchema union :: @@ -258,47 +257,20 @@ boundedEnum toText = schema validate :: - (Fleece schema, Typeable a) => - (a -> b) -> - (b -> Either String a) -> - schema b -> - schema a -validate uncheck check schemaB = - let - name = - defaultSchemaName schemaA - - schemaA = - validateNamed name uncheck check schemaB - in - schemaA - -transform :: - (Fleece schema, Typeable a) => - (a -> b) -> - (b -> a) -> - schema b -> - schema a -transform aToB bToA schemaB = + (Fleece schema, Typeable b) => + Validator schema a b -> + schema a -> + schema b +validate validator schemaB = let name = defaultSchemaName schemaA schemaA = - transformNamed name aToB bToA schemaB + validateNamed name validator schemaB in schemaA -transformNamed :: - Fleece schema => - Name -> - (a -> b) -> - (b -> a) -> - schema b -> - schema a -transformNamed name aToB bToA = - validateNamed name aToB (Right . bToA) - coerceSchema :: (Fleece schema, Typeable a, Coercible a b) => schema b -> @@ -318,8 +290,8 @@ coerceSchemaNamed :: Name -> schema b -> schema a -coerceSchemaNamed name schemaB = - transformNamed name coerce coerce schemaB +coerceSchemaNamed name = + validateNamed name coercion data NothingEncoding = EmitNull @@ -350,10 +322,9 @@ optionalNullable encoding name accessor schema = list :: Fleece schema => schema a -> schema [a] list itemSchema = - transformNamed + validateNamed (unqualifiedName $ "[" <> nameUnqualified (schemaName itemSchema) <> "]") - V.fromList - V.toList + (transform V.fromList V.toList) (array itemSchema) map :: (Fleece schema, Typeable a) => schema a -> schema (Map.Map T.Text a) @@ -372,8 +343,7 @@ nonEmpty itemSchema = in validateNamed (unqualifiedName $ "NonEmpty " <> nameUnqualified (schemaName itemSchema)) - NEL.toList - validateNonEmpty + (mkValidator NEL.toList validateNonEmpty) (list itemSchema) data SetDuplicateHandling @@ -384,10 +354,9 @@ set :: (Ord a, Fleece schema) => SetDuplicateHandling -> schema a -> schema (Set set handling itemSchema = case handling of AllowInputDuplicates -> - transformNamed + validateNamed (unqualifiedName $ "Set [" <> nameUnqualified (schemaName itemSchema) <> "]") - (V.fromList . Set.toList) - (Set.fromList . V.toList) + (transform (V.fromList . Set.toList) (Set.fromList . V.toList)) (array itemSchema) RejectInputDuplicates -> let @@ -401,8 +370,7 @@ set handling itemSchema = in validateNamed (unqualifiedName $ "Set [" <> nameUnqualified (schemaName itemSchema) <> "]") - (V.fromList . Set.toList) - validateNoDuplicates + (mkValidator (V.fromList . Set.toList) validateNoDuplicates) (array itemSchema) nonEmptyText :: Fleece schema => schema NET.NonEmptyText @@ -415,8 +383,7 @@ nonEmptyText = in validateNamed (unqualifiedName "NonEmptyText") - NET.toText - validateNonEmptyText + (mkValidator NET.toText validateNonEmptyText) text integer :: Fleece schema => schema Integer @@ -445,8 +412,7 @@ unboundedIntegralNumberNamed name = in validateNamed name - fromIntegral - validateInteger + (mkValidator fromIntegral validateInteger) number unboundedIntegralNumber :: @@ -480,8 +446,7 @@ boundedIntegralNumberNamed name = in validateNamed name - fromIntegral - validateInteger + (mkValidator fromIntegral validateInteger) number boundedIntegralNumber :: @@ -553,14 +518,13 @@ realFloatNamed :: Name -> schema f realFloatNamed name = - transformNamed + validateNamed name - fromFloatDigits - toRealFloat + (transform fromFloatDigits toRealFloat) number string :: Fleece schema => schema String -string = transform T.pack T.unpack text +string = validate (transform T.pack T.unpack) text utcTime :: Fleece schema => schema Time.UTCTime utcTime = @@ -602,8 +566,7 @@ timeWithFormat typeName formatString = in validateNamed (unqualifiedName $ typeName <> " in " <> formatString <> " format") - (Time.formatTime Time.defaultTimeLocale formatString) - decode + (mkValidator (Time.formatTime Time.defaultTimeLocale formatString) decode) string bareOrJSONString :: Fleece schema => schema a -> schema a @@ -632,10 +595,9 @@ bareOrJSONString baseSchema = (unionMemberWithIndex index0 baseSchema) (unionMemberWithIndex index1 (jsonString baseSchema)) in - transformNamed + validateNamed name - toUnion - fromUnion + (transform toUnion fromUnion) unionSchema -- An internal helper for building building time schemes @@ -662,6 +624,5 @@ iso8601Formatted name format parser = in validateNamed (unqualifiedName name) - (T.pack . ISO8601.formatShow format) - parseTime + (mkValidator (T.pack . ISO8601.formatShow format) parseTime) text diff --git a/json-fleece-core/src/Fleece/Core/Validator.hs b/json-fleece-core/src/Fleece/Core/Validator.hs new file mode 100644 index 00000000..739b5b68 --- /dev/null +++ b/json-fleece-core/src/Fleece/Core/Validator.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Fleece.Core.Validator + ( FleeceValidator (..) + , coercion + , transform + , mapCheck + , mapUncheck + , identity + , check + , uncheck + , StandardValidator + , NoOpValidator (..) + ) where + +import Control.Monad ((<=<)) +import qualified Data.Coerce as Coerce + +class FleeceValidator validator where + mkValidator :: (b -> a) -> (a -> Either String b) -> validator a b + compose :: validator b c -> validator a b -> validator a c + +coercion :: (Coerce.Coercible a b, FleeceValidator validator) => validator a b +coercion = mkValidator Coerce.coerce (pure . Coerce.coerce) + +transform :: FleeceValidator validator => (b -> a) -> (a -> b) -> validator a b +transform f g = mkValidator f (pure . g) + +mapCheck :: FleeceValidator validator => (c -> b) -> (b -> c) -> validator a b -> validator a c +mapCheck f g v = mkValidator f (pure . g) `compose` v + +mapUncheck :: FleeceValidator validator => (c -> a) -> (a -> c) -> validator c b -> validator a b +mapUncheck f g v = v `compose` mkValidator f (pure . g) + +identity :: FleeceValidator validator => validator a a +identity = mkValidator id pure + +data StandardValidator a b = StandardValidator + { standardValidatorUncheck :: b -> a + , standardValidatorCheck :: a -> Either String b + } + +check :: Coerce.Coercible (validator a b) (StandardValidator a b) => validator a b -> a -> Either String b +check = standardValidatorCheck . Coerce.coerce + +uncheck :: Coerce.Coercible (validator a b) (StandardValidator a b) => validator a b -> b -> a +uncheck = standardValidatorUncheck . Coerce.coerce + +instance FleeceValidator StandardValidator where + mkValidator = StandardValidator + compose (StandardValidator f1 g1) (StandardValidator f2 g2) = StandardValidator (f2 . f1) (g1 <=< g2) + +data NoOpValidator a b = NoOpValidator + +instance FleeceValidator NoOpValidator where + mkValidator _ _ = NoOpValidator + compose _ _ = NoOpValidator diff --git a/json-fleece-examples/json-fleece-examples.cabal b/json-fleece-examples/json-fleece-examples.cabal index 5bc59149..0806fd98 100644 --- a/json-fleece-examples/json-fleece-examples.cabal +++ b/json-fleece-examples/json-fleece-examples.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-examples -version: 0.2.3.0 +version: 0.3.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -35,7 +35,7 @@ library build-depends: base >=4.7 && <5 , containers ==0.6.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , scientific >=0.3.7 && <0.4 , shrubbery ==0.2.* , text >=1.2 && <2.1 diff --git a/json-fleece-examples/package.yaml b/json-fleece-examples/package.yaml index 8d3ce1d3..6006a6df 100644 --- a/json-fleece-examples/package.yaml +++ b/json-fleece-examples/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-examples -version: 0.2.3.0 +version: 0.3.0.0 github: "flipstone/json-fleece/json-fleece-examples" license: BSD3 author: "Author name here" @@ -18,7 +18,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - containers >= 0.6 && < 0.7 -- json-fleece-core >= 0.7 && < 0.8 +- json-fleece-core >= 0.8 && < 0.9 - scientific >= 0.3.7 && < 0.4 - shrubbery >= 0.2 && < 0.3 - text >= 1.2 && < 2.1 diff --git a/json-fleece-examples/src/Fleece/Examples.hs b/json-fleece-examples/src/Fleece/Examples.hs index 448402a0..91ae0aae 100644 --- a/json-fleece-examples/src/Fleece/Examples.hs +++ b/json-fleece-examples/src/Fleece/Examples.hs @@ -53,6 +53,7 @@ import Fleece.Core , int , jsonString , list + , mkValidator , nullable , number , object @@ -102,8 +103,10 @@ newtype Validation = Validation T.Text validationSchema :: Fleece schema => schema Validation validationSchema = validate - (\(Validation t) -> t) - (\t -> if T.length t > 12 then Left "At most 12 characters allowed" else Right (Validation t)) + ( mkValidator + (\(Validation t) -> t) + (\t -> if T.length t > 12 then Left "At most 12 characters allowed" else Right (Validation t)) + ) text data OptionalField = OptionalField diff --git a/json-fleece-hermes/json-fleece-hermes.cabal b/json-fleece-hermes/json-fleece-hermes.cabal index 61617730..04aafd17 100644 --- a/json-fleece-hermes/json-fleece-hermes.cabal +++ b/json-fleece-hermes/json-fleece-hermes.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-hermes -version: 0.1.1.0 +version: 0.2.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -37,7 +37,8 @@ library , bytestring ==0.11.* , containers ==0.6.* , hermes-json ==0.6.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* + , json-fleece-openapi3 ==0.5.* , shrubbery ==0.2.* , text >=2.0 default-language: Haskell2010 @@ -60,7 +61,7 @@ test-suite json-fleece-hermes-test , bytestring ==0.11.* , containers ==0.6.* , hedgehog - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-examples , json-fleece-hermes , scientific >=0.3.7 && <0.4 @@ -91,7 +92,7 @@ benchmark json-fleece-hermes-bench , deepseq , hermes-json , json-fleece-aeson - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-hermes , tasty-bench , text diff --git a/json-fleece-hermes/package.yaml b/json-fleece-hermes/package.yaml index 33c53b6d..e4a57e8c 100644 --- a/json-fleece-hermes/package.yaml +++ b/json-fleece-hermes/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-hermes -version: 0.1.1.0 +version: 0.2.0.0 github: "flipstone/json-fleece/json-fleece-hermes" license: BSD3 author: "Author name here" @@ -18,7 +18,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - bytestring >= 0.11 && < 0.12 -- json-fleece-core >= 0.7 && < 0.8 +- json-fleece-core >= 0.8 && < 0.9 - text >= 2.0 # This could be problematic for anyone using LTS 20 or below flags: @@ -55,6 +55,7 @@ library: dependencies: - containers >= 0.6 && < 0.7 - hermes-json >= 0.6 && < 0.7 + - json-fleece-openapi3 >= 0.5 && < 0.6 - shrubbery >= 0.2 && < 0.3 tests: diff --git a/json-fleece-hermes/src/Fleece/Hermes.hs b/json-fleece-hermes/src/Fleece/Hermes.hs index 9a378ddb..f2e85d09 100644 --- a/json-fleece-hermes/src/Fleece/Hermes.hs +++ b/json-fleece-hermes/src/Fleece/Hermes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,6 +26,7 @@ import Shrubbery (type (@=)) import qualified Shrubbery import qualified Fleece.Core as FC +import qualified Fleece.OpenApi3 as FleeceOpenApi3 data Decoder a = Decoder FC.Name (H.Decoder a) @@ -58,6 +60,9 @@ instance FC.Fleece Decoder where newtype TaggedUnionMembers Decoder allTags _handledTags = TaggedUnionMembers (Map.Map T.Text (H.FieldsDecoder (Shrubbery.TaggedUnion allTags))) + newtype Validator Decoder a b = DecoderValidator (FC.StandardValidator a b) + deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator) + schemaName (Decoder name _parseValue) = name @@ -160,10 +165,10 @@ instance FC.Fleece Decoder where <> " enum: " <> show textValue - validateNamed name _uncheck check (Decoder _unvalidatedName parseValue) = + validateNamed name validator (Decoder _unvalidatedName parseValue) = Decoder name $ do uncheckedValue <- parseValue - case check uncheckedValue of + case FC.check validator uncheckedValue of Right checkedValue -> pure checkedValue Left err -> fail $ "Error validating " <> FC.nameToString name <> ": " <> err diff --git a/json-fleece-markdown/json-fleece-markdown.cabal b/json-fleece-markdown/json-fleece-markdown.cabal index daf5bccd..3eaeec1e 100644 --- a/json-fleece-markdown/json-fleece-markdown.cabal +++ b/json-fleece-markdown/json-fleece-markdown.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-markdown -version: 0.5.0.0 +version: 0.6.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -39,7 +39,8 @@ library base >=4.7 && <5 , containers ==0.6.* , dlist ==1.0.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* + , json-fleece-openapi3 ==0.5.* , text >=1.2 && <2.1 default-language: Haskell2010 if flag(strict) diff --git a/json-fleece-markdown/package.yaml b/json-fleece-markdown/package.yaml index a85023fa..cb87a7ef 100644 --- a/json-fleece-markdown/package.yaml +++ b/json-fleece-markdown/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-markdown -version: 0.5.0.0 +version: 0.6.0.0 github: "flipstone/json-fleece/json-fleece-markdown" license: BSD3 author: "Author name here" @@ -52,9 +52,10 @@ library: exposed-modules: - Fleece.Markdown dependencies: - - json-fleece-core >= 0.7 && < 0.8 - containers >= 0.6 && < 0.7 - dlist >= 1.0 && < 1.1 + - json-fleece-core >= 0.8 && < 0.9 + - json-fleece-openapi3 >= 0.5 && < 0.6 tests: json-fleece-markdown-test: diff --git a/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs b/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs index 31fedbe5..63c2c9d9 100644 --- a/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs +++ b/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} module Fleece.Markdown.FleeceInstance @@ -36,6 +37,7 @@ import Fleece.Markdown.SchemaDocumentation , TaggedUnionMemberDocumentation (TaggedUnionMemberDocumentation, tagFields, tagValue) , schemaSelfReference ) +import qualified Fleece.OpenApi3 as FleeceOpenApi3 newtype Markdown a = Markdown SchemaDocumentation @@ -59,6 +61,9 @@ instance FC.Fleece Markdown where newtype TaggedUnionMembers Markdown _allTags _handledTags = TaggedUnionMembers (DList.DList TaggedUnionMemberDocumentation) + newtype Validator Markdown a b = MarkdownValidator (FC.NoOpValidator a b) + deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator) + schemaName (Markdown schemaDoc) = schemaName schemaDoc @@ -122,7 +127,7 @@ instance FC.Fleece Markdown where , schemaReferences = foldMap (schemaSelfReference . fieldSchemaDocs) fields } - validateNamed _name _check _unvalidate (Markdown schemaDocs) = + validateNamed _validator _unvalidate (Markdown schemaDocs) = Markdown schemaDocs boundedEnumNamed name toText = diff --git a/json-fleece-openapi3/examples/star-trek/package.yaml b/json-fleece-openapi3/examples/star-trek/package.yaml index ba4ca2b9..bcb2fe63 100644 --- a/json-fleece-openapi3/examples/star-trek/package.yaml +++ b/json-fleece-openapi3/examples/star-trek/package.yaml @@ -13,7 +13,7 @@ dependencies: - base >= 4.7 && < 5 - text - scientific - - json-fleece-core >= 0.1.3 && < 0.8 + - json-fleece-core >= 0.8 && < 0.9 - json-fleece-aeson-beeline >= 0.2 && < 0.3 - beeline-routing >= 0.2.4 && < 0.3 - beeline-http-client >= 0.8 && < 0.9 diff --git a/json-fleece-openapi3/examples/star-trek/stack.yaml b/json-fleece-openapi3/examples/star-trek/stack.yaml index 29f3eb6b..f52b7844 100644 --- a/json-fleece-openapi3/examples/star-trek/stack.yaml +++ b/json-fleece-openapi3/examples/star-trek/stack.yaml @@ -27,6 +27,8 @@ extra-deps: - ../../../json-fleece-core - ../../../json-fleece-aeson - ../../../json-fleece-aeson-beeline + - ../../../json-fleece-openapi3 + - ../../../json-fleece-codegen-util - git: https://github.com/flipstone/beeline commit: 343c3e5fabc812e5c32efa33ddf8a6cee965e8b0 subdirs: diff --git a/json-fleece-openapi3/examples/star-trek/star-trek.cabal b/json-fleece-openapi3/examples/star-trek/star-trek.cabal index 5e236d9d..661d222d 100644 --- a/json-fleece-openapi3/examples/star-trek/star-trek.cabal +++ b/json-fleece-openapi3/examples/star-trek/star-trek.cabal @@ -1870,7 +1870,7 @@ library , beeline-http-client ==0.8.* , beeline-routing >=0.2.4 && <0.3 , json-fleece-aeson-beeline ==0.2.* - , json-fleece-core >=0.1.3 && <0.8 + , json-fleece-core ==0.8.* , scientific , text , time diff --git a/json-fleece-openapi3/examples/test-cases/package.yaml b/json-fleece-openapi3/examples/test-cases/package.yaml index e747d5f2..484dc6af 100644 --- a/json-fleece-openapi3/examples/test-cases/package.yaml +++ b/json-fleece-openapi3/examples/test-cases/package.yaml @@ -14,7 +14,7 @@ dependencies: - containers - text - scientific - - json-fleece-core >= 0.1.3 && < 0.8 + - json-fleece-core >= 0.8 && < 0.9 - json-fleece-aeson-beeline >= 0.2 && < 0.3 - beeline-routing >= 0.2.4 && < 0.3 - beeline-http-client >= 0.8 && < 0.9 diff --git a/json-fleece-openapi3/examples/test-cases/stack.yaml b/json-fleece-openapi3/examples/test-cases/stack.yaml index 29f3eb6b..f52b7844 100644 --- a/json-fleece-openapi3/examples/test-cases/stack.yaml +++ b/json-fleece-openapi3/examples/test-cases/stack.yaml @@ -27,6 +27,8 @@ extra-deps: - ../../../json-fleece-core - ../../../json-fleece-aeson - ../../../json-fleece-aeson-beeline + - ../../../json-fleece-openapi3 + - ../../../json-fleece-codegen-util - git: https://github.com/flipstone/beeline commit: 343c3e5fabc812e5c32efa33ddf8a6cee965e8b0 subdirs: diff --git a/json-fleece-openapi3/examples/test-cases/test-cases.cabal b/json-fleece-openapi3/examples/test-cases/test-cases.cabal index c9d67306..4f08fcc9 100644 --- a/json-fleece-openapi3/examples/test-cases/test-cases.cabal +++ b/json-fleece-openapi3/examples/test-cases/test-cases.cabal @@ -198,7 +198,7 @@ library , beeline-routing >=0.2.4 && <0.3 , containers , json-fleece-aeson-beeline ==0.2.* - , json-fleece-core >=0.1.3 && <0.8 + , json-fleece-core ==0.8.* , scientific , shrubbery ==0.2.* , text diff --git a/json-fleece-openapi3/json-fleece-openapi3.cabal b/json-fleece-openapi3/json-fleece-openapi3.cabal index ed311330..f66bf870 100644 --- a/json-fleece-openapi3/json-fleece-openapi3.cabal +++ b/json-fleece-openapi3/json-fleece-openapi3.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-openapi3 -version: 0.4.3.1 +version: 0.5.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -2049,6 +2049,10 @@ library exposed-modules: Fleece.OpenApi3 other-modules: + Fleece.OpenApi3.CodeGen + Fleece.OpenApi3.Schemas + Fleece.OpenApi3.Schemas.OpenApi3Validator + Fleece.OpenApi3.Schemas.Schemas Paths_json_fleece_openapi3 hs-source-dirs: src @@ -2058,10 +2062,14 @@ library , containers ==0.6.* , insert-ordered-containers ==0.2.* , json-fleece-codegen-util >=0.9 && <0.11 + , json-fleece-core ==0.8.* , mtl >=2.2 && <2.4 , non-empty-text ==0.2.* , openapi3 ==3.2.* + , scientific >=0.3.7 && <0.4 , text >=1.2 && <2.1 + , time >=1.11 && <1.13 + , vector >=0.12 && <0.14 default-language: Haskell2010 if flag(strict) ghc-options: -Weverything -Werror -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-missing-deriving-strategies -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-unticked-promoted-constructors diff --git a/json-fleece-openapi3/package.yaml b/json-fleece-openapi3/package.yaml index 038cc779..a7ebbb9d 100644 --- a/json-fleece-openapi3/package.yaml +++ b/json-fleece-openapi3/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-openapi3 -version: 0.4.3.1 +version: 0.5.0.0 github: "flipstone/json-fleece/json-fleece-openapi3" license: BSD3 author: "Author name here" @@ -61,12 +61,16 @@ library: - Fleece.OpenApi3 dependencies: - aeson >= 2.0 && < 2.2 - - insert-ordered-containers >= 0.2 && < 0.3 - containers >= 0.6 && < 0.7 + - insert-ordered-containers >= 0.2 && < 0.3 + - json-fleece-core >= 0.8 && < 0.9 - mtl >= 2.2 && < 2.4 - non-empty-text >= 0.2 && < 0.3 - openapi3 >= 3.2 && < 3.3 + - scientific >= 0.3.7 && < 0.4 - text >= 1.2 && < 2.1 + - time >= 1.11 && < 1.13 + - vector >= 0.12 && < 0.14 executables: fleece-openapi3: diff --git a/json-fleece-openapi3/src/Fleece/OpenApi3.hs b/json-fleece-openapi3/src/Fleece/OpenApi3.hs index 39d836ff..4d909eac 100644 --- a/json-fleece-openapi3/src/Fleece/OpenApi3.hs +++ b/json-fleece-openapi3/src/Fleece/OpenApi3.hs @@ -1,1378 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} -module Fleece.OpenApi3 - ( generateOpenApiFleeceCode - ) where +module Fleece.OpenApi3 (module Export) where -import Control.Monad (join, when, (<=<)) -import Control.Monad.Reader (asks) -import qualified Data.Aeson as Aeson -import Data.Bifunctor (bimap, first) -import qualified Data.HashMap.Strict.InsOrd as IOHM -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, mapMaybe) -import qualified Data.NonEmptyText as NET -import qualified Data.OpenApi as OA -import qualified Data.Text as T - -import qualified Fleece.CodeGenUtil as CGU -import qualified Fleece.CodeGenUtil.HaskellCode as HC - -generateOpenApiFleeceCode :: - OA.OpenApi -> - CGU.CodeGen CGU.Modules -generateOpenApiFleeceCode openApi = do - typeMap <- mkCodeGenTypes openApi - CGU.generateFleeceCode typeMap - -type SchemaMap = - Map.Map CGU.CodeGenKey SchemaEntry - -data SchemaEntry = SchemaEntry - { schemaCodeGenType :: CGU.CodeGenType - , schemaOpenApiSchema :: OA.Schema - } - -unionsErrorOnConflict :: - [Map.Map CGU.CodeGenKey a] -> - CGU.CodeGen (Map.Map CGU.CodeGenKey a) -unionsErrorOnConflict maps = - let - conflictOnError key _a _b = - CGU.codeGenError ("Duplicate key found: " <> show key) - in - sequence $ - foldr - (Map.unionWithKey conflictOnError) - mempty - (fmap (fmap pure) maps) - -mkCodeGenTypes :: OA.OpenApi -> CGU.CodeGen CGU.CodeGenMap -mkCodeGenTypes openApi = do - let - components = OA._openApiComponents openApi - - schemaMaps <- - traverse (uncurry (mkSchemaMap CGU.Type)) - . IOHM.toList - $ OA._componentsSchemas components - - schemaMap <- unionsErrorOnConflict schemaMaps - - let - pathItems = - IOHM.toList - . OA._openApiPaths - $ openApi - - codeGenMap = - fmap (CGU.CodeGenItemType . schemaCodeGenType) schemaMap - - pathTypes <- traverse (uncurry $ mkPathItem (OA._componentsParameters components) schemaMap) pathItems - unionsErrorOnConflict (codeGenMap : pathTypes) - -mkPathItem :: OA.Definitions OA.Param -> SchemaMap -> FilePath -> OA.PathItem -> CGU.CodeGen CGU.CodeGenMap -mkPathItem paramDefs schemaMap filePath pathItem = do - let - methodOperations = - pathItemOperations pathItem - - nameStrategy = - if length methodOperations > 1 - then FallbackOperationNameIncludeMethod - else FallbackOperationNameOmitMethod - - operationCodeGenMaps <- - traverse - (uncurry $ mkOperation paramDefs schemaMap filePath pathItem nameStrategy) - methodOperations - - unionsErrorOnConflict operationCodeGenMaps - -pathItemOperations :: OA.PathItem -> [(T.Text, OA.Operation)] -pathItemOperations pathItem = - let - mkItem (method, accessor) = - case accessor pathItem of - Nothing -> Nothing - Just operation -> Just (method, operation) - in - mapMaybe - mkItem - [ ("GET", OA._pathItemGet) - , ("PUT", OA._pathItemPut) - , ("POST", OA._pathItemPost) - , ("DELETE", OA._pathItemDelete) - , ("OPTIONS", OA._pathItemOptions) - , ("HEAD", OA._pathItemHead) - , ("PATCH", OA._pathItemPatch) - , ("TRACE", OA._pathItemTrace) - ] - -data FallbackOperationNamingStrategy - = FallbackOperationNameIncludeMethod - | FallbackOperationNameOmitMethod - -mkOperation :: - OA.Definitions OA.Param -> - SchemaMap -> - FilePath -> - OA.PathItem -> - FallbackOperationNamingStrategy -> - T.Text -> - OA.Operation -> - CGU.CodeGen CGU.CodeGenMap -mkOperation paramDefs schemaMap filePath pathItem nameStrategy method operation = do - let - pathTextParts = - filter (not . T.null) - . T.splitOn "/" - . T.pack - $ filePath - - operationKey = - case OA._operationOperationId operation of - Just operationId -> operationId - Nothing -> - let - pathKey = - T.intercalate "." pathTextParts - in - case nameStrategy of - FallbackOperationNameOmitMethod -> pathKey - FallbackOperationNameIncludeMethod -> pathKey <> "." <> method - - params <- - mkOperationParams paramDefs schemaMap operationKey pathItem operation - - let - lookupParamRef name = - case Map.lookup name params of - Just codeGenParam -> - pure $ - CGU.PathParamRef - (CGU.codeGenOperationParamName codeGenParam) - (CGU.codeGenOperationParamTypeName codeGenParam) - (CGU.codeGenOperationParamDefName codeGenParam) - Nothing -> - CGU.codeGenError $ - "Parameter definition not found for " - <> show name - <> " param of " - <> show method - <> " operation for " - <> filePath - - mkPiece text = - if "{" `T.isPrefixOf` text && "}" `T.isSuffixOf` text - then lookupParamRef (T.drop 1 . T.dropEnd 1 $ text) - else pure (CGU.PathLiteral text) - - pathPieces <- traverse mkPiece pathTextParts - - mbRequestBody <- lookupRequestBody operationKey operation - - let - mbJSONMedia = - IOHM.lookup "application/json" - . OA._requestBodyContent - =<< mbRequestBody - - mbRequestBodySchema <- - fmap join - . traverse (lookupRequestBodySchema operationKey schemaMap) - $ mbJSONMedia - - responses <- - lookupResponses - operationKey - schemaMap - (OA._operationResponses operation) - - let - codeGenOperation = - CGU.CodeGenOperation - { CGU.codeGenOperationOriginalName = operationKey - , CGU.codeGenOperationMethod = method - , CGU.codeGenOperationPath = pathPieces - , CGU.codeGenOperationParams = Map.elems params - , CGU.codeGenOperationRequestBody = fmap schemaTypeInfoDependent mbRequestBodySchema - , CGU.codeGenOperationResponses = fmap (fmap schemaTypeInfoDependent) responses - } - - mkParamEntry (paramName, param) = - ( CGU.ParamKey (operationKey <> "." <> paramName) - , CGU.CodeGenItemOperationParam param - ) - - paramModules = - Map.fromList - . map mkParamEntry - . Map.toList - $ params - - requestBodyModules = - fmap (CGU.CodeGenItemType . schemaCodeGenType) - . maybe mempty schemaTypeInfoDependencies - $ mbRequestBodySchema - - responseBodyModules = - fmap (CGU.CodeGenItemType . schemaCodeGenType) - . foldMap (maybe mempty schemaTypeInfoDependencies) - $ responses - - pure $ - Map.singleton (CGU.OperationKey operationKey) (CGU.CodeGenItemOperation codeGenOperation) - <> paramModules - <> requestBodyModules - <> responseBodyModules - -lookupRequestBody :: - T.Text -> - OA.Operation -> - CGU.CodeGen (Maybe OA.RequestBody) -lookupRequestBody operationKey operation = - case OA._operationRequestBody operation of - Just (OA.Ref _reference) -> - CGU.codeGenError $ - "Error finding request body for operation " - <> show operationKey - <> ": request body references are not currently supported." - Just (OA.Inline body) -> - pure (Just body) - Nothing -> - pure Nothing - -data SchemaTypeInfoWithDeps = SchemaTypeInfoWithDeps - { schemaTypeInfoDependent :: CGU.SchemaTypeInfoOrRef - , schemaTypeInfoDependencies :: SchemaMap - } - -schemaInfoWithoutDependencies :: CGU.SchemaTypeInfo -> SchemaTypeInfoWithDeps -schemaInfoWithoutDependencies schemaTypeInfo = - SchemaTypeInfoWithDeps - { schemaTypeInfoDependent = Left schemaTypeInfo - , schemaTypeInfoDependencies = Map.empty - } - -fmapSchemaInfoAndDeps :: - (CGU.SchemaTypeInfoOrRef -> CGU.SchemaTypeInfoOrRef) -> - SchemaTypeInfoWithDeps -> - SchemaTypeInfoWithDeps -fmapSchemaInfoAndDeps f schemaTypeInfoWithDeps = - schemaTypeInfoWithDeps - { schemaTypeInfoDependent = f $ schemaTypeInfoDependent schemaTypeInfoWithDeps - } - -lookupRequestBodySchema :: - T.Text -> - SchemaMap -> - OA.MediaTypeObject -> - CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) -lookupRequestBodySchema operationKey schemaMap mediaTypeObject = - let - requestError msg = - CGU.codeGenError $ - "Error finding request body schema for operation " - <> show operationKey - <> ": " - <> msg - in - case OA._mediaTypeObjectSchema mediaTypeObject of - Just (OA.Ref (OA.Reference refKey)) -> - case Map.lookup (CGU.SchemaKey refKey) schemaMap of - Just schemaEntry -> - pure - . Just - . schemaInfoWithoutDependencies - . CGU.codeGenTypeSchemaInfo - . schemaCodeGenType - $ schemaEntry - Nothing -> - requestError $ - "Unable to resolve schema reference " - <> show refKey - <> "." - Just (OA.Inline schema) -> do - fmap Just $ - mkInlineBodySchema - requestError - (operationKey <> ".RequestBody") - schemaMap - schema - Nothing -> - pure Nothing - -lookupResponses :: - T.Text -> - SchemaMap -> - OA.Responses -> - CGU.CodeGen (Map.Map CGU.ResponseStatus (Maybe SchemaTypeInfoWithDeps)) -lookupResponses operationKey schemaMap responses = - let - statusCodeEntries = - Map.fromList - . map (\(status, responseRef) -> (CGU.ResponseStatusCode status, responseRef)) - . IOHM.toList - . OA._responsesResponses - $ responses - - allEntries = - case OA._responsesDefault responses of - Just defaultResponseRef -> - Map.insert CGU.DefaultResponse defaultResponseRef statusCodeEntries - Nothing -> statusCodeEntries - in - Map.traverseWithKey - (lookupResponseBodySchema operationKey schemaMap) - allEntries - -lookupResponseBodySchema :: - T.Text -> - SchemaMap -> - CGU.ResponseStatus -> - OA.Referenced OA.Response -> - CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) -lookupResponseBodySchema operationKey schemaMap responseStatus responseRef = - let - responseError msg = - CGU.codeGenError $ - "Error looking up response for operation " - <> show operationKey - <> ": " - <> msg - - lookupCodeGenType refKey = - case Map.lookup (CGU.SchemaKey refKey) schemaMap of - Just schemaEntry -> - pure . CGU.codeGenTypeSchemaInfo . schemaCodeGenType $ schemaEntry - Nothing -> - responseError $ - "Unable to resolve schema reference " - <> show refKey - <> "." - in - case responseRef of - OA.Ref _reference -> - responseError "Response references are not yet supported." - OA.Inline response -> - case IOHM.lookup "application/json" (OA._responseContent response) of - Nothing -> pure Nothing - Just mediaTypeObject -> - fmap Just $ - case OA._mediaTypeObjectSchema mediaTypeObject of - Just (OA.Ref (OA.Reference refKey)) -> - fmap schemaInfoWithoutDependencies (lookupCodeGenType refKey) - Just (OA.Inline schema) -> - let - responseName = - T.pack $ - case responseStatus of - CGU.ResponseStatusCode n -> - "Response" <> show n <> "Body" - CGU.DefaultResponse -> - "DefaultResponseBody" - in - mkInlineBodySchema - responseError - (operationKey <> "." <> responseName) - schemaMap - schema - Nothing -> - -- This indicates that the empty schema was specified for - -- the media type. - pure (schemaInfoWithoutDependencies CGU.anyJSONSchemaTypeInfo) - -mkInlineStringSchema :: - T.Text -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineStringSchema schemaKey schema = do - case OA._schemaEnum schema of - Nothing -> pure . schemaInfoWithoutDependencies $ CGU.textSchemaTypeInfo - Just _values -> do - (_moduleName, typeName) <- CGU.inferTypeForInputName CGU.Operation schemaKey - mbInlinedTypesAndSchemaTypeInfo <- - mkSchemaTypeInfo - schemaKey - typeName - schema - case mbInlinedTypesAndSchemaTypeInfo of - Just (inlinedTypes, schemaTypeInfo) -> - pure $ - SchemaTypeInfoWithDeps - { schemaTypeInfoDependent = Left schemaTypeInfo - , schemaTypeInfoDependencies = inlinedTypes - } - Nothing -> pure . schemaInfoWithoutDependencies $ CGU.textSchemaTypeInfo - -mkInlineBoolSchema :: CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineBoolSchema = - pure . schemaInfoWithoutDependencies $ CGU.boolSchemaTypeInfo - -mkInlineIntegerSchema :: - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineIntegerSchema schema = - pure - . schemaInfoWithoutDependencies - $ case OA._schemaFormat schema of - Just "int32" -> CGU.int32SchemaTypeInfo - Just "int64" -> CGU.int64SchemaTypeInfo - Just _ -> CGU.integerSchemaTypeInfo - Nothing -> CGU.integerSchemaTypeInfo - -mkInlineBodyObjectSchema :: - (forall a. String -> CGU.CodeGen a) -> - T.Text -> - SchemaMap -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineBodyObjectSchema raiseError schemaKey schemaMap schema = - if IOHM.null (OA._schemaProperties schema) - then do - mbAdditionalPropertiesMapSchema <- - mkAdditionalPropertiesMapSchema - raiseError - schemaKey - (\key itemSchema -> mkInlineBodySchema raiseError key schemaMap itemSchema) - (OA._schemaAdditionalProperties schema) - case mbAdditionalPropertiesMapSchema of - Just additionalPropertiesMapSchema -> - pure additionalPropertiesMapSchema - Nothing -> - mkInlineBodyObjectWithNoAdditionalPropertiesSchema schemaKey schema - else mkInlineBodyObjectWithNoAdditionalPropertiesSchema schemaKey schema - -mkInlineBodyObjectWithNoAdditionalPropertiesSchema :: - T.Text -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineBodyObjectWithNoAdditionalPropertiesSchema schemaKey schema = do - (_moduleName, typeName) <- CGU.inferTypeForInputName CGU.Operation schemaKey - (fieldsSchemaMap, dataFormat) <- - mkOpenApiObjectFormat - CGU.Operation - schemaKey - typeName - schema - - schemaTypeInfo <- CGU.inferSchemaInfoForTypeName typeName - - let - codeGenType = - CGU.CodeGenType - { CGU.codeGenTypeOriginalName = schemaKey - , CGU.codeGenTypeName = typeName - , CGU.codeGenTypeSchemaInfo = schemaTypeInfo - , CGU.codeGenTypeDescription = - NET.fromText =<< OA._schemaDescription schema - , CGU.codeGenTypeDataFormat = dataFormat - } - - schemaEntry = - SchemaEntry - { schemaOpenApiSchema = schema - , schemaCodeGenType = codeGenType - } - - codeGenModules = - Map.insert - (CGU.SchemaKey schemaKey) - schemaEntry - fieldsSchemaMap - - pure $ - SchemaTypeInfoWithDeps - { schemaTypeInfoDependent = Left schemaTypeInfo - , schemaTypeInfoDependencies = codeGenModules - } - -mkInlineArraySchema :: - (forall a. String -> CGU.CodeGen a) -> - T.Text -> - SchemaMap -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineArraySchema raiseError schemaKey schemaMap schema = - let - lookupCodeGenType refKey = - case Map.lookup (CGU.SchemaKey refKey) schemaMap of - Just schemaEntry -> - pure . CGU.codeGenTypeSchemaInfo . schemaCodeGenType $ schemaEntry - Nothing -> - raiseError $ - "Unable to resolve schema reference " - <> show refKey - <> "." - in - case OA._schemaItems schema of - Just (OA.OpenApiItemsObject (OA.Ref (OA.Reference itemRefKey))) -> do - itemSchemaInfo <- lookupCodeGenType itemRefKey - pure . schemaInfoWithoutDependencies . CGU.arrayLikeTypeInfo (OA._schemaMinItems schema) $ itemSchemaInfo - Just (OA.OpenApiItemsObject (OA.Inline innerSchema)) -> - let - itemKey = - schemaKey <> "Item" - in - fmap - (fmapSchemaInfoAndDeps $ first $ CGU.arrayLikeTypeInfo $ OA._schemaMinItems schema) - (mkInlineBodySchema raiseError itemKey schemaMap innerSchema) - otherItemType -> - raiseError $ - "Unsupported schema array item type found: " - <> show otherItemType - -mkInlineArrayOneOfSchema :: - (forall a. String -> CGU.CodeGen a) -> - T.Text -> - SchemaMap -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineArrayOneOfSchema raiseError schemaKey schemaMap schema = - let - minItems = OA._schemaMinItems schema - in - case OA._schemaItems schema of - Just (OA.OpenApiItemsObject (OA.Ref ref)) -> do - pure $ - SchemaTypeInfoWithDeps - { schemaTypeInfoDependent = Right $ CGU.CodeGenRefArray minItems $ CGU.TypeReference $ OA.getReference ref - , schemaTypeInfoDependencies = mempty - } - Just (OA.OpenApiItemsObject (OA.Inline innerSchema)) -> - let - itemKey = - schemaKey <> "Item" - in - fmap - (fmapSchemaInfoAndDeps (bimap (CGU.arrayLikeTypeInfo minItems) $ CGU.CodeGenRefArray minItems)) - (mkInlineOneOfSchema raiseError itemKey schemaMap innerSchema) - otherItemType -> - raiseError $ - "Unsupported schema array item type found: " - <> show otherItemType - -applyNullable :: OA.Schema -> SchemaTypeInfoWithDeps -> SchemaTypeInfoWithDeps -applyNullable schema = - if OA._schemaNullable schema == Just True - then fmapSchemaInfoAndDeps (bimap CGU.nullableTypeInfo CGU.CodeGenRefNullable) - else id - -mkInlineBodySchema :: - (forall a. String -> CGU.CodeGen a) -> - T.Text -> - SchemaMap -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineBodySchema raiseError schemaKey schemaMap schema = - applyNullable schema <$> case OA._schemaType schema of - Just OA.OpenApiArray -> mkInlineArraySchema raiseError schemaKey schemaMap schema - Just OA.OpenApiString -> mkInlineStringSchema schemaKey schema - Just OA.OpenApiBoolean -> mkInlineBoolSchema - Just OA.OpenApiInteger -> mkInlineIntegerSchema schema - Just OA.OpenApiObject -> mkInlineBodyObjectSchema raiseError schemaKey schemaMap schema - Just s -> raiseError $ "Inline " <> show s <> " schemas are not currently supported." - Nothing -> raiseError "Inline schema doesn't have a type." - -mkInlineOneOfSchema :: - (forall a. String -> CGU.CodeGen a) -> - T.Text -> - SchemaMap -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkInlineOneOfSchema raiseError schemaKey schemaMap schema = - applyNullable schema <$> case OA._schemaType schema of - Just OA.OpenApiArray -> mkInlineArrayOneOfSchema raiseError schemaKey schemaMap schema - Just OA.OpenApiString -> mkInlineStringSchema schemaKey schema - Just OA.OpenApiBoolean -> mkInlineBoolSchema - Just OA.OpenApiInteger -> mkInlineIntegerSchema schema - Just OA.OpenApiObject -> raiseError "Inline OpenApiObject schemas are not currently supported in oneOf." - Just s -> raiseError $ "Inline " <> show s <> " schemas are not currently supported." - Nothing -> raiseError "Inline schema doesn't have a type." - -mkOperationParams :: - OA.Definitions OA.Param -> - SchemaMap -> - T.Text -> - OA.PathItem -> - OA.Operation -> - CGU.CodeGen (Map.Map T.Text CGU.CodeGenOperationParam) -mkOperationParams paramDefs schemaMap operationKey pathItem operation = do - paramList <- - traverse - (mkOperationParam paramDefs schemaMap operationKey) - (OA._pathItemParameters pathItem <> OA._operationParameters operation) - - let - paramMap = - Map.fromList - . map (\param -> (CGU.codeGenOperationParamName param, param)) - $ paramList - - pure paramMap - -mkOperationParam :: - OA.Definitions OA.Param -> - SchemaMap -> - T.Text -> - OA.Referenced OA.Param -> - CGU.CodeGen CGU.CodeGenOperationParam -mkOperationParam paramDefs schemaMap operationKey paramRef = do - param <- - case paramRef of - OA.Ref name -> do - let - txtName = OA.getReference name - case IOHM.lookup txtName paramDefs of - Nothing -> - CGU.codeGenError $ - "Couldn't not find param def '" - <> T.unpack txtName - <> "', keys are: " - <> show (IOHM.keys paramDefs) - Just x -> pure x - OA.Inline param -> pure param - - let - paramName = - OA._paramName param - - (moduleName, defaultParamTypeName) <- - CGU.inferTypeForInputName CGU.Operation (operationKey <> "." <> paramName) - - case OA._paramSchema param of - Just schemaRef -> do - paramInfo <- - schemaRefToParamInfo - schemaMap - paramName - (OA._paramIn param) - operationKey - schemaRef - - let - paramTypeName = - case paramInfoTypeName paramInfo of - Nothing -> defaultParamTypeName - Just resolvedName -> resolvedName - - paramRequired = - case OA._paramRequired param of - Nothing -> False - Just req -> req - - arity = - case (paramRequired, paramInfoArray paramInfo) of - (True, False) -> CGU.ExactlyOne - (False, False) -> CGU.AtMostOne - (True, True) -> CGU.AtLeastOne - (False, True) -> CGU.AtLeastZero - - paramLocation <- - case OA._paramIn param of - OA.ParamQuery -> pure CGU.ParamLocationQuery - OA.ParamPath -> pure CGU.ParamLocationPath - OA.ParamHeader -> pure CGU.ParamLocationHeader - OA.ParamCookie -> paramCodeGenError paramName operationKey "Cookie params not supported." - - typeOptions <- CGU.lookupTypeOptions paramTypeName - - pure - CGU.CodeGenOperationParam - { CGU.codeGenOperationParamName = paramName - , CGU.codeGenOperationParamArity = arity - , CGU.codeGenOperationParamModuleName = moduleName - , CGU.codeGenOperationParamTypeName = paramTypeName - , CGU.codeGenOperationParamFormat = paramInfoFormat paramInfo - , CGU.codeGenOperationParamLocation = paramLocation - , CGU.codeGenOperationParamDefName = - HC.toVarName - moduleName - (Just (HC.typeNameText paramTypeName)) - "paramDef" - , CGU.codeGenOperationParamTypeOptions = typeOptions - } - Nothing -> - paramCodeGenError paramName operationKey "No param schema found." - -paramCodeGenError :: T.Text -> T.Text -> String -> CGU.CodeGen a -paramCodeGenError paramName operationKey msg = - CGU.codeGenError $ - "Error handing param " - <> T.unpack paramName - <> " of operation " - <> T.unpack operationKey - <> ": " - <> msg - -data ParamInfo = ParamInfo - { paramInfoTypeName :: Maybe HC.TypeName - , paramInfoArray :: Bool - , paramInfoFormat :: CGU.OperationParamFormat - } - -primitiveParamInfo :: CGU.OperationParamFormat -> ParamInfo -primitiveParamInfo format = - ParamInfo - { paramInfoTypeName = Nothing - , paramInfoArray = False - , paramInfoFormat = format - } - -schemaRefToParamInfo :: - SchemaMap -> - T.Text -> - OA.ParamLocation -> - T.Text -> - OA.Referenced OA.Schema -> - CGU.CodeGen ParamInfo -schemaRefToParamInfo schemaMap paramName paramLocation operationKey schemaRef = - case schemaRef of - OA.Inline schema -> do - schemaTypeToParamInfo - schemaMap - paramName - paramLocation - operationKey - schema - OA.Ref (OA.Reference refKey) -> - case Map.lookup (CGU.SchemaKey refKey) schemaMap of - Just schemaEntry -> do - let - codeGenType = - schemaCodeGenType schemaEntry - - paramInfo <- - schemaTypeToParamInfo - schemaMap - paramName - paramLocation - operationKey - (schemaOpenApiSchema schemaEntry) - - pure $ - paramInfo - { paramInfoTypeName = Just (CGU.codeGenTypeName codeGenType) - } - Nothing -> - paramCodeGenError paramName operationKey $ - "Schema reference " - <> show refKey - <> " not found." - -schemaTypeToParamInfo :: - SchemaMap -> - T.Text -> - OA.ParamLocation -> - T.Text -> - OA.Schema -> - CGU.CodeGen ParamInfo -schemaTypeToParamInfo schemaMap paramName paramLocation operationKey schema = - case OA._schemaType schema of - Just OA.OpenApiString -> - case OA._schemaEnum schema of - Nothing -> - pure (primitiveParamInfo CGU.ParamTypeString) - Just enumValues -> do - let - rejectNull mbText = - case mbText of - Nothing -> CGU.codeGenError "null not supported as enum value in params" - Just text -> pure text - - enumTexts <- - traverse (rejectNull <=< enumValueToText paramName schema) enumValues - - pure - . primitiveParamInfo - . CGU.ParamTypeEnum - $ enumTexts - Just OA.OpenApiBoolean -> - pure (primitiveParamInfo CGU.ParamTypeBoolean) - Just OA.OpenApiInteger -> - case OA._schemaFormat schema of - Just "int8" -> pure (primitiveParamInfo CGU.ParamTypeInt8) - Just "int16" -> pure (primitiveParamInfo CGU.ParamTypeInt16) - Just "int32" -> pure (primitiveParamInfo CGU.ParamTypeInt32) - Just "int64" -> pure (primitiveParamInfo CGU.ParamTypeInt64) - _ -> pure (primitiveParamInfo CGU.ParamTypeInteger) - Just OA.OpenApiNumber -> - case OA._schemaFormat schema of - Just "double" -> pure (primitiveParamInfo CGU.ParamTypeDouble) - Just "float" -> pure (primitiveParamInfo CGU.ParamTypeFloat) - _ -> pure (primitiveParamInfo CGU.ParamTypeScientific) - Just OA.OpenApiArray -> - let - arrayParamSchema = - case OA._schemaItems schema of - Just (OA.OpenApiItemsObject itemSchemaRef) -> do - itemInfo <- - schemaRefToParamInfo - schemaMap - paramName - paramLocation - operationKey - itemSchemaRef - - if paramInfoArray itemInfo - then - paramCodeGenError - paramName - operationKey - "Array of arrays not support for param" - else - pure $ - itemInfo - { paramInfoArray = True - } - otherItemType -> - paramCodeGenError paramName operationKey $ - "Unsupported schema array item type found: " - <> show otherItemType - in - case paramLocation of - OA.ParamQuery -> arrayParamSchema - OA.ParamHeader -> arrayParamSchema - otherLocation -> - paramCodeGenError paramName operationKey $ - "Array parameters are not supported for " - <> show otherLocation - <> " paremeters." - Just otherType -> - paramCodeGenError paramName operationKey $ - "Unsupported schema type found for param: " - <> show otherType - Nothing -> - paramCodeGenError paramName operationKey $ - "No schema type found." - -mkSchemaMap :: CGU.CodeSection -> T.Text -> OA.Schema -> CGU.CodeGen SchemaMap -mkSchemaMap section schemaKey schema = do - (_moduleName, typeName) <- CGU.inferTypeForInputName section schemaKey - maybe Map.empty fst <$> mkSchemaTypeInfo schemaKey typeName schema - -mkSchemaTypeInfo :: - T.Text -> - HC.TypeName -> - OA.Schema -> - CGU.CodeGen (Maybe (SchemaMap, CGU.SchemaTypeInfo)) -mkSchemaTypeInfo schemaKey typeName schema = do - baseSchemaInfo <- CGU.inferSchemaInfoForTypeName typeName - mbOpenApiDataFormat <- mkOpenApiDataFormat schemaKey typeName schema - - case mbOpenApiDataFormat of - Just (inlinedTypes, dataFormat) -> - let - schemaInfo = - case OA._schemaNullable schema of - Just True -> CGU.nullableTypeInfo baseSchemaInfo - _ -> baseSchemaInfo - - codeGenType = - CGU.CodeGenType - { CGU.codeGenTypeOriginalName = schemaKey - , CGU.codeGenTypeName = typeName - , CGU.codeGenTypeSchemaInfo = schemaInfo - , CGU.codeGenTypeDescription = NET.fromText =<< OA._schemaDescription schema - , CGU.codeGenTypeDataFormat = dataFormat - } - - schemaEntry = - SchemaEntry - { schemaOpenApiSchema = schema - , schemaCodeGenType = codeGenType - } - - schemaMap = - Map.singleton (CGU.SchemaKey schemaKey) schemaEntry <> inlinedTypes - in - pure $ Just (schemaMap, schemaInfo) - Nothing -> - pure Nothing - -mkOpenApiDataFormat :: - T.Text -> - HC.TypeName -> - OA.Schema -> - CGU.CodeGen (Maybe (SchemaMap, CGU.CodeGenDataFormat)) -mkOpenApiDataFormat schemaKey typeName schema = - let - noRefs mkFormat = do - dataFormat <- mkFormat - pure $ Just (Map.empty, dataFormat) - in - case OA._schemaOneOf schema of - Just schemas -> - case OA._schemaDiscriminator schema of - Nothing -> - Just <$> mkOneOfUnion schemaKey schemas - Just discriminator -> - Just <$> mkOneOfTaggedUnion discriminator schemaKey - Nothing -> - case OA._schemaType schema of - Just OA.OpenApiString -> noRefs $ mkOpenApiStringFormat typeName schema - Just OA.OpenApiNumber -> noRefs $ mkOpenApiNumberFormat typeName schema - Just OA.OpenApiInteger -> noRefs $ mkOpenApiIntegerFormat typeName schema - Just OA.OpenApiBoolean -> do - typeOptions <- CGU.lookupTypeOptions typeName - noRefs $ pure (CGU.boolFormat typeOptions) - Just OA.OpenApiArray -> - Just <$> mkOpenApiArrayFormat schemaKey typeName schema - Just OA.OpenApiObject -> - mkOpenApiObjectFormatOrAdditionalPropertiesNewtype - CGU.Type - schemaKey - typeName - schema - Just OA.OpenApiNull -> do - typeOptions <- CGU.lookupTypeOptions typeName - noRefs $ pure (CGU.nullFormat typeOptions) - Nothing -> - mkOpenApiObjectFormatOrAdditionalPropertiesNewtype - CGU.Type - schemaKey - typeName - schema - -mkOneOfUnion :: - T.Text -> - [OA.Referenced OA.Schema] -> - CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) -mkOneOfUnion schemaKey refSchemas = do - let - processRefSchema refSchema = - case refSchema of - OA.Inline schema -> do - typeInfoWithDeps <- - mkInlineOneOfSchema - (\err -> CGU.codeGenError $ "Inside inline oneOf: " <> err) - schemaKey - mempty - schema - let - unionMember = - CGU.CodeGenUnionMember - { CGU.codeGenUnionMemberType = schemaTypeInfoDependent typeInfoWithDeps - } - pure (schemaTypeInfoDependencies typeInfoWithDeps, unionMember) - OA.Ref ref -> do - let - unionMember = - CGU.CodeGenUnionMember - { CGU.codeGenUnionMemberType = Right $ CGU.TypeReference $ OA.getReference ref - } - pure (mempty, unionMember) - - (maps, codeGenUnionMembers) <- fmap unzip . traverse processRefSchema $ refSchemas - schemaMap <- unionsErrorOnConflict maps - pure (schemaMap, CGU.CodeGenUnion codeGenUnionMembers) - -mkOneOfTaggedUnion :: - OA.Discriminator -> - T.Text -> - CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) -mkOneOfTaggedUnion discriminator _schemaKey = do - let - processMappingEntry (tag, ref) = - case T.stripPrefix "#/components/schemas/" ref of - Nothing -> - CGU.codeGenError $ - "Discriminators mappings with references to locations other than the schema components are not supported: " - <> T.unpack ref - Just typeName -> - pure $ - CGU.CodeGenTaggedUnionMember - { CGU.codeGenTaggedUnionMemberTag = tag - , CGU.codeGenTaggedUnionMemberType = Right . CGU.TypeReference $ typeName - } - - mapping = - OA._discriminatorMapping discriminator - - tagProperty = - OA._discriminatorPropertyName discriminator - - when - (IOHM.null mapping) - (CGU.codeGenError "Discriminators without mappings is not currently supported") - - codeGenTaggedUnionMembers <- - traverse processMappingEntry - . IOHM.toList - $ mapping - - pure (mempty, CGU.CodeGenTaggedUnion tagProperty codeGenTaggedUnionMembers) - -mkOpenApiStringFormat :: HC.TypeName -> OA.Schema -> CGU.CodeGen CGU.CodeGenDataFormat -mkOpenApiStringFormat typeName schema = do - typeOptions <- CGU.lookupTypeOptions typeName - case OA._schemaEnum schema of - Just enumValues -> - fmap - (CGU.enumFormat typeOptions . catMaybes) - (traverse (enumValueToText (HC.typeNameText typeName) schema) enumValues) - Nothing -> - pure $ - case OA._schemaFormat schema of - Just "date" -> - CGU.dayFormat typeOptions - Just "date-time" -> - case CGU.dateTimeFormat typeOptions of - CGU.UTCTimeFormat -> CGU.utcTimeFormat typeOptions - CGU.ZonedTimeFormat -> CGU.zonedTimeFormat typeOptions - CGU.LocalTimeFormat -> CGU.localTimeFormat typeOptions - _ -> CGU.textFormat typeOptions - -enumValueToText :: T.Text -> OA.Schema -> Aeson.Value -> CGU.CodeGen (Maybe T.Text) -enumValueToText name schema value = - case value of - Aeson.String text -> pure (Just text) - Aeson.Null -> - case OA._schemaNullable schema of - Just True -> pure Nothing - _ -> CGU.codeGenError "null listed as enum value in a non-nullable schema" - _ -> - CGU.codeGenError $ - "Non-string value found for enum in schema/parameter titled '" - <> T.unpack name - <> "', value is " - <> show value - -mkOpenApiNumberFormat :: HC.TypeName -> OA.Schema -> CGU.CodeGen CGU.CodeGenDataFormat -mkOpenApiNumberFormat typeName schema = do - typeOptions <- CGU.lookupTypeOptions typeName - pure $ - case OA._schemaFormat schema of - Just "float" -> CGU.floatFormat typeOptions - Just "double" -> CGU.doubleFormat typeOptions - _ -> CGU.scientificFormat typeOptions - -mkOpenApiIntegerFormat :: HC.TypeName -> OA.Schema -> CGU.CodeGen CGU.CodeGenDataFormat -mkOpenApiIntegerFormat typeName schema = do - typeOptions <- CGU.lookupTypeOptions typeName - pure $ - case OA._schemaFormat schema of - Just "int32" -> CGU.int32Format typeOptions - Just "int64" -> CGU.int64Format typeOptions - _ -> CGU.integerFormat typeOptions - -mkOpenApiObjectFormatOrAdditionalPropertiesNewtype :: - CGU.CodeSection -> - T.Text -> - HC.TypeName -> - OA.Schema -> - CGU.CodeGen (Maybe (SchemaMap, CGU.CodeGenDataFormat)) -mkOpenApiObjectFormatOrAdditionalPropertiesNewtype section schemaKey typeName schema = do - if IOHM.null (OA._schemaProperties schema) - then - mkOpenApiAdditionalPropertiesNewtype - section - schemaKey - typeName - schema - else Just <$> mkOpenApiObjectFormat section schemaKey typeName schema - -mkOpenApiAdditionalPropertiesNewtype :: - CGU.CodeSection -> - T.Text -> - HC.TypeName -> - OA.Schema -> - CGU.CodeGen (Maybe (SchemaMap, CGU.CodeGenDataFormat)) -mkOpenApiAdditionalPropertiesNewtype section schemaKey typeName schema = do - let - raiseError err = - CGU.codeGenError $ - "Unable to build schema for " - <> show schemaKey - <> ": " - <> err - - mbSchemaTypeInfoWithDeps <- - mkAdditionalPropertiesMapSchema - raiseError - schemaKey - (mkAdditionalPropertiesInlineItemSchema section) - (OA._schemaAdditionalProperties schema) - - case mbSchemaTypeInfoWithDeps of - Just schemaTypeInfoWithDeps -> do - typeOptions <- CGU.lookupTypeOptions typeName - - let - format = - CGU.CodeGenNewType - typeOptions - (schemaTypeInfoDependent schemaTypeInfoWithDeps) - pure $ Just (schemaTypeInfoDependencies schemaTypeInfoWithDeps, format) - Nothing -> - pure Nothing - -mkOpenApiObjectFormat :: - CGU.CodeSection -> - T.Text -> - HC.TypeName -> - OA.Schema -> - CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) -mkOpenApiObjectFormat section schemaKey typeName schema = do - let - requiredParams = - OA._schemaRequired schema - - raiseAdditionalPropsError err = - CGU.codeGenError $ - "Unable to build additionalProperties schema for " - <> show schemaKey - <> ": " - <> err - - typeOptions <- CGU.lookupTypeOptions typeName - - (fieldDependencies, fields) <- - fmap unzip - . traverse (uncurry $ propertyToCodeGenField section schemaKey requiredParams) - . filter (\(prop, _) -> prop `notElem` unsupportedProperties) - . IOHM.toList - . OA._schemaProperties - $ schema - - mbAdditionalProperties <- - case OA._schemaAdditionalProperties schema of - Nothing -> - pure Nothing - Just additionalProperties -> - mkAdditionalPropertiesSchema - raiseAdditionalPropsError - schemaKey - (mkAdditionalPropertiesInlineItemSchema section) - (Just additionalProperties) - - let - dependencies = - Map.unions - ( maybe Map.empty schemaTypeInfoDependencies mbAdditionalProperties - : fieldDependencies - ) - - mbCodeGenAdditionalProps = - fmap - (CGU.CodeGenAdditionalProperties . schemaTypeInfoDependent) - mbAdditionalProperties - - pure (dependencies, CGU.CodeGenObject typeOptions fields mbCodeGenAdditionalProps) - -mkAdditionalPropertiesInlineItemSchema :: - CGU.CodeSection -> - T.Text -> - OA.Schema -> - CGU.CodeGen SchemaTypeInfoWithDeps -mkAdditionalPropertiesInlineItemSchema section itemKey itemSchema = do - itemDependencies <- mkSchemaMap section itemKey itemSchema - (_moduleName, itemTypeName) <- CGU.inferTypeForInputName section itemKey - itemSchemaInfo <- CGU.inferSchemaInfoForTypeName itemTypeName - pure $ - SchemaTypeInfoWithDeps - { schemaTypeInfoDependent = Left itemSchemaInfo - , schemaTypeInfoDependencies = itemDependencies - } - -unsupportedProperties :: [T.Text] -unsupportedProperties = - [ "_links" - ] - -mkOpenApiArrayFormat :: - T.Text -> - HC.TypeName -> - OA.Schema -> - CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) -mkOpenApiArrayFormat schemaKey typeName schema = do - typeOptions <- CGU.lookupTypeOptions typeName - fmap (fmap (CGU.CodeGenArray typeOptions (OA._schemaMinItems schema))) $ - schemaArrayItemsToFieldType - CGU.Type - schemaKey - schema - schemaKey - (OA._schemaItems schema) - -propertyToCodeGenField :: - CGU.CodeSection -> - T.Text -> - [OA.ParamName] -> - OA.ParamName -> - OA.Referenced OA.Schema -> - CGU.CodeGen (SchemaMap, CGU.CodeGenObjectField) -propertyToCodeGenField section parentSchemaKey requiredParams name schemaRef = do - (schemaMap, codeGenFieldType) <- - schemaRefToFieldType section parentSchemaKey name schemaRef - - let - field = - CGU.CodeGenObjectField - { CGU.codeGenFieldName = name - , CGU.codeGenFieldRequired = name `elem` requiredParams - , CGU.codeGenFieldType = codeGenFieldType - } - - pure (schemaMap, field) - -schemaRefToFieldType :: - CGU.CodeSection -> - T.Text -> - OA.ParamName -> - OA.Referenced OA.Schema -> - CGU.CodeGen (SchemaMap, CGU.CodeGenRefType) -schemaRefToFieldType section parentKey fieldName schemaRef = - case schemaRef of - OA.Ref ref -> - pure (Map.empty, CGU.TypeReference . OA.getReference $ ref) - OA.Inline inlineSchema -> - case OA._schemaType inlineSchema of - Just OA.OpenApiArray -> - let - nullable = - OA._schemaNullable inlineSchema == Just True - applyNull = - if nullable - then CGU.CodeGenRefNullable - else id - minItems = - OA._schemaMinItems inlineSchema - in - fmap (fmap (applyNull . CGU.CodeGenRefArray minItems)) $ - schemaArrayItemsToFieldType - section - parentKey - inlineSchema - fieldName - (OA._schemaItems inlineSchema) - _ -> do - let - key = - parentKey <> "." <> fieldName - - childRef = - CGU.TypeReference key - - schemaMap <- mkSchemaMap section key inlineSchema - pure (schemaMap, childRef) - -schemaArrayItemsToFieldType :: - CGU.CodeSection -> - T.Text -> - OA.Schema -> - OA.ParamName -> - Maybe OA.OpenApiItems -> - CGU.CodeGen (SchemaMap, CGU.CodeGenRefType) -schemaArrayItemsToFieldType section parentKey schema fieldName arrayItems = - let - fieldError err = - CGU.codeGenError $ - "Unable to generate type for field " - <> show fieldName - <> " of object " - <> show parentKey - <> ": " - <> err - in - case arrayItems of - Just (OA.OpenApiItemsObject itemSchema) -> - schemaRefToFieldType section parentKey (fieldName <> "Item") itemSchema - Just (OA.OpenApiItemsArray []) -> do - let - key = - fieldName <> "Item" - - fieldType = - CGU.TypeReference key - - (_moduleName, typeName) <- CGU.inferTypeForInputName section key - schemaTypeInfo <- CGU.inferSchemaInfoForTypeName typeName - typeOptions <- CGU.lookupTypeOptions typeName - - let - schemaMap = - Map.singleton (CGU.SchemaKey key) $ - SchemaEntry - { schemaOpenApiSchema = schema - , schemaCodeGenType = - CGU.CodeGenType - { CGU.codeGenTypeOriginalName = key - , CGU.codeGenTypeName = typeName - , CGU.codeGenTypeSchemaInfo = schemaTypeInfo - , CGU.codeGenTypeDescription = Nothing - , CGU.codeGenTypeDataFormat = CGU.textFormat typeOptions - } - } - - pure (schemaMap, fieldType) - Just (OA.OpenApiItemsArray _itemSchemaRefs) -> - fieldError "Heterogeneous arrays are not supported" - Nothing -> - fieldError "Array schema found with no item schema" - -mkAdditionalPropertiesMapSchema :: - (forall a. String -> CGU.CodeGen a) -> - T.Text -> - (T.Text -> OA.Schema -> CGU.CodeGen SchemaTypeInfoWithDeps) -> - Maybe OA.AdditionalProperties -> - CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) -mkAdditionalPropertiesMapSchema raiseError schemaKey mkInlineItemSchema mbAdditionalProperties = do - mbSchema <- - mkAdditionalPropertiesSchema - raiseError - schemaKey - mkInlineItemSchema - mbAdditionalProperties - - pure - . fmap (fmapSchemaInfoAndDeps $ bimap CGU.mapTypeInfo CGU.CodeGenRefMap) - $ mbSchema - -mkAdditionalPropertiesSchema :: - (forall a. String -> CGU.CodeGen a) -> - T.Text -> - (T.Text -> OA.Schema -> CGU.CodeGen SchemaTypeInfoWithDeps) -> - Maybe OA.AdditionalProperties -> - CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) -mkAdditionalPropertiesSchema raiseError schemaKey mkInlineItemSchema mbAdditionalProperties = - case mbAdditionalProperties of - Nothing -> - -- No explicit properties nor additional properties are defined, - -- but the OpenAPI spec defines additional properties as - -- defaulting to True, so we handle this the same as if only - -- additional properties was defined as true. - pure - . Just - . schemaInfoWithoutDependencies - $ CGU.anyJSONSchemaTypeInfo - Just (OA.AdditionalPropertiesAllowed True) -> - pure - . Just - . schemaInfoWithoutDependencies - $ CGU.anyJSONSchemaTypeInfo - Just (OA.AdditionalPropertiesAllowed False) -> do - strictAdditionalProperties <- asks CGU.strictAdditionalProperties - if strictAdditionalProperties - then - raiseError $ - "Schemas for objects with additional properties disallowed are" - <> " not yet supported. `additionalProperties: false` can be" - <> " ignored by overriding the `strictAdditionalProperties`" - <> " field in the Fleece code gen config as false." - else pure Nothing - Just (OA.AdditionalPropertiesSchema (OA.Ref ref)) -> - pure - . Just - $ SchemaTypeInfoWithDeps - { schemaTypeInfoDependent = Right $ CGU.TypeReference $ OA.getReference ref - , schemaTypeInfoDependencies = Map.empty - } - Just (OA.AdditionalPropertiesSchema (OA.Inline innerSchema)) -> - let - itemKey = - schemaKey <> "Item" - in - Just <$> mkInlineItemSchema itemKey innerSchema +import Fleece.OpenApi3.CodeGen as Export +import Fleece.OpenApi3.Schemas as Export diff --git a/json-fleece-openapi3/src/Fleece/OpenApi3/CodeGen.hs b/json-fleece-openapi3/src/Fleece/OpenApi3/CodeGen.hs new file mode 100644 index 00000000..5088e098 --- /dev/null +++ b/json-fleece-openapi3/src/Fleece/OpenApi3/CodeGen.hs @@ -0,0 +1,1378 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Fleece.OpenApi3.CodeGen + ( generateOpenApiFleeceCode + ) where + +import Control.Monad (join, when, (<=<)) +import Control.Monad.Reader (asks) +import qualified Data.Aeson as Aeson +import Data.Bifunctor (bimap, first) +import qualified Data.HashMap.Strict.InsOrd as IOHM +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.NonEmptyText as NET +import qualified Data.OpenApi as OA +import qualified Data.Text as T + +import qualified Fleece.CodeGenUtil as CGU +import qualified Fleece.CodeGenUtil.HaskellCode as HC + +generateOpenApiFleeceCode :: + OA.OpenApi -> + CGU.CodeGen CGU.Modules +generateOpenApiFleeceCode openApi = do + typeMap <- mkCodeGenTypes openApi + CGU.generateFleeceCode typeMap + +type SchemaMap = + Map.Map CGU.CodeGenKey SchemaEntry + +data SchemaEntry = SchemaEntry + { schemaCodeGenType :: CGU.CodeGenType + , schemaOpenApiSchema :: OA.Schema + } + +unionsErrorOnConflict :: + [Map.Map CGU.CodeGenKey a] -> + CGU.CodeGen (Map.Map CGU.CodeGenKey a) +unionsErrorOnConflict maps = + let + conflictOnError key _a _b = + CGU.codeGenError ("Duplicate key found: " <> show key) + in + sequence $ + foldr + (Map.unionWithKey conflictOnError) + mempty + (fmap (fmap pure) maps) + +mkCodeGenTypes :: OA.OpenApi -> CGU.CodeGen CGU.CodeGenMap +mkCodeGenTypes openApi = do + let + components = OA._openApiComponents openApi + + schemaMaps <- + traverse (uncurry (mkSchemaMap CGU.Type)) + . IOHM.toList + $ OA._componentsSchemas components + + schemaMap <- unionsErrorOnConflict schemaMaps + + let + pathItems = + IOHM.toList + . OA._openApiPaths + $ openApi + + codeGenMap = + fmap (CGU.CodeGenItemType . schemaCodeGenType) schemaMap + + pathTypes <- traverse (uncurry $ mkPathItem (OA._componentsParameters components) schemaMap) pathItems + unionsErrorOnConflict (codeGenMap : pathTypes) + +mkPathItem :: OA.Definitions OA.Param -> SchemaMap -> FilePath -> OA.PathItem -> CGU.CodeGen CGU.CodeGenMap +mkPathItem paramDefs schemaMap filePath pathItem = do + let + methodOperations = + pathItemOperations pathItem + + nameStrategy = + if length methodOperations > 1 + then FallbackOperationNameIncludeMethod + else FallbackOperationNameOmitMethod + + operationCodeGenMaps <- + traverse + (uncurry $ mkOperation paramDefs schemaMap filePath pathItem nameStrategy) + methodOperations + + unionsErrorOnConflict operationCodeGenMaps + +pathItemOperations :: OA.PathItem -> [(T.Text, OA.Operation)] +pathItemOperations pathItem = + let + mkItem (method, accessor) = + case accessor pathItem of + Nothing -> Nothing + Just operation -> Just (method, operation) + in + mapMaybe + mkItem + [ ("GET", OA._pathItemGet) + , ("PUT", OA._pathItemPut) + , ("POST", OA._pathItemPost) + , ("DELETE", OA._pathItemDelete) + , ("OPTIONS", OA._pathItemOptions) + , ("HEAD", OA._pathItemHead) + , ("PATCH", OA._pathItemPatch) + , ("TRACE", OA._pathItemTrace) + ] + +data FallbackOperationNamingStrategy + = FallbackOperationNameIncludeMethod + | FallbackOperationNameOmitMethod + +mkOperation :: + OA.Definitions OA.Param -> + SchemaMap -> + FilePath -> + OA.PathItem -> + FallbackOperationNamingStrategy -> + T.Text -> + OA.Operation -> + CGU.CodeGen CGU.CodeGenMap +mkOperation paramDefs schemaMap filePath pathItem nameStrategy method operation = do + let + pathTextParts = + filter (not . T.null) + . T.splitOn "/" + . T.pack + $ filePath + + operationKey = + case OA._operationOperationId operation of + Just operationId -> operationId + Nothing -> + let + pathKey = + T.intercalate "." pathTextParts + in + case nameStrategy of + FallbackOperationNameOmitMethod -> pathKey + FallbackOperationNameIncludeMethod -> pathKey <> "." <> method + + params <- + mkOperationParams paramDefs schemaMap operationKey pathItem operation + + let + lookupParamRef name = + case Map.lookup name params of + Just codeGenParam -> + pure $ + CGU.PathParamRef + (CGU.codeGenOperationParamName codeGenParam) + (CGU.codeGenOperationParamTypeName codeGenParam) + (CGU.codeGenOperationParamDefName codeGenParam) + Nothing -> + CGU.codeGenError $ + "Parameter definition not found for " + <> show name + <> " param of " + <> show method + <> " operation for " + <> filePath + + mkPiece text = + if "{" `T.isPrefixOf` text && "}" `T.isSuffixOf` text + then lookupParamRef (T.drop 1 . T.dropEnd 1 $ text) + else pure (CGU.PathLiteral text) + + pathPieces <- traverse mkPiece pathTextParts + + mbRequestBody <- lookupRequestBody operationKey operation + + let + mbJSONMedia = + IOHM.lookup "application/json" + . OA._requestBodyContent + =<< mbRequestBody + + mbRequestBodySchema <- + fmap join + . traverse (lookupRequestBodySchema operationKey schemaMap) + $ mbJSONMedia + + responses <- + lookupResponses + operationKey + schemaMap + (OA._operationResponses operation) + + let + codeGenOperation = + CGU.CodeGenOperation + { CGU.codeGenOperationOriginalName = operationKey + , CGU.codeGenOperationMethod = method + , CGU.codeGenOperationPath = pathPieces + , CGU.codeGenOperationParams = Map.elems params + , CGU.codeGenOperationRequestBody = fmap schemaTypeInfoDependent mbRequestBodySchema + , CGU.codeGenOperationResponses = fmap (fmap schemaTypeInfoDependent) responses + } + + mkParamEntry (paramName, param) = + ( CGU.ParamKey (operationKey <> "." <> paramName) + , CGU.CodeGenItemOperationParam param + ) + + paramModules = + Map.fromList + . map mkParamEntry + . Map.toList + $ params + + requestBodyModules = + fmap (CGU.CodeGenItemType . schemaCodeGenType) + . maybe mempty schemaTypeInfoDependencies + $ mbRequestBodySchema + + responseBodyModules = + fmap (CGU.CodeGenItemType . schemaCodeGenType) + . foldMap (maybe mempty schemaTypeInfoDependencies) + $ responses + + pure $ + Map.singleton (CGU.OperationKey operationKey) (CGU.CodeGenItemOperation codeGenOperation) + <> paramModules + <> requestBodyModules + <> responseBodyModules + +lookupRequestBody :: + T.Text -> + OA.Operation -> + CGU.CodeGen (Maybe OA.RequestBody) +lookupRequestBody operationKey operation = + case OA._operationRequestBody operation of + Just (OA.Ref _reference) -> + CGU.codeGenError $ + "Error finding request body for operation " + <> show operationKey + <> ": request body references are not currently supported." + Just (OA.Inline body) -> + pure (Just body) + Nothing -> + pure Nothing + +data SchemaTypeInfoWithDeps = SchemaTypeInfoWithDeps + { schemaTypeInfoDependent :: CGU.SchemaTypeInfoOrRef + , schemaTypeInfoDependencies :: SchemaMap + } + +schemaInfoWithoutDependencies :: CGU.SchemaTypeInfo -> SchemaTypeInfoWithDeps +schemaInfoWithoutDependencies schemaTypeInfo = + SchemaTypeInfoWithDeps + { schemaTypeInfoDependent = Left schemaTypeInfo + , schemaTypeInfoDependencies = Map.empty + } + +fmapSchemaInfoAndDeps :: + (CGU.SchemaTypeInfoOrRef -> CGU.SchemaTypeInfoOrRef) -> + SchemaTypeInfoWithDeps -> + SchemaTypeInfoWithDeps +fmapSchemaInfoAndDeps f schemaTypeInfoWithDeps = + schemaTypeInfoWithDeps + { schemaTypeInfoDependent = f $ schemaTypeInfoDependent schemaTypeInfoWithDeps + } + +lookupRequestBodySchema :: + T.Text -> + SchemaMap -> + OA.MediaTypeObject -> + CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) +lookupRequestBodySchema operationKey schemaMap mediaTypeObject = + let + requestError msg = + CGU.codeGenError $ + "Error finding request body schema for operation " + <> show operationKey + <> ": " + <> msg + in + case OA._mediaTypeObjectSchema mediaTypeObject of + Just (OA.Ref (OA.Reference refKey)) -> + case Map.lookup (CGU.SchemaKey refKey) schemaMap of + Just schemaEntry -> + pure + . Just + . schemaInfoWithoutDependencies + . CGU.codeGenTypeSchemaInfo + . schemaCodeGenType + $ schemaEntry + Nothing -> + requestError $ + "Unable to resolve schema reference " + <> show refKey + <> "." + Just (OA.Inline schema) -> do + fmap Just $ + mkInlineBodySchema + requestError + (operationKey <> ".RequestBody") + schemaMap + schema + Nothing -> + pure Nothing + +lookupResponses :: + T.Text -> + SchemaMap -> + OA.Responses -> + CGU.CodeGen (Map.Map CGU.ResponseStatus (Maybe SchemaTypeInfoWithDeps)) +lookupResponses operationKey schemaMap responses = + let + statusCodeEntries = + Map.fromList + . map (\(status, responseRef) -> (CGU.ResponseStatusCode status, responseRef)) + . IOHM.toList + . OA._responsesResponses + $ responses + + allEntries = + case OA._responsesDefault responses of + Just defaultResponseRef -> + Map.insert CGU.DefaultResponse defaultResponseRef statusCodeEntries + Nothing -> statusCodeEntries + in + Map.traverseWithKey + (lookupResponseBodySchema operationKey schemaMap) + allEntries + +lookupResponseBodySchema :: + T.Text -> + SchemaMap -> + CGU.ResponseStatus -> + OA.Referenced OA.Response -> + CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) +lookupResponseBodySchema operationKey schemaMap responseStatus responseRef = + let + responseError msg = + CGU.codeGenError $ + "Error looking up response for operation " + <> show operationKey + <> ": " + <> msg + + lookupCodeGenType refKey = + case Map.lookup (CGU.SchemaKey refKey) schemaMap of + Just schemaEntry -> + pure . CGU.codeGenTypeSchemaInfo . schemaCodeGenType $ schemaEntry + Nothing -> + responseError $ + "Unable to resolve schema reference " + <> show refKey + <> "." + in + case responseRef of + OA.Ref _reference -> + responseError "Response references are not yet supported." + OA.Inline response -> + case IOHM.lookup "application/json" (OA._responseContent response) of + Nothing -> pure Nothing + Just mediaTypeObject -> + fmap Just $ + case OA._mediaTypeObjectSchema mediaTypeObject of + Just (OA.Ref (OA.Reference refKey)) -> + fmap schemaInfoWithoutDependencies (lookupCodeGenType refKey) + Just (OA.Inline schema) -> + let + responseName = + T.pack $ + case responseStatus of + CGU.ResponseStatusCode n -> + "Response" <> show n <> "Body" + CGU.DefaultResponse -> + "DefaultResponseBody" + in + mkInlineBodySchema + responseError + (operationKey <> "." <> responseName) + schemaMap + schema + Nothing -> + -- This indicates that the empty schema was specified for + -- the media type. + pure (schemaInfoWithoutDependencies CGU.anyJSONSchemaTypeInfo) + +mkInlineStringSchema :: + T.Text -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineStringSchema schemaKey schema = do + case OA._schemaEnum schema of + Nothing -> pure . schemaInfoWithoutDependencies $ CGU.textSchemaTypeInfo + Just _values -> do + (_moduleName, typeName) <- CGU.inferTypeForInputName CGU.Operation schemaKey + mbInlinedTypesAndSchemaTypeInfo <- + mkSchemaTypeInfo + schemaKey + typeName + schema + case mbInlinedTypesAndSchemaTypeInfo of + Just (inlinedTypes, schemaTypeInfo) -> + pure $ + SchemaTypeInfoWithDeps + { schemaTypeInfoDependent = Left schemaTypeInfo + , schemaTypeInfoDependencies = inlinedTypes + } + Nothing -> pure . schemaInfoWithoutDependencies $ CGU.textSchemaTypeInfo + +mkInlineBoolSchema :: CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineBoolSchema = + pure . schemaInfoWithoutDependencies $ CGU.boolSchemaTypeInfo + +mkInlineIntegerSchema :: + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineIntegerSchema schema = + pure + . schemaInfoWithoutDependencies + $ case OA._schemaFormat schema of + Just "int32" -> CGU.int32SchemaTypeInfo + Just "int64" -> CGU.int64SchemaTypeInfo + Just _ -> CGU.integerSchemaTypeInfo + Nothing -> CGU.integerSchemaTypeInfo + +mkInlineBodyObjectSchema :: + (forall a. String -> CGU.CodeGen a) -> + T.Text -> + SchemaMap -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineBodyObjectSchema raiseError schemaKey schemaMap schema = + if IOHM.null (OA._schemaProperties schema) + then do + mbAdditionalPropertiesMapSchema <- + mkAdditionalPropertiesMapSchema + raiseError + schemaKey + (\key itemSchema -> mkInlineBodySchema raiseError key schemaMap itemSchema) + (OA._schemaAdditionalProperties schema) + case mbAdditionalPropertiesMapSchema of + Just additionalPropertiesMapSchema -> + pure additionalPropertiesMapSchema + Nothing -> + mkInlineBodyObjectWithNoAdditionalPropertiesSchema schemaKey schema + else mkInlineBodyObjectWithNoAdditionalPropertiesSchema schemaKey schema + +mkInlineBodyObjectWithNoAdditionalPropertiesSchema :: + T.Text -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineBodyObjectWithNoAdditionalPropertiesSchema schemaKey schema = do + (_moduleName, typeName) <- CGU.inferTypeForInputName CGU.Operation schemaKey + (fieldsSchemaMap, dataFormat) <- + mkOpenApiObjectFormat + CGU.Operation + schemaKey + typeName + schema + + schemaTypeInfo <- CGU.inferSchemaInfoForTypeName typeName + + let + codeGenType = + CGU.CodeGenType + { CGU.codeGenTypeOriginalName = schemaKey + , CGU.codeGenTypeName = typeName + , CGU.codeGenTypeSchemaInfo = schemaTypeInfo + , CGU.codeGenTypeDescription = + NET.fromText =<< OA._schemaDescription schema + , CGU.codeGenTypeDataFormat = dataFormat + } + + schemaEntry = + SchemaEntry + { schemaOpenApiSchema = schema + , schemaCodeGenType = codeGenType + } + + codeGenModules = + Map.insert + (CGU.SchemaKey schemaKey) + schemaEntry + fieldsSchemaMap + + pure $ + SchemaTypeInfoWithDeps + { schemaTypeInfoDependent = Left schemaTypeInfo + , schemaTypeInfoDependencies = codeGenModules + } + +mkInlineArraySchema :: + (forall a. String -> CGU.CodeGen a) -> + T.Text -> + SchemaMap -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineArraySchema raiseError schemaKey schemaMap schema = + let + lookupCodeGenType refKey = + case Map.lookup (CGU.SchemaKey refKey) schemaMap of + Just schemaEntry -> + pure . CGU.codeGenTypeSchemaInfo . schemaCodeGenType $ schemaEntry + Nothing -> + raiseError $ + "Unable to resolve schema reference " + <> show refKey + <> "." + in + case OA._schemaItems schema of + Just (OA.OpenApiItemsObject (OA.Ref (OA.Reference itemRefKey))) -> do + itemSchemaInfo <- lookupCodeGenType itemRefKey + pure . schemaInfoWithoutDependencies . CGU.arrayLikeTypeInfo (OA._schemaMinItems schema) $ itemSchemaInfo + Just (OA.OpenApiItemsObject (OA.Inline innerSchema)) -> + let + itemKey = + schemaKey <> "Item" + in + fmap + (fmapSchemaInfoAndDeps $ first $ CGU.arrayLikeTypeInfo $ OA._schemaMinItems schema) + (mkInlineBodySchema raiseError itemKey schemaMap innerSchema) + otherItemType -> + raiseError $ + "Unsupported schema array item type found: " + <> show otherItemType + +mkInlineArrayOneOfSchema :: + (forall a. String -> CGU.CodeGen a) -> + T.Text -> + SchemaMap -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineArrayOneOfSchema raiseError schemaKey schemaMap schema = + let + minItems = OA._schemaMinItems schema + in + case OA._schemaItems schema of + Just (OA.OpenApiItemsObject (OA.Ref ref)) -> do + pure $ + SchemaTypeInfoWithDeps + { schemaTypeInfoDependent = Right $ CGU.CodeGenRefArray minItems $ CGU.TypeReference $ OA.getReference ref + , schemaTypeInfoDependencies = mempty + } + Just (OA.OpenApiItemsObject (OA.Inline innerSchema)) -> + let + itemKey = + schemaKey <> "Item" + in + fmap + (fmapSchemaInfoAndDeps (bimap (CGU.arrayLikeTypeInfo minItems) $ CGU.CodeGenRefArray minItems)) + (mkInlineOneOfSchema raiseError itemKey schemaMap innerSchema) + otherItemType -> + raiseError $ + "Unsupported schema array item type found: " + <> show otherItemType + +applyNullable :: OA.Schema -> SchemaTypeInfoWithDeps -> SchemaTypeInfoWithDeps +applyNullable schema = + if OA._schemaNullable schema == Just True + then fmapSchemaInfoAndDeps (bimap CGU.nullableTypeInfo CGU.CodeGenRefNullable) + else id + +mkInlineBodySchema :: + (forall a. String -> CGU.CodeGen a) -> + T.Text -> + SchemaMap -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineBodySchema raiseError schemaKey schemaMap schema = + applyNullable schema <$> case OA._schemaType schema of + Just OA.OpenApiArray -> mkInlineArraySchema raiseError schemaKey schemaMap schema + Just OA.OpenApiString -> mkInlineStringSchema schemaKey schema + Just OA.OpenApiBoolean -> mkInlineBoolSchema + Just OA.OpenApiInteger -> mkInlineIntegerSchema schema + Just OA.OpenApiObject -> mkInlineBodyObjectSchema raiseError schemaKey schemaMap schema + Just s -> raiseError $ "Inline " <> show s <> " schemas are not currently supported." + Nothing -> raiseError "Inline schema doesn't have a type." + +mkInlineOneOfSchema :: + (forall a. String -> CGU.CodeGen a) -> + T.Text -> + SchemaMap -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkInlineOneOfSchema raiseError schemaKey schemaMap schema = + applyNullable schema <$> case OA._schemaType schema of + Just OA.OpenApiArray -> mkInlineArrayOneOfSchema raiseError schemaKey schemaMap schema + Just OA.OpenApiString -> mkInlineStringSchema schemaKey schema + Just OA.OpenApiBoolean -> mkInlineBoolSchema + Just OA.OpenApiInteger -> mkInlineIntegerSchema schema + Just OA.OpenApiObject -> raiseError "Inline OpenApiObject schemas are not currently supported in oneOf." + Just s -> raiseError $ "Inline " <> show s <> " schemas are not currently supported." + Nothing -> raiseError "Inline schema doesn't have a type." + +mkOperationParams :: + OA.Definitions OA.Param -> + SchemaMap -> + T.Text -> + OA.PathItem -> + OA.Operation -> + CGU.CodeGen (Map.Map T.Text CGU.CodeGenOperationParam) +mkOperationParams paramDefs schemaMap operationKey pathItem operation = do + paramList <- + traverse + (mkOperationParam paramDefs schemaMap operationKey) + (OA._pathItemParameters pathItem <> OA._operationParameters operation) + + let + paramMap = + Map.fromList + . map (\param -> (CGU.codeGenOperationParamName param, param)) + $ paramList + + pure paramMap + +mkOperationParam :: + OA.Definitions OA.Param -> + SchemaMap -> + T.Text -> + OA.Referenced OA.Param -> + CGU.CodeGen CGU.CodeGenOperationParam +mkOperationParam paramDefs schemaMap operationKey paramRef = do + param <- + case paramRef of + OA.Ref name -> do + let + txtName = OA.getReference name + case IOHM.lookup txtName paramDefs of + Nothing -> + CGU.codeGenError $ + "Couldn't not find param def '" + <> T.unpack txtName + <> "', keys are: " + <> show (IOHM.keys paramDefs) + Just x -> pure x + OA.Inline param -> pure param + + let + paramName = + OA._paramName param + + (moduleName, defaultParamTypeName) <- + CGU.inferTypeForInputName CGU.Operation (operationKey <> "." <> paramName) + + case OA._paramSchema param of + Just schemaRef -> do + paramInfo <- + schemaRefToParamInfo + schemaMap + paramName + (OA._paramIn param) + operationKey + schemaRef + + let + paramTypeName = + case paramInfoTypeName paramInfo of + Nothing -> defaultParamTypeName + Just resolvedName -> resolvedName + + paramRequired = + case OA._paramRequired param of + Nothing -> False + Just req -> req + + arity = + case (paramRequired, paramInfoArray paramInfo) of + (True, False) -> CGU.ExactlyOne + (False, False) -> CGU.AtMostOne + (True, True) -> CGU.AtLeastOne + (False, True) -> CGU.AtLeastZero + + paramLocation <- + case OA._paramIn param of + OA.ParamQuery -> pure CGU.ParamLocationQuery + OA.ParamPath -> pure CGU.ParamLocationPath + OA.ParamHeader -> pure CGU.ParamLocationHeader + OA.ParamCookie -> paramCodeGenError paramName operationKey "Cookie params not supported." + + typeOptions <- CGU.lookupTypeOptions paramTypeName + + pure + CGU.CodeGenOperationParam + { CGU.codeGenOperationParamName = paramName + , CGU.codeGenOperationParamArity = arity + , CGU.codeGenOperationParamModuleName = moduleName + , CGU.codeGenOperationParamTypeName = paramTypeName + , CGU.codeGenOperationParamFormat = paramInfoFormat paramInfo + , CGU.codeGenOperationParamLocation = paramLocation + , CGU.codeGenOperationParamDefName = + HC.toVarName + moduleName + (Just (HC.typeNameText paramTypeName)) + "paramDef" + , CGU.codeGenOperationParamTypeOptions = typeOptions + } + Nothing -> + paramCodeGenError paramName operationKey "No param schema found." + +paramCodeGenError :: T.Text -> T.Text -> String -> CGU.CodeGen a +paramCodeGenError paramName operationKey msg = + CGU.codeGenError $ + "Error handing param " + <> T.unpack paramName + <> " of operation " + <> T.unpack operationKey + <> ": " + <> msg + +data ParamInfo = ParamInfo + { paramInfoTypeName :: Maybe HC.TypeName + , paramInfoArray :: Bool + , paramInfoFormat :: CGU.OperationParamFormat + } + +primitiveParamInfo :: CGU.OperationParamFormat -> ParamInfo +primitiveParamInfo format = + ParamInfo + { paramInfoTypeName = Nothing + , paramInfoArray = False + , paramInfoFormat = format + } + +schemaRefToParamInfo :: + SchemaMap -> + T.Text -> + OA.ParamLocation -> + T.Text -> + OA.Referenced OA.Schema -> + CGU.CodeGen ParamInfo +schemaRefToParamInfo schemaMap paramName paramLocation operationKey schemaRef = + case schemaRef of + OA.Inline schema -> do + schemaTypeToParamInfo + schemaMap + paramName + paramLocation + operationKey + schema + OA.Ref (OA.Reference refKey) -> + case Map.lookup (CGU.SchemaKey refKey) schemaMap of + Just schemaEntry -> do + let + codeGenType = + schemaCodeGenType schemaEntry + + paramInfo <- + schemaTypeToParamInfo + schemaMap + paramName + paramLocation + operationKey + (schemaOpenApiSchema schemaEntry) + + pure $ + paramInfo + { paramInfoTypeName = Just (CGU.codeGenTypeName codeGenType) + } + Nothing -> + paramCodeGenError paramName operationKey $ + "Schema reference " + <> show refKey + <> " not found." + +schemaTypeToParamInfo :: + SchemaMap -> + T.Text -> + OA.ParamLocation -> + T.Text -> + OA.Schema -> + CGU.CodeGen ParamInfo +schemaTypeToParamInfo schemaMap paramName paramLocation operationKey schema = + case OA._schemaType schema of + Just OA.OpenApiString -> + case OA._schemaEnum schema of + Nothing -> + pure (primitiveParamInfo CGU.ParamTypeString) + Just enumValues -> do + let + rejectNull mbText = + case mbText of + Nothing -> CGU.codeGenError "null not supported as enum value in params" + Just text -> pure text + + enumTexts <- + traverse (rejectNull <=< enumValueToText paramName schema) enumValues + + pure + . primitiveParamInfo + . CGU.ParamTypeEnum + $ enumTexts + Just OA.OpenApiBoolean -> + pure (primitiveParamInfo CGU.ParamTypeBoolean) + Just OA.OpenApiInteger -> + case OA._schemaFormat schema of + Just "int8" -> pure (primitiveParamInfo CGU.ParamTypeInt8) + Just "int16" -> pure (primitiveParamInfo CGU.ParamTypeInt16) + Just "int32" -> pure (primitiveParamInfo CGU.ParamTypeInt32) + Just "int64" -> pure (primitiveParamInfo CGU.ParamTypeInt64) + _ -> pure (primitiveParamInfo CGU.ParamTypeInteger) + Just OA.OpenApiNumber -> + case OA._schemaFormat schema of + Just "double" -> pure (primitiveParamInfo CGU.ParamTypeDouble) + Just "float" -> pure (primitiveParamInfo CGU.ParamTypeFloat) + _ -> pure (primitiveParamInfo CGU.ParamTypeScientific) + Just OA.OpenApiArray -> + let + arrayParamSchema = + case OA._schemaItems schema of + Just (OA.OpenApiItemsObject itemSchemaRef) -> do + itemInfo <- + schemaRefToParamInfo + schemaMap + paramName + paramLocation + operationKey + itemSchemaRef + + if paramInfoArray itemInfo + then + paramCodeGenError + paramName + operationKey + "Array of arrays not support for param" + else + pure $ + itemInfo + { paramInfoArray = True + } + otherItemType -> + paramCodeGenError paramName operationKey $ + "Unsupported schema array item type found: " + <> show otherItemType + in + case paramLocation of + OA.ParamQuery -> arrayParamSchema + OA.ParamHeader -> arrayParamSchema + otherLocation -> + paramCodeGenError paramName operationKey $ + "Array parameters are not supported for " + <> show otherLocation + <> " paremeters." + Just otherType -> + paramCodeGenError paramName operationKey $ + "Unsupported schema type found for param: " + <> show otherType + Nothing -> + paramCodeGenError paramName operationKey $ + "No schema type found." + +mkSchemaMap :: CGU.CodeSection -> T.Text -> OA.Schema -> CGU.CodeGen SchemaMap +mkSchemaMap section schemaKey schema = do + (_moduleName, typeName) <- CGU.inferTypeForInputName section schemaKey + maybe Map.empty fst <$> mkSchemaTypeInfo schemaKey typeName schema + +mkSchemaTypeInfo :: + T.Text -> + HC.TypeName -> + OA.Schema -> + CGU.CodeGen (Maybe (SchemaMap, CGU.SchemaTypeInfo)) +mkSchemaTypeInfo schemaKey typeName schema = do + baseSchemaInfo <- CGU.inferSchemaInfoForTypeName typeName + mbOpenApiDataFormat <- mkOpenApiDataFormat schemaKey typeName schema + + case mbOpenApiDataFormat of + Just (inlinedTypes, dataFormat) -> + let + schemaInfo = + case OA._schemaNullable schema of + Just True -> CGU.nullableTypeInfo baseSchemaInfo + _ -> baseSchemaInfo + + codeGenType = + CGU.CodeGenType + { CGU.codeGenTypeOriginalName = schemaKey + , CGU.codeGenTypeName = typeName + , CGU.codeGenTypeSchemaInfo = schemaInfo + , CGU.codeGenTypeDescription = NET.fromText =<< OA._schemaDescription schema + , CGU.codeGenTypeDataFormat = dataFormat + } + + schemaEntry = + SchemaEntry + { schemaOpenApiSchema = schema + , schemaCodeGenType = codeGenType + } + + schemaMap = + Map.singleton (CGU.SchemaKey schemaKey) schemaEntry <> inlinedTypes + in + pure $ Just (schemaMap, schemaInfo) + Nothing -> + pure Nothing + +mkOpenApiDataFormat :: + T.Text -> + HC.TypeName -> + OA.Schema -> + CGU.CodeGen (Maybe (SchemaMap, CGU.CodeGenDataFormat)) +mkOpenApiDataFormat schemaKey typeName schema = + let + noRefs mkFormat = do + dataFormat <- mkFormat + pure $ Just (Map.empty, dataFormat) + in + case OA._schemaOneOf schema of + Just schemas -> + case OA._schemaDiscriminator schema of + Nothing -> + Just <$> mkOneOfUnion schemaKey schemas + Just discriminator -> + Just <$> mkOneOfTaggedUnion discriminator schemaKey + Nothing -> + case OA._schemaType schema of + Just OA.OpenApiString -> noRefs $ mkOpenApiStringFormat typeName schema + Just OA.OpenApiNumber -> noRefs $ mkOpenApiNumberFormat typeName schema + Just OA.OpenApiInteger -> noRefs $ mkOpenApiIntegerFormat typeName schema + Just OA.OpenApiBoolean -> do + typeOptions <- CGU.lookupTypeOptions typeName + noRefs $ pure (CGU.boolFormat typeOptions) + Just OA.OpenApiArray -> + Just <$> mkOpenApiArrayFormat schemaKey typeName schema + Just OA.OpenApiObject -> + mkOpenApiObjectFormatOrAdditionalPropertiesNewtype + CGU.Type + schemaKey + typeName + schema + Just OA.OpenApiNull -> do + typeOptions <- CGU.lookupTypeOptions typeName + noRefs $ pure (CGU.nullFormat typeOptions) + Nothing -> + mkOpenApiObjectFormatOrAdditionalPropertiesNewtype + CGU.Type + schemaKey + typeName + schema + +mkOneOfUnion :: + T.Text -> + [OA.Referenced OA.Schema] -> + CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) +mkOneOfUnion schemaKey refSchemas = do + let + processRefSchema refSchema = + case refSchema of + OA.Inline schema -> do + typeInfoWithDeps <- + mkInlineOneOfSchema + (\err -> CGU.codeGenError $ "Inside inline oneOf: " <> err) + schemaKey + mempty + schema + let + unionMember = + CGU.CodeGenUnionMember + { CGU.codeGenUnionMemberType = schemaTypeInfoDependent typeInfoWithDeps + } + pure (schemaTypeInfoDependencies typeInfoWithDeps, unionMember) + OA.Ref ref -> do + let + unionMember = + CGU.CodeGenUnionMember + { CGU.codeGenUnionMemberType = Right $ CGU.TypeReference $ OA.getReference ref + } + pure (mempty, unionMember) + + (maps, codeGenUnionMembers) <- fmap unzip . traverse processRefSchema $ refSchemas + schemaMap <- unionsErrorOnConflict maps + pure (schemaMap, CGU.CodeGenUnion codeGenUnionMembers) + +mkOneOfTaggedUnion :: + OA.Discriminator -> + T.Text -> + CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) +mkOneOfTaggedUnion discriminator _schemaKey = do + let + processMappingEntry (tag, ref) = + case T.stripPrefix "#/components/schemas/" ref of + Nothing -> + CGU.codeGenError $ + "Discriminators mappings with references to locations other than the schema components are not supported: " + <> T.unpack ref + Just typeName -> + pure $ + CGU.CodeGenTaggedUnionMember + { CGU.codeGenTaggedUnionMemberTag = tag + , CGU.codeGenTaggedUnionMemberType = Right . CGU.TypeReference $ typeName + } + + mapping = + OA._discriminatorMapping discriminator + + tagProperty = + OA._discriminatorPropertyName discriminator + + when + (IOHM.null mapping) + (CGU.codeGenError "Discriminators without mappings is not currently supported") + + codeGenTaggedUnionMembers <- + traverse processMappingEntry + . IOHM.toList + $ mapping + + pure (mempty, CGU.CodeGenTaggedUnion tagProperty codeGenTaggedUnionMembers) + +mkOpenApiStringFormat :: HC.TypeName -> OA.Schema -> CGU.CodeGen CGU.CodeGenDataFormat +mkOpenApiStringFormat typeName schema = do + typeOptions <- CGU.lookupTypeOptions typeName + case OA._schemaEnum schema of + Just enumValues -> + fmap + (CGU.enumFormat typeOptions . catMaybes) + (traverse (enumValueToText (HC.typeNameText typeName) schema) enumValues) + Nothing -> + pure $ + case OA._schemaFormat schema of + Just "date" -> + CGU.dayFormat typeOptions + Just "date-time" -> + case CGU.dateTimeFormat typeOptions of + CGU.UTCTimeFormat -> CGU.utcTimeFormat typeOptions + CGU.ZonedTimeFormat -> CGU.zonedTimeFormat typeOptions + CGU.LocalTimeFormat -> CGU.localTimeFormat typeOptions + _ -> CGU.textFormat typeOptions + +enumValueToText :: T.Text -> OA.Schema -> Aeson.Value -> CGU.CodeGen (Maybe T.Text) +enumValueToText name schema value = + case value of + Aeson.String text -> pure (Just text) + Aeson.Null -> + case OA._schemaNullable schema of + Just True -> pure Nothing + _ -> CGU.codeGenError "null listed as enum value in a non-nullable schema" + _ -> + CGU.codeGenError $ + "Non-string value found for enum in schema/parameter titled '" + <> T.unpack name + <> "', value is " + <> show value + +mkOpenApiNumberFormat :: HC.TypeName -> OA.Schema -> CGU.CodeGen CGU.CodeGenDataFormat +mkOpenApiNumberFormat typeName schema = do + typeOptions <- CGU.lookupTypeOptions typeName + pure $ + case OA._schemaFormat schema of + Just "float" -> CGU.floatFormat typeOptions + Just "double" -> CGU.doubleFormat typeOptions + _ -> CGU.scientificFormat typeOptions + +mkOpenApiIntegerFormat :: HC.TypeName -> OA.Schema -> CGU.CodeGen CGU.CodeGenDataFormat +mkOpenApiIntegerFormat typeName schema = do + typeOptions <- CGU.lookupTypeOptions typeName + pure $ + case OA._schemaFormat schema of + Just "int32" -> CGU.int32Format typeOptions + Just "int64" -> CGU.int64Format typeOptions + _ -> CGU.integerFormat typeOptions + +mkOpenApiObjectFormatOrAdditionalPropertiesNewtype :: + CGU.CodeSection -> + T.Text -> + HC.TypeName -> + OA.Schema -> + CGU.CodeGen (Maybe (SchemaMap, CGU.CodeGenDataFormat)) +mkOpenApiObjectFormatOrAdditionalPropertiesNewtype section schemaKey typeName schema = do + if IOHM.null (OA._schemaProperties schema) + then + mkOpenApiAdditionalPropertiesNewtype + section + schemaKey + typeName + schema + else Just <$> mkOpenApiObjectFormat section schemaKey typeName schema + +mkOpenApiAdditionalPropertiesNewtype :: + CGU.CodeSection -> + T.Text -> + HC.TypeName -> + OA.Schema -> + CGU.CodeGen (Maybe (SchemaMap, CGU.CodeGenDataFormat)) +mkOpenApiAdditionalPropertiesNewtype section schemaKey typeName schema = do + let + raiseError err = + CGU.codeGenError $ + "Unable to build schema for " + <> show schemaKey + <> ": " + <> err + + mbSchemaTypeInfoWithDeps <- + mkAdditionalPropertiesMapSchema + raiseError + schemaKey + (mkAdditionalPropertiesInlineItemSchema section) + (OA._schemaAdditionalProperties schema) + + case mbSchemaTypeInfoWithDeps of + Just schemaTypeInfoWithDeps -> do + typeOptions <- CGU.lookupTypeOptions typeName + + let + format = + CGU.CodeGenNewType + typeOptions + (schemaTypeInfoDependent schemaTypeInfoWithDeps) + pure $ Just (schemaTypeInfoDependencies schemaTypeInfoWithDeps, format) + Nothing -> + pure Nothing + +mkOpenApiObjectFormat :: + CGU.CodeSection -> + T.Text -> + HC.TypeName -> + OA.Schema -> + CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) +mkOpenApiObjectFormat section schemaKey typeName schema = do + let + requiredParams = + OA._schemaRequired schema + + raiseAdditionalPropsError err = + CGU.codeGenError $ + "Unable to build additionalProperties schema for " + <> show schemaKey + <> ": " + <> err + + typeOptions <- CGU.lookupTypeOptions typeName + + (fieldDependencies, fields) <- + fmap unzip + . traverse (uncurry $ propertyToCodeGenField section schemaKey requiredParams) + . filter (\(prop, _) -> prop `notElem` unsupportedProperties) + . IOHM.toList + . OA._schemaProperties + $ schema + + mbAdditionalProperties <- + case OA._schemaAdditionalProperties schema of + Nothing -> + pure Nothing + Just additionalProperties -> + mkAdditionalPropertiesSchema + raiseAdditionalPropsError + schemaKey + (mkAdditionalPropertiesInlineItemSchema section) + (Just additionalProperties) + + let + dependencies = + Map.unions + ( maybe Map.empty schemaTypeInfoDependencies mbAdditionalProperties + : fieldDependencies + ) + + mbCodeGenAdditionalProps = + fmap + (CGU.CodeGenAdditionalProperties . schemaTypeInfoDependent) + mbAdditionalProperties + + pure (dependencies, CGU.CodeGenObject typeOptions fields mbCodeGenAdditionalProps) + +mkAdditionalPropertiesInlineItemSchema :: + CGU.CodeSection -> + T.Text -> + OA.Schema -> + CGU.CodeGen SchemaTypeInfoWithDeps +mkAdditionalPropertiesInlineItemSchema section itemKey itemSchema = do + itemDependencies <- mkSchemaMap section itemKey itemSchema + (_moduleName, itemTypeName) <- CGU.inferTypeForInputName section itemKey + itemSchemaInfo <- CGU.inferSchemaInfoForTypeName itemTypeName + pure $ + SchemaTypeInfoWithDeps + { schemaTypeInfoDependent = Left itemSchemaInfo + , schemaTypeInfoDependencies = itemDependencies + } + +unsupportedProperties :: [T.Text] +unsupportedProperties = + [ "_links" + ] + +mkOpenApiArrayFormat :: + T.Text -> + HC.TypeName -> + OA.Schema -> + CGU.CodeGen (SchemaMap, CGU.CodeGenDataFormat) +mkOpenApiArrayFormat schemaKey typeName schema = do + typeOptions <- CGU.lookupTypeOptions typeName + fmap (fmap (CGU.CodeGenArray typeOptions (OA._schemaMinItems schema))) $ + schemaArrayItemsToFieldType + CGU.Type + schemaKey + schema + schemaKey + (OA._schemaItems schema) + +propertyToCodeGenField :: + CGU.CodeSection -> + T.Text -> + [OA.ParamName] -> + OA.ParamName -> + OA.Referenced OA.Schema -> + CGU.CodeGen (SchemaMap, CGU.CodeGenObjectField) +propertyToCodeGenField section parentSchemaKey requiredParams name schemaRef = do + (schemaMap, codeGenFieldType) <- + schemaRefToFieldType section parentSchemaKey name schemaRef + + let + field = + CGU.CodeGenObjectField + { CGU.codeGenFieldName = name + , CGU.codeGenFieldRequired = name `elem` requiredParams + , CGU.codeGenFieldType = codeGenFieldType + } + + pure (schemaMap, field) + +schemaRefToFieldType :: + CGU.CodeSection -> + T.Text -> + OA.ParamName -> + OA.Referenced OA.Schema -> + CGU.CodeGen (SchemaMap, CGU.CodeGenRefType) +schemaRefToFieldType section parentKey fieldName schemaRef = + case schemaRef of + OA.Ref ref -> + pure (Map.empty, CGU.TypeReference . OA.getReference $ ref) + OA.Inline inlineSchema -> + case OA._schemaType inlineSchema of + Just OA.OpenApiArray -> + let + nullable = + OA._schemaNullable inlineSchema == Just True + applyNull = + if nullable + then CGU.CodeGenRefNullable + else id + minItems = + OA._schemaMinItems inlineSchema + in + fmap (fmap (applyNull . CGU.CodeGenRefArray minItems)) $ + schemaArrayItemsToFieldType + section + parentKey + inlineSchema + fieldName + (OA._schemaItems inlineSchema) + _ -> do + let + key = + parentKey <> "." <> fieldName + + childRef = + CGU.TypeReference key + + schemaMap <- mkSchemaMap section key inlineSchema + pure (schemaMap, childRef) + +schemaArrayItemsToFieldType :: + CGU.CodeSection -> + T.Text -> + OA.Schema -> + OA.ParamName -> + Maybe OA.OpenApiItems -> + CGU.CodeGen (SchemaMap, CGU.CodeGenRefType) +schemaArrayItemsToFieldType section parentKey schema fieldName arrayItems = + let + fieldError err = + CGU.codeGenError $ + "Unable to generate type for field " + <> show fieldName + <> " of object " + <> show parentKey + <> ": " + <> err + in + case arrayItems of + Just (OA.OpenApiItemsObject itemSchema) -> + schemaRefToFieldType section parentKey (fieldName <> "Item") itemSchema + Just (OA.OpenApiItemsArray []) -> do + let + key = + fieldName <> "Item" + + fieldType = + CGU.TypeReference key + + (_moduleName, typeName) <- CGU.inferTypeForInputName section key + schemaTypeInfo <- CGU.inferSchemaInfoForTypeName typeName + typeOptions <- CGU.lookupTypeOptions typeName + + let + schemaMap = + Map.singleton (CGU.SchemaKey key) $ + SchemaEntry + { schemaOpenApiSchema = schema + , schemaCodeGenType = + CGU.CodeGenType + { CGU.codeGenTypeOriginalName = key + , CGU.codeGenTypeName = typeName + , CGU.codeGenTypeSchemaInfo = schemaTypeInfo + , CGU.codeGenTypeDescription = Nothing + , CGU.codeGenTypeDataFormat = CGU.textFormat typeOptions + } + } + + pure (schemaMap, fieldType) + Just (OA.OpenApiItemsArray _itemSchemaRefs) -> + fieldError "Heterogeneous arrays are not supported" + Nothing -> + fieldError "Array schema found with no item schema" + +mkAdditionalPropertiesMapSchema :: + (forall a. String -> CGU.CodeGen a) -> + T.Text -> + (T.Text -> OA.Schema -> CGU.CodeGen SchemaTypeInfoWithDeps) -> + Maybe OA.AdditionalProperties -> + CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) +mkAdditionalPropertiesMapSchema raiseError schemaKey mkInlineItemSchema mbAdditionalProperties = do + mbSchema <- + mkAdditionalPropertiesSchema + raiseError + schemaKey + mkInlineItemSchema + mbAdditionalProperties + + pure + . fmap (fmapSchemaInfoAndDeps $ bimap CGU.mapTypeInfo CGU.CodeGenRefMap) + $ mbSchema + +mkAdditionalPropertiesSchema :: + (forall a. String -> CGU.CodeGen a) -> + T.Text -> + (T.Text -> OA.Schema -> CGU.CodeGen SchemaTypeInfoWithDeps) -> + Maybe OA.AdditionalProperties -> + CGU.CodeGen (Maybe SchemaTypeInfoWithDeps) +mkAdditionalPropertiesSchema raiseError schemaKey mkInlineItemSchema mbAdditionalProperties = + case mbAdditionalProperties of + Nothing -> + -- No explicit properties nor additional properties are defined, + -- but the OpenAPI spec defines additional properties as + -- defaulting to True, so we handle this the same as if only + -- additional properties was defined as true. + pure + . Just + . schemaInfoWithoutDependencies + $ CGU.anyJSONSchemaTypeInfo + Just (OA.AdditionalPropertiesAllowed True) -> + pure + . Just + . schemaInfoWithoutDependencies + $ CGU.anyJSONSchemaTypeInfo + Just (OA.AdditionalPropertiesAllowed False) -> do + strictAdditionalProperties <- asks CGU.strictAdditionalProperties + if strictAdditionalProperties + then + raiseError $ + "Schemas for objects with additional properties disallowed are" + <> " not yet supported. `additionalProperties: false` can be" + <> " ignored by overriding the `strictAdditionalProperties`" + <> " field in the Fleece code gen config as false." + else pure Nothing + Just (OA.AdditionalPropertiesSchema (OA.Ref ref)) -> + pure + . Just + $ SchemaTypeInfoWithDeps + { schemaTypeInfoDependent = Right $ CGU.TypeReference $ OA.getReference ref + , schemaTypeInfoDependencies = Map.empty + } + Just (OA.AdditionalPropertiesSchema (OA.Inline innerSchema)) -> + let + itemKey = + schemaKey <> "Item" + in + Just <$> mkInlineItemSchema itemKey innerSchema diff --git a/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas.hs b/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas.hs new file mode 100644 index 00000000..bfc34b53 --- /dev/null +++ b/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +module Fleece.OpenApi3.Schemas (module Export) where + +import Fleece.OpenApi3.Schemas.OpenApi3Validator as Export +import Fleece.OpenApi3.Schemas.Schemas as Export diff --git a/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/OpenApi3Validator.hs b/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/OpenApi3Validator.hs new file mode 100644 index 00000000..dfd53c60 --- /dev/null +++ b/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/OpenApi3Validator.hs @@ -0,0 +1,135 @@ +module Fleece.OpenApi3.Schemas.OpenApi3Validator + ( OpenApi3Validator (..) + ) where + +import qualified Data.Foldable as Foldable +import Data.Scientific (Scientific) +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Fleece.Core as FC + +class FC.FleeceValidator validator => OpenApi3Validator validator where + maximumScientific :: Scientific -> validator Scientific Scientific + minimumScientific :: Scientific -> validator Scientific Scientific + + maximumIntegral :: Integral a => a -> validator a a + minimumIntegral :: Integral a => a -> validator a a + + maxLength :: Int -> validator T.Text T.Text + minLength :: Int -> validator T.Text T.Text + + maxItems :: Int -> validator (V.Vector a) (V.Vector a) + minItems :: Int -> validator (V.Vector a) (V.Vector a) + uniqueItems :: Ord a => FC.SetDuplicateHandling -> validator (V.Vector a) (Set.Set a) + + setValidatorType :: T.Text -> validator a b -> validator a b + setValidatorFormat :: T.Text -> validator a b -> validator a b + +instance OpenApi3Validator FC.StandardValidator where + maximumScientific n = + FC.mkValidator + id + ( \x -> + if x > n + then Left ("Value " <> show x <> " is greater than maximum of " <> show n) + else Right x + ) + + minimumScientific n = + FC.mkValidator + id + ( \x -> + if x < n + then Left ("Value " <> show x <> " is less than minimum of " <> show n) + else Right x + ) + + maximumIntegral n = + FC.mkValidator + id + ( \x -> + if x > n + then Left ("Value " <> show (toInteger x) <> " is greater than maximum of " <> show (toInteger n)) + else Right x + ) + + minimumIntegral n = + FC.mkValidator + id + ( \x -> + if x < n + then Left ("Value " <> show (toInteger x) <> " is less than minimum of " <> show (toInteger x)) + else Right x + ) + + maxLength n = + FC.mkValidator + id + ( \x -> + if T.length x > n + then Left ("Text length " <> show (T.length x) <> " is greater than maximum of " <> show n) + else Right x + ) + + minLength n = + FC.mkValidator + id + ( \x -> + if T.length x < n + then Left ("Text length " <> show (T.length x) <> " is less than minimum of " <> show n) + else Right x + ) + + maxItems n = + FC.mkValidator + id + ( \xs -> + if length xs > n + then Left ("Array length " <> show (length xs) <> " is greater than maximum of " <> show n) + else Right xs + ) + + minItems n = + FC.mkValidator + id + ( \xs -> + if length xs < n + then Left ("Array length " <> show (length xs) <> " is less than minimum of " <> show n) + else Right xs + ) + + uniqueItems handling = + FC.mkValidator + (V.fromList . Set.toList) + ( \xs -> + let + set = Foldable.foldl' (flip Set.insert) Set.empty xs + in + case handling of + FC.AllowInputDuplicates -> Right set + FC.RejectInputDuplicates + | length set < length xs -> Left "Unexpected duplicates in input array." + | otherwise -> Right set + ) + + setValidatorType _ v = v + + setValidatorFormat _ v = v + +instance OpenApi3Validator FC.NoOpValidator where + maximumScientific = const FC.NoOpValidator + minimumScientific = const FC.NoOpValidator + + maximumIntegral = const FC.NoOpValidator + minimumIntegral = const FC.NoOpValidator + + maxLength = const FC.NoOpValidator + minLength = const FC.NoOpValidator + + maxItems = const FC.NoOpValidator + minItems = const FC.NoOpValidator + uniqueItems = const FC.NoOpValidator + + setValidatorType _ = const FC.NoOpValidator + setValidatorFormat _ = const FC.NoOpValidator diff --git a/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/Schemas.hs b/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/Schemas.hs new file mode 100644 index 00000000..ba1131b2 --- /dev/null +++ b/json-fleece-openapi3/src/Fleece/OpenApi3/Schemas/Schemas.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Fleece.OpenApi3.Schemas.Schemas + ( FleeceOpenApi3 + , nonEmpty + , set + , nonEmptyText + , integer + , unboundedIntegralNumberNamed + , unboundedIntegralNumber + , boundedIntegralNumberNamed + , boundedIntegralNumber + , int + , int8 + , int16 + , int32 + , int64 + , word + , word8 + , word16 + , word32 + , word64 + , double + , float + , utcTime + , utcTimeWithFormat + , localTime + , localTimeWithFormat + , zonedTime + , zonedTimeWithFormat + , day + , dayWithFormat + , dateTimeFormat + , customFormat + ) where + +import qualified Data.Int as I +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (fromJust) +import qualified Data.NonEmptyText as NET +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Time as Time +import Data.Typeable (Typeable) +import qualified Data.Vector as V +import qualified Data.Word as W +import qualified Fleece.Core as FC + +import Fleece.OpenApi3.Schemas.OpenApi3Validator (OpenApi3Validator (maximumIntegral, minItems, minLength, minimumIntegral, setValidatorFormat, setValidatorType, uniqueItems)) + +type FleeceOpenApi3 schema = + ( FC.Fleece schema + , OpenApi3Validator (FC.Validator schema) + ) + +nonEmpty :: FleeceOpenApi3 schema => schema a -> schema (NEL.NonEmpty a) +nonEmpty itemSchema = + let + validator = + FC.transform (V.fromList . NEL.toList) (NEL.fromList . V.toList) + `FC.compose` minItems 1 + in + FC.validateNamed + (FC.unqualifiedName $ "NonEmpty " <> FC.nameUnqualified (FC.schemaName itemSchema)) + validator + (FC.array itemSchema) + +set :: (Ord a, FleeceOpenApi3 schema) => FC.SetDuplicateHandling -> schema a -> schema (Set.Set a) +set handling itemSchema = + FC.validateNamed + (FC.unqualifiedName $ "Set [" <> FC.nameUnqualified (FC.schemaName itemSchema) <> "]") + (uniqueItems handling) + (FC.array itemSchema) + +nonEmptyText :: FleeceOpenApi3 schema => schema NET.NonEmptyText +nonEmptyText = + let + validator = + FC.transform NET.toText (fromJust . NET.fromText) + `FC.compose` minLength 1 + in + FC.validateNamed + (FC.unqualifiedName "NonEmptyText") + validator + FC.text + +integer :: FleeceOpenApi3 schema => schema Integer +integer = unboundedIntegralNumber + +unboundedIntegralNumberNamed :: + (FleeceOpenApi3 schema, Integral n) => + FC.Name -> + schema n +unboundedIntegralNumberNamed name = + FC.validateNamed + name + (setValidatorType "integer" FC.identity) + (FC.unboundedIntegralNumberNamed name) + +unboundedIntegralNumber :: + (FleeceOpenApi3 schema, Integral n, Typeable n) => + schema n +unboundedIntegralNumber = + let + name = + FC.defaultSchemaName schema + + schema = + unboundedIntegralNumberNamed name + in + schema + +boundedIntegralNumberNamed :: + (FleeceOpenApi3 schema, Integral n, Bounded n) => + FC.Name -> + schema n +boundedIntegralNumberNamed name = + let + validator = + minimumIntegral minBound + `FC.compose` maximumIntegral maxBound + in + FC.validateNamed + name + validator + (unboundedIntegralNumberNamed name) + +boundedIntegralNumber :: + (FleeceOpenApi3 schema, Integral n, Bounded n, Typeable n) => + schema n +boundedIntegralNumber = + let + name = + FC.defaultSchemaName schema + + schema = + boundedIntegralNumberNamed name + in + schema + +int :: FleeceOpenApi3 schema => schema Int +int = boundedIntegralNumber + +int8 :: FleeceOpenApi3 schema => schema I.Int8 +int8 = boundedIntegralNumber + +int16 :: FleeceOpenApi3 schema => schema I.Int16 +int16 = boundedIntegralNumber + +int32 :: FleeceOpenApi3 schema => schema I.Int32 +int32 = FC.validate (setValidatorFormat "int32" FC.identity) boundedIntegralNumber + +int64 :: FleeceOpenApi3 schema => schema I.Int64 +int64 = FC.validate (setValidatorFormat "int64" FC.identity) boundedIntegralNumber + +word :: FleeceOpenApi3 schema => schema Word +word = boundedIntegralNumber + +word8 :: FleeceOpenApi3 schema => schema W.Word8 +word8 = boundedIntegralNumber + +word16 :: FleeceOpenApi3 schema => schema W.Word16 +word16 = boundedIntegralNumber + +word32 :: FleeceOpenApi3 schema => schema W.Word32 +word32 = boundedIntegralNumber + +word64 :: FleeceOpenApi3 schema => schema W.Word64 +word64 = boundedIntegralNumber + +double :: FleeceOpenApi3 schema => schema Double +double = FC.validate (setValidatorFormat "double" FC.identity) FC.realFloat + +float :: FleeceOpenApi3 schema => schema Float +float = FC.validate (setValidatorFormat "float" FC.identity) FC.realFloat + +utcTime :: FleeceOpenApi3 schema => schema Time.UTCTime +utcTime = dateTimeFormat FC.utcTime + +utcTimeWithFormat :: FleeceOpenApi3 schema => String -> schema Time.UTCTime +utcTimeWithFormat s = customFormat (T.pack s) $ FC.utcTimeWithFormat s + +localTime :: FleeceOpenApi3 schema => schema Time.LocalTime +localTime = dateTimeFormat FC.localTime + +localTimeWithFormat :: FleeceOpenApi3 schema => String -> schema Time.LocalTime +localTimeWithFormat s = customFormat (T.pack s) $ FC.localTimeWithFormat s + +zonedTime :: FleeceOpenApi3 schema => schema Time.ZonedTime +zonedTime = dateTimeFormat FC.zonedTime + +zonedTimeWithFormat :: FleeceOpenApi3 schema => String -> schema Time.ZonedTime +zonedTimeWithFormat s = customFormat (T.pack s) $ FC.zonedTimeWithFormat s + +day :: FleeceOpenApi3 schema => schema Time.Day +day = FC.validateNamed "Day" (setValidatorFormat "date" FC.identity) FC.day + +dayWithFormat :: FleeceOpenApi3 schema => String -> schema Time.Day +dayWithFormat s = customFormat (T.pack s) $ FC.dayWithFormat s + +dateTimeFormat :: FleeceOpenApi3 schema => schema a -> schema a +dateTimeFormat schema = + FC.validateNamed (FC.schemaName schema) (setValidatorFormat "date-time" FC.identity) schema + +customFormat :: FleeceOpenApi3 schema => T.Text -> schema a -> schema a +customFormat format schema = + FC.validateNamed (FC.schemaName schema) (setValidatorFormat format FC.identity) schema diff --git a/json-fleece-pretty-print/json-fleece-pretty-print.cabal b/json-fleece-pretty-print/json-fleece-pretty-print.cabal index 0d49fcc1..47674f59 100644 --- a/json-fleece-pretty-print/json-fleece-pretty-print.cabal +++ b/json-fleece-pretty-print/json-fleece-pretty-print.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-pretty-print -version: 0.1.3.0 +version: 0.2.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -36,7 +36,8 @@ library base >=4.7 && <5 , containers ==0.6.* , dlist ==1.0.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* + , json-fleece-openapi3 ==0.5.* , scientific ==0.3.* , shrubbery ==0.2.* , text >=1.2 && <2.1 @@ -58,7 +59,7 @@ test-suite json-fleece-pretty-print-test base >=4.7 && <5 , containers ==0.6.* , hedgehog - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-examples , json-fleece-pretty-print , shrubbery ==0.2.* diff --git a/json-fleece-pretty-print/package.yaml b/json-fleece-pretty-print/package.yaml index 7bc00d00..a9c4d07d 100644 --- a/json-fleece-pretty-print/package.yaml +++ b/json-fleece-pretty-print/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-pretty-print -version: 0.1.3.0 +version: 0.2.0.0 github: "flipstone/json-fleece/json-fleece-pretty-print" license: BSD3 author: "Author name here" @@ -17,7 +17,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 -- json-fleece-core >= 0.7 && < 0.8 +- json-fleece-core >= 0.8 && < 0.9 - shrubbery >= 0.2 && < 0.3 - text >= 1.2 && < 2.1 @@ -55,6 +55,7 @@ library: dependencies: - containers >= 0.6 && < 0.7 - dlist >= 1.0 && < 1.1 + - json-fleece-openapi3 >= 0.5 && < 0.6 - scientific >= 0.3 && < 0.4 tests: diff --git a/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs b/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs index 3d531408..5f5fedfa 100644 --- a/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs +++ b/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -21,6 +22,7 @@ import GHC.TypeLits (symbolVal) import qualified Shrubbery import qualified Fleece.Core as FC +import qualified Fleece.OpenApi3 as FleeceOpenApi3 data PrettyPrinter a = PrettyPrinter FC.Name (a -> Pretty) @@ -88,6 +90,9 @@ instance FC.Fleece PrettyPrinter where newtype TaggedUnionMembers PrettyPrinter _allTags handledTags = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTags (T.Text, DList.DList Pretty)) + newtype Validator PrettyPrinter a b = PrettyPrinterValidator (FC.StandardValidator a b) + deriving (FC.FleeceValidator, FleeceOpenApi3.OpenApi3Validator) + schemaName (PrettyPrinter name _toBuilder) = name @@ -166,11 +171,11 @@ instance FC.Fleece PrettyPrinter where , Indent (Block (map (\f -> f object) (DList.toList fields))) ] - validateNamed name unvalidate _check (PrettyPrinter _name toPretty) = + validateNamed name validator (PrettyPrinter _name toPretty) = PrettyPrinter name $ \value -> prefixConstructor (renderName name) - (toPretty (unvalidate value)) + (toPretty (FC.uncheck validator value)) boundedEnumNamed name toText = PrettyPrinter name (showInline . toText) diff --git a/json-fleece-swagger2/examples/uber/package.yaml b/json-fleece-swagger2/examples/uber/package.yaml index c66e5155..e2891b41 100644 --- a/json-fleece-swagger2/examples/uber/package.yaml +++ b/json-fleece-swagger2/examples/uber/package.yaml @@ -13,7 +13,7 @@ dependencies: - base >= 4.7 && < 5 - text - scientific - - json-fleece-core >= 0.1.3 && < 0.8 + - json-fleece-core >= 0.8 && < 0.9 - json-fleece-aeson-beeline >= 0.2 && < 0.3 - beeline-routing >= 0.2.4 && < 0.3 - beeline-http-client >= 0.8 && < 0.9 diff --git a/json-fleece-swagger2/examples/uber/stack.yaml b/json-fleece-swagger2/examples/uber/stack.yaml index 29f3eb6b..f52b7844 100644 --- a/json-fleece-swagger2/examples/uber/stack.yaml +++ b/json-fleece-swagger2/examples/uber/stack.yaml @@ -27,6 +27,8 @@ extra-deps: - ../../../json-fleece-core - ../../../json-fleece-aeson - ../../../json-fleece-aeson-beeline + - ../../../json-fleece-openapi3 + - ../../../json-fleece-codegen-util - git: https://github.com/flipstone/beeline commit: 343c3e5fabc812e5c32efa33ddf8a6cee965e8b0 subdirs: diff --git a/json-fleece-swagger2/examples/uber/uber.cabal b/json-fleece-swagger2/examples/uber/uber.cabal index c6df8a0a..ed85cd52 100644 --- a/json-fleece-swagger2/examples/uber/uber.cabal +++ b/json-fleece-swagger2/examples/uber/uber.cabal @@ -73,7 +73,7 @@ library , beeline-http-client ==0.8.* , beeline-routing >=0.2.4 && <0.3 , json-fleece-aeson-beeline ==0.2.* - , json-fleece-core >=0.1.3 && <0.8 + , json-fleece-core ==0.8.* , scientific , text , time diff --git a/json-fleece-swagger2/json-fleece-swagger2.cabal b/json-fleece-swagger2/json-fleece-swagger2.cabal index 08537d0b..30a2aa74 100644 --- a/json-fleece-swagger2/json-fleece-swagger2.cabal +++ b/json-fleece-swagger2/json-fleece-swagger2.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-swagger2 -version: 0.4.0.4 +version: 0.5.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -86,7 +86,7 @@ library base >=4.7 && <5 , insert-ordered-containers ==0.2.* , json-fleece-codegen-util >=0.6 && <0.11 - , json-fleece-openapi3 ==0.4.* + , json-fleece-openapi3 ==0.5.* , openapi3 ==3.2.* , swagger2 ==2.8.* , text >=1.2 && <2.1 diff --git a/json-fleece-swagger2/package.yaml b/json-fleece-swagger2/package.yaml index e5c8416e..299ce334 100644 --- a/json-fleece-swagger2/package.yaml +++ b/json-fleece-swagger2/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-swagger2 -version: 0.4.0.4 +version: 0.5.0.0 github: "flipstone/json-fleece/json-fleece-swagger2" license: BSD3 author: "Author name here" @@ -57,7 +57,7 @@ library: exposed-modules: - Fleece.Swagger2 dependencies: - - json-fleece-openapi3 >= 0.4 && < 0.5 + - json-fleece-openapi3 >= 0.5 && < 0.6 - insert-ordered-containers >= 0.2 && < 0.3 - swagger2 >= 2.8 && < 2.9 - openapi3 >= 3.2 && < 3.3