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