openapi-hs (empty) → 4.0.0
raw patch · 40 files changed
+11876/−0 lines, 40 filesdep +HUnitdep +QuickCheckdep +aeson
Dependencies added: HUnit, QuickCheck, aeson, aeson-pretty, base, base-compat-batteries, bytestring, containers, cookie, generics-sop, hashable, hspec, http-media, insert-ordered-containers, lens, mtl, openapi-hs, optics-core, optics-th, quickcheck-instances, scientific, template-haskell, text, time, transformers, unordered-containers, utf8-string, uuid-types, vector
Files
- CHANGELOG.md +414/−0
- LICENSE +29/−0
- MIGRATION_3.0_TO_3.1.md +89/−0
- README.md +224/−0
- examples/hackage.hs +134/−0
- openapi-hs.cabal +168/−0
- src/Data/HashMap/Strict/InsOrd/Compat.hs +453/−0
- src/Data/OpenApi.hs +440/−0
- src/Data/OpenApi/Aeson/Compat.hs +89/−0
- src/Data/OpenApi/Declare.hs +188/−0
- src/Data/OpenApi/Internal.hs +1855/−0
- src/Data/OpenApi/Internal/AesonUtils.hs +355/−0
- src/Data/OpenApi/Internal/ParamSchema.hs +386/−0
- src/Data/OpenApi/Internal/Schema.hs +1236/−0
- src/Data/OpenApi/Internal/Schema/Validation.hs +715/−0
- src/Data/OpenApi/Internal/TypeShape.hs +66/−0
- src/Data/OpenApi/Internal/Utils.hs +149/−0
- src/Data/OpenApi/Lens.hs +191/−0
- src/Data/OpenApi/Migration.hs +115/−0
- src/Data/OpenApi/Operation.hs +307/−0
- src/Data/OpenApi/Optics.hs +379/−0
- src/Data/OpenApi/ParamSchema.hs +27/−0
- src/Data/OpenApi/Schema.hs +53/−0
- src/Data/OpenApi/Schema/Generator.hs +157/−0
- src/Data/OpenApi/Schema/Validation.hs +90/−0
- src/Data/OpenApi/SchemaOptions.hs +76/−0
- test/Data/OpenApi/CommonTestTypes.hs +1149/−0
- test/Data/OpenApi/MigrationSpec.hs +79/−0
- test/Data/OpenApi/ParamSchemaSpec.hs +37/−0
- test/Data/OpenApi/Schema/CoreTypes31Spec.hs +61/−0
- test/Data/OpenApi/Schema/GeneratorSpec.hs +176/−0
- test/Data/OpenApi/Schema/RoundtripSpec.hs +55/−0
- test/Data/OpenApi/Schema/Validation31Spec.hs +120/−0
- test/Data/OpenApi/Schema/ValidationSpec.hs +340/−0
- test/Data/OpenApi/Schema31Spec.hs +94/−0
- test/Data/OpenApi/SchemaSpec.hs +119/−0
- test/Data/OpenApi/TopLevel31Spec.hs +82/−0
- test/Data/OpenApiSpec.hs +1157/−0
- test/Spec.hs +1/−0
- test/SpecCommon.hs +21/−0
+ CHANGELOG.md view
@@ -0,0 +1,414 @@+4.0.0+-----++- **Breaking:** the data model now represents OpenAPI 3.1 / JSON Schema 2020-12+ instead of 3.0. Supported spec versions are 3.1.x.+- **Breaking:** removed `nullable`; use `type: ["...","null"]` (`OpenApiTypeArray`).+- **Breaking:** `exclusiveMaximum`/`exclusiveMinimum` are now numeric (`Scientific`)+ and independent of `maximum`/`minimum`.+- **Breaking:** removed the tuple `items` array; use `prefixItems` + `items: false`.+ Generic `ToSchema` derivation for Haskell tuples (and `sketchSchema`/`sketchStrictSchema`)+ now emits this positional `prefixItems` form, preserving each member's type.+- Added JSON Schema 2020-12 fields: `prefixItems`, `const`, `if`/`then`/`else`,+ `contains`/`minContains`/`maxContains`, `unevaluatedProperties`/`unevaluatedItems`,+ `dependentSchemas`/`dependentRequired`, `propertyNames`, content keywords, `examples`,+ and `$id`/`$anchor`/`$defs`/`$ref`/`$dynamicRef`/`$dynamicAnchor`.+- Added top-level 3.1 features: `webhooks`, `Info.summary`, `License.identifier`,+ and `$ref` on `PathItem`.+- Added `Value`-layer 3.0->3.1 migration helpers in `Data.OpenApi.Migration`+ (see `MIGRATION_3.0_TO_3.1.md`).+- Schema validation understands the new 3.1 keywords (type arrays, numeric+ exclusive bounds, `prefixItems`, `contains*`, `if`/`then`/`else`, `const`, and a+ best-effort `unevaluated*`).+- The `example` executable now emits a complete OpenAPI 3.1 contract (with `info`,+ a server, top-level `tags`, and a unique `operationId` per operation) to stdout, so+ its output lints cleanly under [`vacuum`](https://quobix.com/vacuum/) for external,+ authoritative conformance checking.+- **Build:** Cabal-only on GHC 9.12.4/9.14.1; removed `stack.yaml` and the custom+ `Setup.hs`/`cabal-doctest` machinery; `build-type: Simple`.+- **Renamed** the package from `openapi3` to `openapi-hs` (module namespace+ `Data.OpenApi.*` unchanged).++3.2.5+-----++- Support insert-ordered-containers 0.3 [#119](https://github.com/biocad/openapi3/pull/119).++3.2.4+-----++- Give `title` to sub schemas of sum types [#88](https://github.com/biocad/openapi3/pull/88).++3.2.3+-----++- Fix generation of `allOf` / `oneOf` schemas when variants are not objects [#49](https://github.com/biocad/openapi3/pull/49).+- Support parsing OpenAPI 3.0.1, 3.0.2, 3.0.3 versions [#68](https://github.com/biocad/openapi3/pull/68).+- Support GHC-9.4 [#61](https://github.com/biocad/openapi3/pull/61).+- Output `scopes` in schema even if empty [#65](https://github.com/biocad/openapi3/pull/65).+- Fix `mtl-2.3` compatibility [#60](https://github.com/biocad/openapi3/pull/60).++3.2.2+-----++- Fix bug with infinite recursion in GToSchema [#37](https://github.com/biocad/openapi3/pull/37).++3.2.1+-----++- Support aeson-2.0.3.+- Support GHC-9.2 (doctests still fail).++3.2.0+-----++- Support aeson-2 [#34](https://github.com/biocad/openapi3/pull/34).+- Use `SecurityDefinitions` type for `_componentsSecuritySchemes`+ [#32](https://github.com/biocad/openapi3/pull/32).++3.1.0+-----++- Use `format: date-time` for `ToParamSchema ZonedTime` instance (see+ [#20](https://github.com/biocad/openapi3/pull/20)).+- Support generating schema for any polymorphic types via `Typeable` (see+ [#19](https://github.com/biocad/openapi3/pull/19)).+- Allow `hashable-1.3.1`, prettify doctests (see [#18](https://github.com/biocad/openapi3/pull/18)).++3.0.2.0+-------++- Fix definition for HTTP security scheme (see [#10](https://github.com/biocad/openapi3/pull/10));+- Fix error message in `exclusiveMaximum` / `exclusiveMinimum` validation (see+ [#15](https://github.com/biocad/openapi3/pull/15));++3.0.1.0+-------++- Support polymorphic types in schema generator.++3.0.0+-----++- Switch to OpenAPI 3.0 specification.++2.6.1+-----++- More GHC-8.10 related cleanup, tighten lower bound on some dependencies.+ (see [#216]( https://github.com/GetShopTV/swagger2/pull/216 ));+- Add "format" field for uint32 and uint64+ (see [#215]( https://github.com/GetShopTV/swagger2/pull/215 ));++2.6+---++- GHC 8.10 support (see [#210]( https://github.com/GetShopTV/swagger2/pull/210 ));+- Move `aeson-pretty` to other dependencies (see [#206]( https://github.com/GetShopTV/swagger2/pull/206 ));+- Merge OAuth2 scopes (see [#151]( https://github.com/GetShopTV/swagger2/pull/151 ));++2.5+---++Highlights:+- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));+- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));+- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));++Fixes and minor changes:+- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));+- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));+- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));++2.4+---++- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5+- Tags aren't sorted+ (see [#165](https://github.com/GetShopTV/swagger2/issues/165))+- Schema type is optional+ (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))+- Take concrete 'Proxy' as argument+ (see [#180](https://github.com/GetShopTV/swagger2/pull/180))+- GHC-8.8 preparations++2.3.1.1+-------++- Allow `network-3.0`++2.3.1+-----++- Add a quickcheck generator for aeson Values that match a swagger schema+ (see [#162](https://github.com/GetShopTV/swagger2/pull/162))+- Add `ToParamSchema` instance for `SetCookie`+ (see [#173](https://github.com/GetShopTV/swagger2/pull/173))+- Make nullary schemas valid+ (see [#168](https://github.com/GetShopTV/swagger2/pull/168))++2.3.0.1+-------++- Support GHC-8.6++2.3+---++Major changes:++- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));+- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));++Dependencies and CI:++- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));+- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));+- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));+- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));++2.2.2+-----++* Add `ToSchema Version` instance+* Use base-compat-batteries (0.10)+* PVP bounds++2.2.1+-----++* Add `Semigroup` instances+* GHC-8.4 compatibility+* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))+* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))+* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))+* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))++2.2+---++* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));+* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));+* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):+ * `genericNameSchema` — to give a custom schema `Generic`-based name;+ * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;+ * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;+* Add a few tests with invalid `Schema`.++2.1.6+-----++* Add `ToParamSchema` and `ToSchema` instances for `Fixed` (see [#121](https://github.com/GetShopTV/swagger2/pull/121)) and `Natural` (see [#123](https://github.com/GetShopTV/swagger2/pull/123));+* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));+* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).++2.1.5+-----++* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));+* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));+* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));+* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).++2.1.4.1+-------++* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108));+* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));+* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));+* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).++2.1.4+-----++* Add `liftDeclare` (see [#100](https://github.com/GetShopTV/swagger2/pull/100));+* Add `MonadDeclare` instances for all monad transformers (see [#100](https://github.com/GetShopTV/swagger2/pull/100)).++2.1.3+-----++* Add [`UUID`](http://hackage.haskell.org/package/uuid-types/docs/Data-UUID-Types.html#t:UUID) instances (see [#81](https://github.com/GetShopTV/swagger2/pull/81)).+* Add [`TypeError`](https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-TypeLits.html#g:4) `ToSchema` and `ToParamSchema ByteString` instances (see [#78](https://github.com/GetShopTV/swagger2/pull/78))+* Improve documentation for generic sum type instance derivation (see [#75](https://github.com/GetShopTV/swagger2/pull/75))+* Compile warning free (see [#82](https://github.com/GetShopTV/swagger2/pull/82))++2.1.2.1+-------++* Bug fix previous release++2.1.2+---++* Minor changes:+ * Support `aeson-1.0.0.0` (see [#70](https://github.com/GetShopTV/swagger2/pull/70)).++2.1.1+---++* Minor changes:+ * Proper `Schema` examples for `Char`, `Day`, `LocalTime`, `ZonedTime` and `UTCTime`.++2.1+---++* Major changes:+ * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));+ * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).++2.0.2+---++* Fixes:+ * Fix `additionalProperties` to allow references;+ * Fix `ToSchema` instances for `Map` and `HashMap` (prevent infinite recursion for recursive values).++2.0.1+---++* Fixes:+ * Re-export `Pattern` synonym from `Data.Swagger`;+ * Documentation fixes.++2.0+---++* Major changes:+ * GHC 7.8 support (see [#49](https://github.com/GetShopTV/swagger2/pull/49));+ * Switch to classy field lenses (see [#41](https://github.com/GetShopTV/swagger2/pull/41));+ * Add `Data.Swagger.Schema.Validation` (see [#18](https://github.com/GetShopTV/swagger2/pull/18));+ * Add `Data.Swagger.Operation` with helpers (see [#50](https://github.com/GetShopTV/swagger2/pull/50));+ * Add `IsString` instances for some types (see [#47](https://github.com/GetShopTV/swagger2/pull/47));+ * Add helpers to sketch `Schema` from JSON (see [#48](https://github.com/GetShopTV/swagger2/pull/48)).++* Minor changes:+ * Make `NamedSchema` a `data` rather than `type` (see [#42](https://github.com/GetShopTV/swagger2/pull/42));+ * Change `Definitions` to `Definitions Schema`;+ * Add schema templates for `"binary"`, `"byte"` and `"password"` formats (see [63ed597](https://github.com/GetShopTV/swagger2/commit/63ed59736dc4f942f0e2a7d668d7cee513fa9eaf));+ * Add `Monoid` instance for `Contact`;+ * Change `tags` to be `Set` rather than list.++* Fixes:+ * Fix schema for `()` and nullary constructors (see [ab65c4a](https://github.com/GetShopTV/swagger2/commit/ab65c4a48253c34f8a88221a53dc97bf5e6e8d29));+ * Fix `Operation` `FromJSON` instance to allow missing `tags` and `parameters` properties.++1.2.1+---++* Minor changes:+ * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.++* Fixes:+ * Fix build for GHC 8.0-rc1.++1.2+---+* Minor changes (see [#36](https://github.com/GetShopTV/swagger2/pull/36)):+ * Change default `ToSchema` instance for unit data types (i.e. types with one nullable constructor like `data Unit = Unit`):+ now these types are treated like sum types with only one alternative;+ * Add generic `ToParamSchema` instance for unit data types;+ * Add `items: []` to schema for `()` (making it a valid schema).++* Fixes:+ * Do not omit `items: []` from `Schema` JSON;+ * Do not generate unused definitions for nested `newtype`s (see [#38](https://github.com/GetShopTV/swagger2/pull/38)).++1.1.1+---+* Fixes:+ * `CollectionFormat Param` -> `CollectionFormat ParamOtherSchema`;+ this change was necessary after putting `CollectionFormat` to `SwaggerItems`.++1.1+---+* Major changes:+ * Put `CollectionFormat` in one place (see [`3cc860d`](https://github.com/GetShopTV/swagger2/commit/3cc860dd3f002ab984f4d0e4ce1d1799f985832e)).++* Minor changes:+ * Use Swagger formats for `Int32`, `Int64`, `Float`, `Double`, `Day` and `ZonedTime` (see [#32](https://github.com/GetShopTV/swagger2/pull/32));+ * Export `HeaderName`, `TagName`, `HttpStatusCode` type synonyms;+ * Add `ToParamSchema` instances for `[a]`, `Set a` and `HashSet a`;+ * Add `Monoid` instances for `Header` and `Example`.++* Fixes:+ * Use overwrite strategy for `HashMap` `SwaggerMonoid` instances by default.++1.0+---+* Major changes:+ * Add `Data` and `Typeable` instances for `Data.Swagger` types;+ * Merge `ParamType`/`ItemsType`/`SchemaType` into `SwaggerType` GADT;+ * Merge collection format types into `CollectionFormat` GADT;+ * Introduce `SwaggerItems` GADT, replacing `Items` and `SchemaItems` in `ParamSchema` (see [#24](https://github.com/GetShopTV/swagger2/pull/24));+ * Move type, format and items fields to `ParamSchema` (former `SchemaComon`);+ * Prepend reference path automatically (see [commit 49d1fad](https://github.com/GetShopTV/swagger2/commit/49d1fadd2100644e70c442667180d0d73e107a5f))+ and thus remove `"#/definitions/"` from user code, leaving much clearer `Reference "Name"`;+ * Change `Data.Swagger.Schema` (see [#19](https://github.com/GetShopTV/swagger2/pull/19)):+ * Change the only method of `ToSchema` to `declareNamedSchema` which should produce a `NamedSchema`+ along with a list of schema definitions used to produce it;+ * Add `declareSchema`, `declareSchemaRef`;+ * Replace `genericTo*` helpers with `genericDeclare*` helpers;+ * Add `paramSchemaTo[Named]Schema` helpers to facilitate code reuse for primitive schemas;+ * Add helpers for inlining `Schema` references dynamically (see [#23](https://github.com/GetShopTV/swagger2/pull/23));+ * Add `ToParamSchema` class (see [#17](https://github.com/GetShopTV/swagger2/pull/17)) with+ * generic default implementation and+ * instances for some base types compliant with `http-api-data` instances;+ * Add `Data.Swagger.Declare` module with+ * `DeclareT` monad transformer;+ * `MonadDeclare` type class;+ * various helpers;+ * Rename parameter-related types:+ * `Parameter` -> `Param`;+ * `ParameterSchema` -> `ParamAnySchema`;+ * `ParameterOtherSchema` -> `ParamOtherSchema`;+ * `ParameterLocation` -> `ParamLocation`;+ * `SchemaCommon` -> `ParamSchema`;+ * `parameter*` fields renamed to `param*` fields;+ * `schemaCommon*` fields renamed to `paramSchema*` fields;+ * `HasSchemaCommon` -> `HasParamSchema`.++* Minor changes:+ * Replace TH-generated JSON instances with `Generic`-based (see [#25](https://github.com/GetShopTV/swagger2/pull/25));+ * Drop `template-haskell` dependency;+ * Omit empty array/object properties from `toJSON` output ([#22](https://github.com/GetShopTV/swagger2/pull/22));+ * Remove `minLength` property from schemas for `time` types;+ * Move `SchemaOptions` to `Data.Swagger.SchemaOptions`;+ * Remove `useReferences` from `SchemaOptions` (see [#23](https://github.com/GetShopTV/swagger2/pull/23));+ * Place all internal submodules under `Data.Swagger.Internal`;+ * Better documentation (see [#26](https://github.com/GetShopTV/swagger2/pull/26)).++0.4.1+---+* Fixes:+ * Use `PackageImports` for `Data.HashSet` to avoid test failure on stackage (see [#15](https://github.com/GetShopTV/swagger2/issues/15));+ * Add an upper version bound for `aeson` due to `aeson-0.10.0.0` bug (see [bos/aeson#293](https://github.com/bos/aeson/issues/293));+ * Switch to Cabal-based multi GHC Travis config.++0.4+---+* Remove `Swagger`/`swagger` prefixes;+* Add `ToSchema` type class with default generic implementation;+* Add configurable generic `ToSchema` helpers;+* Add `doctest` test suite;+* Fixes:+ * Fix `HasSchemaCommon` instance for `Schema`;+ * Change `minimum`, `maximum` and `multipleOf` properties to be any number,+ not necessarily an integer;+ * Fix all warnings.++0.3+---+* Fixes:+ * Fix `SwaggerMonoid Text` instance;+ * Wrap `Bool` in `Maybe` everywhere;+ * These changes make all `Data.Swagger` `Monoid` instances obey monoid laws+ (previously right identity law was broken by some instances).++0.2+---+* Add `Data.Swagger.Lens`;+* Support references;+* Fixes:+ * Fix `FromJSON SwaggerHost` instance;+ * Add missing `Maybe`s for field types;+ * Decode petstore `swagger.json` successfully.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2015-2016, GetShopTV+Copyright (c) 2020, Biocad+Copyright (c) 2026, Nadeem Bitar+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of openapi-hs nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ MIGRATION_3.0_TO_3.1.md view
@@ -0,0 +1,89 @@+# Migrating from OpenAPI 3.0 to 3.1 (`openapi-hs` 4.0.0)++`openapi-hs` 4.0.0 models **OpenAPI 3.1 / JSON Schema 2020-12 only**. The Haskell+types deliberately cannot represent 3.0-only constructs ("Strategy A"), so a 3.0+document does not decode directly. This guide explains what changed and how to+bring a 3.0 document forward.++The Haskell module namespace is unchanged (`Data.OpenApi.*`); downstream code only+swaps the dependency name `openapi3` → `openapi-hs`.++## Breaking changes++- **`nullable` removed.** JSON Schema 2020-12 has no `nullable` keyword. Express+ nullability with a type array instead: `{"type": "string", "nullable": true}`+ becomes `{"type": ["string", "null"]}`. In Haskell, `_schemaType` is now+ `Maybe OpenApiTypeValue` (`OpenApiTypeSingle` or `OpenApiTypeArray`); there is no+ `_schemaNullable` field.+- **`exclusiveMaximum` / `exclusiveMinimum` are numeric and independent.** In 3.0+ they were booleans modifying `maximum` / `minimum`. In 3.1 they are numbers+ carrying a strict bound, independent of `maximum` / `minimum` (a schema may carry+ both). In Haskell they are `Maybe Scientific`, not `Maybe Bool`.+- **Tuple `items` arrays removed.** 3.0 used `"items": [s1, s2]` for fixed-length+ tuples. 3.1 uses `"prefixItems": [s1, s2]` plus `"items": false` (no extra+ elements). In Haskell, `OpenApiItems` is now `OpenApiItemsObject | OpenApiItemsBoolean`+ (no `OpenApiItemsArray`); tuple positions live in the new `_schemaPrefixItems` field.+- **Supported spec versions are 3.1.x.** `lowerOpenApiSpecVersion`/+ `upperOpenApiSpecVersion` are `3.1.0` / `3.1.1`; the default `mempty :: OpenApi`+ emits `"openapi": "3.1.0"`. A 3.0.x version string fails the version-bounds check.+- **Package renamed** `openapi3` → `openapi-hs` (modules unchanged).+- **Build modernized:** Cabal-only on GHC 9.12.4 / 9.14.1; no `stack.yaml`, no+ custom `Setup.hs` / `cabal-doctest`.++## What's new in 3.1++Additive JSON Schema 2020-12 fields: `const`, `prefixItems`, `contains` /+`minContains` / `maxContains`, `if` / `then` / `else`, `dependentSchemas` /+`dependentRequired`, `unevaluatedProperties` / `unevaluatedItems`, `propertyNames`,+`contentEncoding` / `contentMediaType` / `contentSchema`, `examples`, and the+`$`-prefixed identification keywords `$id` / `$anchor` / `$defs` / `$ref` /+`$dynamicRef` / `$dynamicAnchor`. Top-level: `webhooks` on `OpenApi`, `summary` on+`Info`, `identifier` on `License`, and `$ref` on `PathItem`.++## Bringing a 3.0 document forward++Rewrite the **parsed JSON** (a `Data.Aeson.Value`) into a 3.1 shape *before*+decoding, using `Data.OpenApi.Migration`. The whole-document walk is `migrate30To31`:++```haskell+{-# LANGUAGE OverloadedStrings #-}+import Data.Aeson (decode, encode, eitherDecode)+import Data.OpenApi (OpenApi, Schema)+import Data.OpenApi.Migration (migrate30To31)++bring30Forward :: Data.Aeson.Value -> Maybe OpenApi+bring30Forward raw30 = decode (encode (migrate30To31 raw30))+```++`migrate30To31` recurses into every nested object (`properties`, `prefixItems`,+`$defs`, `allOf`, request/response bodies, …), so nested schemas are migrated too.++The single-concern helpers are also exported and can be applied to one schema object:++```haskell+import Data.OpenApi.Migration+ ( migrate30NullableValue -- nullable:true -> type array+ , migrate30ExclusiveBoundsValue -- boolean bounds -> numeric bounds+ , migrate30ItemsArrayValue -- items:[..] -> prefixItems + items:false+ )++-- {"type":"string","nullable":true} -> {"type":["string","null"]}+migrate30NullableValue v+```++All migration helpers are **`{-# DEPRECATED #-}` on purpose**: they exist to flag+that 3.0 input is transitional. The warning is your cue to migrate inputs to 3.1 at+the source and drop the helper call.++## Pitfalls++- A bare `nullable: true` with **no** `type` becomes `{"type": ["null"]}` (a value+ that may only be `null`).+- `exclusiveMaximum: true` **drops** the accompanying `maximum` (its value moves into+ the numeric `exclusiveMaximum`). `exclusiveMaximum: false` just removes the boolean+ and keeps `maximum`.+- `migrate30ItemsArrayValue` fires only when `items` is a JSON **array**; an object or+ boolean `items` is left unchanged.+- Tuple `ToSchema` derivation for Haskell tuples currently emits a homogenised+ `anyOf` `items` element rather than positional `prefixItems` (a documented interim+ behavior; the `prefixItems` field exists for a future switch).
+ README.md view
@@ -0,0 +1,224 @@+# openapi-hs++[](https://hackage.haskell.org/package/openapi-hs)+[](/LICENSE)++A Haskell library for **decoding, encoding, manipulating, and validating+[OpenAPI 3.1](https://spec.openapis.org/oas/v3.1.0) documents** — the format that+describes HTTP APIs in JSON or YAML. OpenAPI 3.1 adopts the+[JSON Schema 2020-12](https://json-schema.org/specification-links#2020-12) dialect.++> **Fork notice.** `openapi-hs` is a fork of+> [`biocad/openapi3`](https://github.com/biocad/openapi3), which is no longer actively+> maintained and supports only OpenAPI 3.0. This fork brings the library up to OpenAPI 3.1.+> The Haskell module namespace is unchanged (`Data.OpenApi.*`), so migrating is usually just a+> dependency-name swap: `openapi3` → `openapi-hs`. The fork keeps the upstream+> [BSD-3-Clause license](#license) and copyright.++---++## Highlights++- **Full OpenAPI 3.1 / JSON Schema 2020-12 data model** with lossless JSON round-tripping.+- **Type arrays** for nullability (`type: ["string", "null"]`) instead of the removed `nullable`.+- **Numeric** `exclusiveMaximum` / `exclusiveMinimum`, independent of `maximum` / `minimum`.+- **Tuples via `prefixItems`** (+ `items: false`) instead of the removed `items` array form.+- **Conditional & assertion keywords:** `if`/`then`/`else`, `const`, `contains` /+ `minContains` / `maxContains`, `dependentSchemas` / `dependentRequired`,+ `unevaluatedProperties` / `unevaluatedItems`, content keywords, and `examples`.+- **JSON Schema identification keywords:** `$id`, `$anchor`, `$defs`, `$ref`, `$dynamicRef`,+ `$dynamicAnchor`.+- **Top-level 3.1 features:** `webhooks`, `Info.summary`, `License.identifier`, and `$ref` on+ `PathItem`.+- **Schema validation** that understands the new 3.1 keywords.+- **`ToSchema` derivation** to generate schemas from your Haskell types via `GHC.Generics`.+- **`lens` and `optics`** accessors for ergonomic reads and updates.+- **3.0 → 3.1 migration helpers** for documents you don't control yet.++## Installation++Add `openapi-hs` to your project's dependencies (Cabal):++```cabal+build-depends: openapi-hs+```++then import the umbrella module, which re-exports everything you typically need:++```haskell+import Data.OpenApi+```++Requires GHC **9.12.4** or **9.14.1**.++## Quick start++### Build and serialize a schema++```haskell+{-# LANGUAGE OverloadedStrings #-}+import Control.Lens+import Data.Aeson (encode)+import Data.OpenApi++-- "a string, or null" — 3.1 nullability via a type array+nullableString :: Schema+nullableString = mempty+ & type_ ?~ OpenApiTypeArray [OpenApiString, OpenApiNull]+ & description ?~ "an optional name"++-- encode nullableString == "{\"description\":\"an optional name\",\"type\":[\"string\",\"null\"]}"+```++### Derive a schema from a Haskell type++```haskell+{-# LANGUAGE DeriveGeneric #-}+import Data.Aeson (ToJSON)+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic)+import Data.OpenApi++data User = User+ { name :: String+ , age :: Int+ } deriving (Show, Generic)++instance ToJSON User -- needed for validation (below)+instance ToSchema User++userSchema :: Schema+userSchema = toSchema (Proxy :: Proxy User)+```++### Decode a 3.1 document++```haskell+import Data.Aeson (decode)+import Data.OpenApi (Schema)++-- decode "{\"prefixItems\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"items\":false}"+-- :: Maybe Schema+```++### Validate a value against a schema++```haskell+import Data.OpenApi+import Data.OpenApi.Schema.Validation (validateToJSON)++-- Using the `User` from above (which has both ToJSON and ToSchema):+-- validateToJSON returns [] when the value conforms to its derived schema,+-- or a list of human-readable errors otherwise.+ok :: [ValidationError]+ok = validateToJSON (User "Ada" 36) -- []+```++For validating an arbitrary JSON `Value` against a specific `Schema`, use+`validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]`.++## Lenses and optics++Every record field has a generated accessor in both the+[`lens`](https://hackage.haskell.org/package/lens) and+[`optics`](https://hackage.haskell.org/package/optics) styles. Import whichever you prefer:++```haskell+import Data.OpenApi -- lens accessors (Data.OpenApi.Lens)+-- or+import Data.OpenApi.Optics -- optics labels (#type, #properties, …)+```++A few field lenses are suffixed with `_` to avoid clashing with reserved words or `Prelude`+names: `type_`, `enum_`, `minimum_`, `maximum_`, `default_`, `const_`, `if_`, `then_`, `else_`,+`contains_`, `id_`. The corresponding optics labels keep the bare name (`#type`, `#const`, …).++## Migrating from OpenAPI 3.0++The 3.1 data types deliberately cannot represent 3.0-only constructs ("Strategy A"), so a 3.0+document does not decode directly. Rewrite the **parsed JSON** into a 3.1 shape first, using+`Data.OpenApi.Migration`:++```haskell+import Data.Aeson (Value, decode, encode)+import Data.OpenApi (OpenApi)+import Data.OpenApi.Migration (migrate30To31)++bring30Forward :: Value -> Maybe OpenApi+bring30Forward raw30 = decode (encode (migrate30To31 raw30))+```++`migrate30To31` recurses into every nested schema, rewriting `nullable` → type arrays, boolean+exclusive bounds → numeric bounds, and tuple `items` arrays → `prefixItems` + `items: false`.+The single-concern helpers (`migrate30NullableValue`, `migrate30ExclusiveBoundsValue`,+`migrate30ItemsArrayValue`) are also exported. They are intentionally **deprecated** to flag that+3.0 input is transitional.++See **[`MIGRATION_3.0_TO_3.1.md`](/MIGRATION_3.0_TO_3.1.md)** for the full breaking-changes list,+worked examples, and pitfalls.++## Examples++Runnable examples live in the [`examples/`](/examples) directory. Generated specifications can be+explored interactively in any OpenAPI 3.1 viewer or editor.++## Validation++The library's own correctness is checked at three complementary levels:++1. **Round-trip** — the test suite encodes documents and decodes them back through+ `FromJSON OpenApi`, which rejects any `openapi` version outside `3.1.0 … 3.1.1`, then+ compares for semantic equality.+2. **Schema conformance** — `Data.OpenApi.Schema.Validation` (`validateToJSON` /+ `validateJSON`) checks that values conform to their derived 3.1 schemas, including the new+ keywords.+3. **Authoritative conformance** — the `example` executable emits a complete OpenAPI 3.1+ contract (with `info`, a server, top-level `tags`, and a unique `operationId` per operation)+ that lints cleanly under [`vacuum`](https://quobix.com/vacuum/):++ ```bash+ cabal run example > openapi.json+ nix run nixpkgs#vacuum-go -- lint -d openapi.json+ ```++ The first two layers are *self-referential* — they confirm a document agrees with this+ library's own model of OpenAPI 3.1. `vacuum` is an external, authoritative linter, so it+ independently catches encoder output that is valid JSON but non-conformant OpenAPI.++## Building and developing++This repository ships a Nix flake providing a pinned GHC 9.12.4 toolchain. From the repository+root:++```bash+nix develop -c cabal build all+nix develop -c cabal test all+```++If you have a matching `cabal` + GHC 9.12.x on your `PATH`, the same commands work without the+`nix develop -c` prefix. The package is Cabal-only (`build-type: Simple`); there is no `stack.yaml`.++## Documentation++Full API documentation is on+[Hackage](https://hackage.haskell.org/package/openapi-hs). Each module's Haddocks include+worked examples.++The design and implementation strategy behind the 3.1 work is documented in+**[`docs/OPENAPI31_MIGRATION_PLAN.md`](https://github.com/shinzui/openapi-hs/blob/master/docs/OPENAPI31_MIGRATION_PLAN.md)**.++## Contributing++Bug reports, fixes, documentation improvements, and other contributions are welcome. Please open+an issue or pull request on the [GitHub issue tracker](https://github.com/shinzui/openapi-hs/issues).++## License++`openapi-hs` retains the original **BSD-3-Clause** license of the upstream+[`openapi3`](https://github.com/biocad/openapi3) project, including its copyright. See the+[`LICENSE`](/LICENSE) file for the full text; this fork's changes are released under the same+terms.++---++*Originally derived from work by the GetShopTV and Biocad teams.*
+ examples/hackage.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Emit a representative API's OpenAPI 3.1 document as JSON to stdout.+--+-- Besides serving as a runnable example, this feeds Layer-3 (external,+-- authoritative) validation:+--+-- > cabal run example > openapi.json+-- > nix run nixpkgs#vacuum-go -- lint -d openapi.json+--+-- The document is deliberately a complete OpenAPI 3.1 contract — it carries+-- @info@ (title/version/description), a @server@, top-level @tags@, and a+-- unique @operationId@ per operation — so an external linter has a realistic+-- document to validate rather than a bare skeleton.+module Main where++import Control.Lens+import Data.Aeson+import Data.ByteString.Lazy.Char8 qualified as BL+import Data.OpenApi+import Data.OpenApi.Declare+import Data.OpenApi.Lens+import Data.OpenApi.Operation+import Data.Proxy+import Data.Text (Text)+import GHC.Generics++type Username = Text++data UserSummary = UserSummary+ { summaryUsername :: Username,+ summaryUserid :: Int+ }+ deriving stock (Generic)++instance ToSchema UserSummary where+ declareNamedSchema _ = do+ usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)+ useridSchema <- declareSchemaRef (Proxy :: Proxy Int)+ return $+ NamedSchema (Just "UserSummary") $+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties+ .~ [ ("summaryUsername", usernameSchema),+ ("summaryUserid", useridSchema)+ ]+ & required+ .~ [ "summaryUsername",+ "summaryUserid"+ ]++type Group = Text++data UserDetailed = UserDetailed+ { username :: Username,+ userid :: Int,+ groups :: [Group]+ }+ deriving stock (Generic)+ deriving anyclass (ToSchema)++newtype Package = Package {packageName :: Text}+ deriving stock (Generic)+ deriving anyclass (ToSchema)++hackageOpenApi :: OpenApi+hackageOpenApi = spec & components . schemas .~ defs+ where+ (defs, spec) = runDeclare declareHackageOpenApi mempty++declareHackageOpenApi :: Declare (Definitions Schema) OpenApi+declareHackageOpenApi = do+ -- param schemas+ let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)++ -- responses+ userSummaryResponse <- declareResponse "application/json" (Proxy :: Proxy UserSummary)+ userDetailedResponse <- declareResponse "application/json" (Proxy :: Proxy UserDetailed)+ packagesResponse <- declareResponse "application/json" (Proxy :: Proxy [Package])++ return $+ mempty+ & info . title .~ "Hackage API"+ & info . version .~ "1.0.0"+ & info . description ?~ "A small, representative Hackage-style read API."+ & servers .~ ["https://hackage.haskell.org"]+ & tags+ .~ [ Tag "users" (Just "User lookup operations") Nothing,+ Tag "packages" (Just "Package operations") Nothing+ ]+ & paths+ .~ [ ( "/users",+ mempty+ & get+ ?~ ( mempty+ & operationId ?~ "getUsers"+ & tags .~ ["users"]+ & at 200 ?~ Inline userSummaryResponse+ )+ ),+ ( "/user/{username}",+ mempty+ & get+ ?~ ( mempty+ & operationId ?~ "getUser"+ & tags .~ ["users"]+ & parameters+ .~ [ Inline $+ mempty+ & name .~ "username"+ & required ?~ True+ & in_ .~ ParamPath+ & schema ?~ Inline usernameParamSchema+ ]+ & at 200 ?~ Inline userDetailedResponse+ )+ ),+ ( "/packages",+ mempty+ & get+ ?~ ( mempty+ & operationId ?~ "getPackages"+ & tags .~ ["packages"]+ & at 200 ?~ Inline packagesResponse+ )+ )+ ]++main :: IO ()+main = BL.putStrLn (encode hackageOpenApi)
+ openapi-hs.cabal view
@@ -0,0 +1,168 @@+cabal-version: 3.0+name: openapi-hs+version: 4.0.0+synopsis: OpenAPI 3.1 data model+category: Web, OpenApi+description:+ openapi-hs (a fork of the openapi3 library) is intended to be used for decoding and+ encoding OpenAPI 3.1 API specifications as well as manipulating them. The Haskell+ module namespace remains Data.OpenApi.*, so only the package dependency name changes+ for downstream users migrating from openapi3.+ .+ The OpenAPI 3.1 specification is available at https://spec.openapis.org/oas/v3.1.0++homepage: https://github.com/shinzui/openapi-hs+bug-reports: https://github.com/shinzui/openapi-hs/issues+license: BSD-3-Clause+license-file: LICENSE+author: Nickolay Kudasov, Maxim Koltsov, Nadeem Bitar+maintainer: nadeem@gmail.com+copyright:+ (c) 2015-2016, GetShopTV, (c) 2020, Biocad, (c) 2026, Nadeem Bitar++build-type: Simple+extra-source-files: examples/*.hs+extra-doc-files:+ CHANGELOG.md+ MIGRATION_3.0_TO_3.1.md+ README.md++tested-with: GHC ==9.12.4 || ==9.14.1++library+ hs-source-dirs: src+ exposed-modules:+ Data.HashMap.Strict.InsOrd.Compat+ Data.OpenApi+ Data.OpenApi.Aeson.Compat+ Data.OpenApi.Declare+ Data.OpenApi.Internal+ Data.OpenApi.Internal.AesonUtils+ Data.OpenApi.Internal.ParamSchema+ Data.OpenApi.Internal.Schema+ Data.OpenApi.Internal.Schema.Validation+ Data.OpenApi.Internal.TypeShape+ Data.OpenApi.Internal.Utils+ Data.OpenApi.Lens+ Data.OpenApi.Migration+ Data.OpenApi.Operation+ Data.OpenApi.Optics+ Data.OpenApi.ParamSchema+ Data.OpenApi.Schema+ Data.OpenApi.Schema.Generator+ Data.OpenApi.Schema.Validation+ Data.OpenApi.SchemaOptions++ -- internal modules+ -- GHC boot libraries+ build-depends:+ , base >=4.11.1.0 && <4.23+ , bytestring >=0.10.8.2 && <0.13+ , containers >=0.5.11.0 && <0.9+ , template-haskell >=2.13.0.0 && <2.25+ , time >=1.8.0.2 && <1.16+ , transformers >=0.5.5.0 && <0.7++ build-depends:+ , mtl >=2.2.2 && <2.4+ , text >=1.2.3.1 && <2.2++ -- other dependencies+ build-depends:+ , aeson >=2.0.1.0 && <2.3+ , aeson-pretty >=0.8.7 && <0.9+ , base-compat-batteries >=0.11.1 && <0.16+ , cookie >=0.4.3 && <0.6+ , generics-sop >=0.5.1.0 && <0.6+ , hashable >=1.2.7.0 && <1.6+ , http-media >=0.8.0.0 && <0.9+ , insert-ordered-containers >=0.2.3 && <0.4+ , lens >=4.16.1 && <5.4+ , optics-core >=0.2 && <0.5+ , optics-th >=0.2 && <0.5+ , QuickCheck >=2.10.1 && <2.19+ , scientific >=0.3.6.2 && <0.4+ , unordered-containers >=0.2.9.0 && <0.3+ , uuid-types >=1.0.3 && <1.1+ , vector >=0.12.0.1 && <0.14++ default-language: GHC2024+ default-extensions:+ DefaultSignatures+ FunctionalDependencies+ OverloadedLabels+ OverloadedStrings+ PackageImports+ RecordWildCards+ TemplateHaskell+ TypeFamilies+ UndecidableInstances+ UndecidableSuperClasses+ ViewPatterns++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs++ -- From library part+ -- We need aeson's toEncoding for doctests too+ build-depends:+ , aeson+ , base+ , base-compat-batteries+ , bytestring+ , containers+ , hashable+ , insert-ordered-containers+ , lens+ , mtl+ , openapi-hs+ , QuickCheck+ , template-haskell+ , text+ , time+ , unordered-containers+ , vector++ -- test-suite only dependencies+ build-depends:+ , hspec >=2.5.5 && <2.12+ , HUnit >=1.6.0.0 && <1.7+ , quickcheck-instances >=0.3.19 && <0.14+ , utf8-string >=1.0.1.1 && <1.1++ -- https://github.com/haskell/cabal/issues/3708+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.12+ other-modules:+ Data.OpenApi.CommonTestTypes+ Data.OpenApi.MigrationSpec+ Data.OpenApi.ParamSchemaSpec+ Data.OpenApi.Schema.CoreTypes31Spec+ Data.OpenApi.Schema.GeneratorSpec+ Data.OpenApi.Schema.RoundtripSpec+ Data.OpenApi.Schema.Validation31Spec+ Data.OpenApi.Schema.ValidationSpec+ Data.OpenApi.Schema31Spec+ Data.OpenApi.SchemaSpec+ Data.OpenApi.TopLevel31Spec+ Data.OpenApiSpec+ SpecCommon++ default-language: GHC2024++executable example+ hs-source-dirs: examples+ main-is: hackage.hs+ default-language: GHC2024+ build-depends:+ , aeson+ , base+ , bytestring+ , lens+ , openapi-hs+ , text++source-repository head+ type: git+ location: https://github.com/shinzui/openapi-hs.git
+ src/Data/HashMap/Strict/InsOrd/Compat.hs view
@@ -0,0 +1,453 @@+-- Ported from GetShopTV/swagger2 (pull request #262) to apply the same+-- insert-ordered-containers-0.3 compatibility fix to openapi3.+-- Credit for the design and implementation belongs to the swagger2 authors.+{-# LANGUAGE CPP #-}++-- |+-- Module: Data.HashMap.Strict.InsOrd.Compat+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Compatibility wrapper around @insert-ordered-containers@ to mitigate the+-- breaking changes introduced in @insert-ordered-containers-0.3.0@:+-- <https://github.com/erikd/insert-ordered-containers/pull/8>.+--+-- That change fixed 'Eq' and Aeson instances in the upstream package, but it is+-- a behavioral break for openapi-hs, which needs stable OpenAPI Schema+-- generation and JSON object-like encoding.+--+-- This module keeps the original encoding expectations:+--+-- * 'InsOrdHashMap' values are encoded as JSON objects (not arrays of key/value+-- tuples), so field names remain first-class object keys.+-- * Equality intentionally ignores insertion order (compares as plain hash+-- maps), which matches how many tests currently assert JSON equality.+--+-- Simple encoding examples:+--+-- >>> import Data.Aeson (encode, eitherDecode)+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8+-- >>> import qualified Data.HashMap.Strict as HM+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM+-- >>> let decodeIOHM s = either error id (eitherDecode (BSL8.pack s) :: Either String (IOHM.InsOrdHashMap String Int))+--+-- A regular hash map has no insertion order guarantee:+--+-- >>> encode (HM.fromList [("a", 1 :: Int), ("b", 2)])+-- "{\"a\":1,\"b\":2}"+-- >>> encode (HM.fromList [("b", 1 :: Int), ("a", 2)])+-- "{\"a\":2,\"b\":1}"+--+-- Our compat 'InsOrdHashMap' encodes to a JSON object as well, but preserves insertion order:+--+-- >>> encode (IOHM.fromList [("a", 1 :: Int), ("b", 2)])+-- "{\"a\":1,\"b\":2}"+-- >>> encode (IOHM.fromList [("b", 1 :: Int), ("a", 2)])+-- "{\"b\":1,\"a\":2}"+--+-- Round-tripping through decode/encode demonstrates the caveat: encoding+-- preserves insertion order, but decoded object key order is not guaranteed.+--+-- >>> encode (decodeIOHM "{\"a\":1,\"b\":2}")+-- "{\"a\":1,\"b\":2}"+-- >>> encode (decodeIOHM "{\"b\":1,\"a\":2}")+-- "{\"a\":2,\"b\":1}"+--+-- This object encoding is what openapi-hs wants for generated schema+-- definitions/properties because it keeps emitted schemas easy to consume and+-- stable in practice.+--+-- Important caveat: decoding cannot be fully stable with respect to insertion+-- order due to @aeson@ limitations. In particular, object parsing goes through+-- structures that do not preserve all ordering guarantees end-to-end. We accept+-- this trade-off for now because the primary requirement is deterministic+-- /encoding/ for generated OpenAPI Schema artifacts.+--+-- Many tests rely on @aesonQQ@-style JSON equality, where semantic object+-- equality matters more than insertion order. Comparing via plain hash maps+-- makes those tests robust under benign key-order variation. This is a weaker+-- notion of equality and hopefully will be revisited later.+module Data.HashMap.Strict.InsOrd.Compat+ ( InsOrdHashMap,++ -- * Construction+ empty,+ singleton,++ -- * Basic interface+ null,+ size,+ member,+ lookup,+ lookupDefault,+ insert,+ insertWith,+ delete,+ adjust,+ update,+ alter,++ -- * Combine+ union,+ unionWith,+ unionWithKey,+ unions,++ -- * Transformations+ map,+ mapKeys,+ traverseKeys,+ mapWithKey,+ traverseWithKey,++ -- ** Unordered+ unorderedTraverse,+ unorderedTraverseWithKey,++ -- * Difference and intersection+ difference,+ intersection,+ intersectionWith,+ intersectionWithKey,++ -- * Folds+ foldl',+ foldlWithKey',+ foldr,+ foldrWithKey,+ foldMapWithKey,++ -- ** Unordered+ unorderedFoldMap,+ unorderedFoldMapWithKey,++ -- * Filter+ filter,+ filterWithKey,+ mapMaybe,+ mapMaybeWithKey,++ -- * Conversions+ keys,+ elems,+ toList,+ toRevList,+ fromList,+ toHashMap,+ fromHashMap,++ -- * Lenses+ hashMap,+ unorderedTraversal,++ -- * Debugging+ valid,+ )+where++#if !MIN_VERSION_insert_ordered_containers(0,3,0)+import Prelude hiding (null, lookup, map, foldl', foldr, filter)+import Data.HashMap.Strict.InsOrd+#else+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap++import Prelude hiding (null, size, member, lookup, lookupDefault, map, foldl', filter)+import qualified Prelude++import qualified Data.Aeson as A+import qualified Data.Aeson.Encoding as E+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap++import qualified GHC.Exts as Exts++import Data.Data (Data)+import Data.Foldable (Foldable (foldMap))+import Data.Hashable (Hashable (..))++import qualified Control.Lens as Lens+import Control.Lens+ (At (..), Index, Iso, IxValue, Ixed (..), Traversal, _1, _2, iso, (<&>))++import qualified Optics.Core as Optics++newtype InsOrdHashMap k v = InsOrdHashMap { unCompatInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap k v }+ deriving stock (Show, Read, Data, Functor, Foldable, Traversable)+ deriving newtype (Semigroup, Monoid)++instance (Eq k, Eq v) => Eq (InsOrdHashMap k v) where+ a == b = toHashMap a == toHashMap b++instance (Eq k, Hashable k) => Exts.IsList (InsOrdHashMap k v) where+ type Item (InsOrdHashMap k v) = Exts.Item (InsOrdHashMap.InsOrdHashMap k v)+ fromList = InsOrdHashMap . InsOrdHashMap.fromList+ toList = InsOrdHashMap.toList . unCompatInsOrdHashMap++-------------------------------------------------------------------------------+-- Aeson+-------------------------------------------------------------------------------++instance (A.ToJSONKey k) => A.ToJSON1 (InsOrdHashMap k) where+ liftToJSON _ t _ = case A.toJSONKey :: A.ToJSONKeyFunction k of+ A.ToJSONKeyText f _ -> A.object . fmap (\(k, v) -> (f k, t v)) . toList+ A.ToJSONKeyValue f _ -> A.toJSON . fmap (\(k,v) -> A.toJSON (f k, t v)) . toList++ liftToEncoding o t _ = case A.toJSONKey :: A.ToJSONKeyFunction k of+ A.ToJSONKeyText _ f -> E.dict f t foldrWithKey+ A.ToJSONKeyValue _ f -> E.list (A.liftToEncoding2 (const False) f (E.list f) o t (E.list t)) . toList++instance (A.ToJSONKey k, A.ToJSON v) => A.ToJSON (InsOrdHashMap k v) where+ toJSON = A.toJSON1+ toEncoding = A.toEncoding1++-------------------------------------------------------------------------------++instance (Eq k, Hashable k, A.FromJSONKey k) => A.FromJSON1 (InsOrdHashMap k) where+ liftParseJSON o p pl v = fromList . HashMap.toList <$> A.liftParseJSON o p pl v++instance (Eq k, Hashable k, A.FromJSONKey k, A.FromJSON v) => A.FromJSON (InsOrdHashMap k v) where+ parseJSON = A.parseJSON1++-------------------------------------------------------------------------------+-- indexed-traversals+-------------------------------------------------------------------------------++instance (Eq k, Hashable k) => Optics.FunctorWithIndex k (InsOrdHashMap k) where+ imap = mapWithKey+instance (Eq k, Hashable k) => Optics.FoldableWithIndex k (InsOrdHashMap k) where+ ifoldMap = foldMapWithKey+ ifoldr = foldrWithKey+instance (Eq k, Hashable k) => Optics.TraversableWithIndex k (InsOrdHashMap k) where+ itraverse = traverseWithKey++-------------------------------------------------------------------------------+-- Lens+-------------------------------------------------------------------------------++type instance Index (InsOrdHashMap k v) = k+type instance IxValue (InsOrdHashMap k v) = v++instance (Eq k, Hashable k) => Ixed (InsOrdHashMap k v) where+ ix k f m = ixImpl k pure f m+ {-# INLINABLE ix #-}++ixImpl+ :: (Eq k, Hashable k, Functor f)+ => k+ -> (InsOrdHashMap k v -> f (InsOrdHashMap k v))+ -> (v -> f v)+ -> InsOrdHashMap k v+ -> f (InsOrdHashMap k v)+ixImpl k point f m = case lookup k m of+ Just v -> f v <&> \v' -> insert k v' m+ Nothing -> point m+{-# INLINE ixImpl #-}++instance (Eq k, Hashable k) => At (InsOrdHashMap k a) where+ at k f m = f mv <&> \r -> case r of+ Nothing -> maybe m (const (delete k m)) mv+ Just v' -> insert k v' m+ where mv = lookup k m+ {-# INLINABLE at #-}++-------------------------------------------------------------------------------+-- Optics+-------------------------------------------------------------------------------++type instance Optics.Index (InsOrdHashMap k v) = k+type instance Optics.IxValue (InsOrdHashMap k v) = v++instance (Eq k, Hashable k) => Optics.Ixed (InsOrdHashMap k v) where+ ix k = Optics.atraversalVL $ \point f m -> ixImpl k point f m+ {-# INLINE ix #-}++instance (Eq k, Hashable k) => Optics.At (InsOrdHashMap k a) where+ at k = Optics.lensVL $ \f m -> Lens.at k f m+ {-# INLINE at #-}++-------------------------------------------------------------------------------++-- | This is a slight lie, as roundtrip doesn't preserve ordering.+hashMap :: Iso (InsOrdHashMap k a) (InsOrdHashMap k b) (HashMap k a) (HashMap k b)+hashMap = iso toHashMap fromHashMap++unorderedTraversal :: Traversal (InsOrdHashMap k a) (InsOrdHashMap k b) a b+unorderedTraversal = hashMap . traverse++-------------------------------------------------------------------------------+-- * Construction+-------------------------------------------------------------------------------++empty :: InsOrdHashMap k v+empty = InsOrdHashMap InsOrdHashMap.empty++singleton :: Hashable k => k -> v -> InsOrdHashMap k v+singleton k v = InsOrdHashMap (InsOrdHashMap.singleton k v)++-------------------------------------------------------------------------------+-- * Basic interface+-------------------------------------------------------------------------------++null :: InsOrdHashMap k v -> Bool+null = InsOrdHashMap.null . unCompatInsOrdHashMap++size :: InsOrdHashMap k v -> Int+size = InsOrdHashMap.size . unCompatInsOrdHashMap++insert :: Hashable k => k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v+insert k v = InsOrdHashMap . InsOrdHashMap.insert k v . unCompatInsOrdHashMap++insertWith :: Hashable k => (v -> v -> v) -> k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v+insertWith f k v = InsOrdHashMap . InsOrdHashMap.insertWith f k v . unCompatInsOrdHashMap++delete :: Hashable k => k -> InsOrdHashMap k v -> InsOrdHashMap k v+delete k = InsOrdHashMap . InsOrdHashMap.delete k . unCompatInsOrdHashMap++adjust :: Hashable k => (v -> v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v+adjust f k = InsOrdHashMap . InsOrdHashMap.adjust f k . unCompatInsOrdHashMap++update :: Hashable k => (v -> Maybe v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v+update f k = InsOrdHashMap . InsOrdHashMap.update f k . unCompatInsOrdHashMap++alter :: Hashable k => (Maybe v -> Maybe v) -> k -> InsOrdHashMap k v -> InsOrdHashMap k v+alter f k = InsOrdHashMap . InsOrdHashMap.alter f k . unCompatInsOrdHashMap++member :: Hashable k => k -> InsOrdHashMap k v -> Bool+member k = InsOrdHashMap.member k . unCompatInsOrdHashMap++lookup :: Hashable k => k -> InsOrdHashMap k v -> Maybe v+lookup k = InsOrdHashMap.lookup k . unCompatInsOrdHashMap++lookupDefault :: Hashable k => v -> k -> InsOrdHashMap k v -> v+lookupDefault k def = InsOrdHashMap.lookupDefault k def . unCompatInsOrdHashMap++-- * Combine++union :: Hashable k => InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+union m1 m2 = InsOrdHashMap (InsOrdHashMap.union (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2))++unionWith :: Hashable k => (v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+unionWith f m1 m2 = InsOrdHashMap (InsOrdHashMap.unionWith f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2))++unionWithKey :: Hashable k => (k -> v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+unionWithKey f m1 m2 = InsOrdHashMap (InsOrdHashMap.unionWithKey f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2))++unions :: Hashable k => [InsOrdHashMap k v] -> InsOrdHashMap k v+unions = InsOrdHashMap . InsOrdHashMap.unions . Prelude.map unCompatInsOrdHashMap++-------------------------------------------------------------------------------+-- * Transformations+-------------------------------------------------------------------------------++map :: (v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v+map f = InsOrdHashMap . InsOrdHashMap.map f . unCompatInsOrdHashMap++mapKeys :: Hashable k => (k -> k) -> InsOrdHashMap k v -> InsOrdHashMap k v+mapKeys f = InsOrdHashMap . InsOrdHashMap.mapKeys f . unCompatInsOrdHashMap++traverseKeys :: (Applicative f, Hashable k) => (k -> f k) -> InsOrdHashMap k v -> f (InsOrdHashMap k v)+traverseKeys f = fmap InsOrdHashMap . InsOrdHashMap.traverseKeys f . unCompatInsOrdHashMap++mapWithKey :: (k -> v1 -> v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2+mapWithKey f = InsOrdHashMap . InsOrdHashMap.mapWithKey f . unCompatInsOrdHashMap++traverseWithKey :: (Applicative f, Hashable k) => (k -> v1 -> f v2) -> InsOrdHashMap k v1 -> f (InsOrdHashMap k v2)+traverseWithKey f = fmap InsOrdHashMap . InsOrdHashMap.traverseWithKey f . unCompatInsOrdHashMap++-- ** Unordered++unorderedTraverse :: (Applicative f, Hashable k) => (v -> f v) -> InsOrdHashMap k v -> f (InsOrdHashMap k v)+unorderedTraverse f = fmap InsOrdHashMap . InsOrdHashMap.unorderedTraverse f . unCompatInsOrdHashMap++unorderedTraverseWithKey :: (Applicative f, Hashable k) => (k -> v -> f v) -> InsOrdHashMap k v -> f (InsOrdHashMap k v)+unorderedTraverseWithKey f = fmap InsOrdHashMap . InsOrdHashMap.unorderedTraverseWithKey f . unCompatInsOrdHashMap++-------------------------------------------------------------------------------+-- * Difference and intersection+-------------------------------------------------------------------------------++difference :: Hashable k => InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+difference m1 m2 = InsOrdHashMap (InsOrdHashMap.difference (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2))++intersection :: Hashable k => InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+intersection m1 m2 = InsOrdHashMap (InsOrdHashMap.intersection (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2))++intersectionWith :: Hashable k => (v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+intersectionWith f m1 m2 = InsOrdHashMap (InsOrdHashMap.intersectionWith f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2))++intersectionWithKey :: Hashable k => (k -> v -> v -> v) -> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v+intersectionWithKey f m1 m2 = InsOrdHashMap (InsOrdHashMap.intersectionWithKey f (unCompatInsOrdHashMap m1) (unCompatInsOrdHashMap m2))++-------------------------------------------------------------------------------+-- * Folds+-------------------------------------------------------------------------------++foldl' :: (a -> v -> a) -> a -> InsOrdHashMap k v -> a+foldl' f z = InsOrdHashMap.foldl' f z . unCompatInsOrdHashMap++foldlWithKey' :: (a -> k -> v -> a) -> a -> InsOrdHashMap k v -> a+foldlWithKey' f z = InsOrdHashMap.foldlWithKey' f z . unCompatInsOrdHashMap++foldMapWithKey :: Monoid m => (k -> v -> m) -> InsOrdHashMap k v -> m+foldMapWithKey f = InsOrdHashMap.foldMapWithKey f . unCompatInsOrdHashMap++foldrWithKey :: (k -> v -> a -> a) -> a -> InsOrdHashMap k v -> a+foldrWithKey f z = InsOrdHashMap.foldrWithKey f z . unCompatInsOrdHashMap++-- ** Unordered++unorderedFoldMap :: Monoid m => (v -> m) -> InsOrdHashMap k v -> m+unorderedFoldMap f = InsOrdHashMap.unorderedFoldMap f . unCompatInsOrdHashMap++unorderedFoldMapWithKey :: Monoid m => (k -> v -> m) -> InsOrdHashMap k v -> m+unorderedFoldMapWithKey f = InsOrdHashMap.unorderedFoldMapWithKey f . unCompatInsOrdHashMap++-------------------------------------------------------------------------------+-- * Filter+-------------------------------------------------------------------------------++filter :: (v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v+filter f = InsOrdHashMap . InsOrdHashMap.filter f . unCompatInsOrdHashMap++filterWithKey :: (k -> v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v+filterWithKey f = InsOrdHashMap . InsOrdHashMap.filterWithKey f . unCompatInsOrdHashMap++mapMaybe :: (v -> Maybe v) -> InsOrdHashMap k v -> InsOrdHashMap k v+mapMaybe f = InsOrdHashMap . InsOrdHashMap.mapMaybe f . unCompatInsOrdHashMap++mapMaybeWithKey :: (k -> v -> Maybe v) -> InsOrdHashMap k v -> InsOrdHashMap k v+mapMaybeWithKey f = InsOrdHashMap . InsOrdHashMap.mapMaybeWithKey f . unCompatInsOrdHashMap++-------------------------------------------------------------------------------+-- * Conversions+-------------------------------------------------------------------------------++keys :: InsOrdHashMap k v -> [k]+keys = InsOrdHashMap.keys . unCompatInsOrdHashMap++elems :: InsOrdHashMap k v -> [v]+elems = InsOrdHashMap.elems . unCompatInsOrdHashMap++toRevList :: InsOrdHashMap k v -> [(k, v)]+toRevList = InsOrdHashMap.toRevList . unCompatInsOrdHashMap++fromList :: Hashable k => [(k, v)] -> InsOrdHashMap k v+fromList = InsOrdHashMap . InsOrdHashMap.fromList++toList :: InsOrdHashMap k v -> [(k, v)]+toList = InsOrdHashMap.toList . unCompatInsOrdHashMap++toHashMap :: InsOrdHashMap k v -> HashMap k v+toHashMap = InsOrdHashMap.toHashMap . unCompatInsOrdHashMap++fromHashMap :: HashMap k v -> InsOrdHashMap k v+fromHashMap = InsOrdHashMap . InsOrdHashMap.fromHashMap++-------------------------------------------------------------------------------+-- * Debugging+-------------------------------------------------------------------------------++valid :: (Eq k, Hashable k) => InsOrdHashMap k v -> Bool+valid = InsOrdHashMap.valid . unCompatInsOrdHashMap++#endif
+ src/Data/OpenApi.hs view
@@ -0,0 +1,440 @@+-- |+-- Module: Data.OpenApi+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- OpenAPI 3.1 data model.+--+-- This library supports OpenAPI Specification version 3.1.x (which adopts the+-- JSON Schema 2020-12 dialect), decoding and encoding 3.1 API specifications as+-- well as manipulating them. The specification is available at+-- <https://spec.openapis.org/oas/v3.1.0>.+--+-- To bring an existing OpenAPI 3.0 document forward, rewrite the parsed JSON with+-- the helpers in "Data.OpenApi.Migration" before decoding it into these 3.1 types+-- (see @MIGRATION_3.0_TO_3.1.md@).+module Data.OpenApi+ ( -- * How to use this library+ -- $howto++ -- ** @'Monoid'@ instances+ -- $monoids++ -- ** Lenses and prisms+ -- $lens++ -- ** Schema specification+ -- $schema++ -- ** Manipulation+ -- $manipulation++ -- ** Validation+ -- $validation++ -- * Re-exports+ module Data.OpenApi.Lens,+ module Data.OpenApi.Optics,+ module Data.OpenApi.Operation,+ module Data.OpenApi.ParamSchema,+ module Data.OpenApi.Schema,+ module Data.OpenApi.Schema.Validation,++ -- * OpenAPI specification+ OpenApi (..),+ OpenApiMajorVersion (..),+ detectVersion,+ Server (..),+ ServerVariable (..),+ Components (..),++ -- ** Info types+ Info (..),+ Contact (..),+ License (..),++ -- ** PathItem+ PathItem (..),++ -- ** Operations+ Operation (..),+ Tag (..),+ TagName,++ -- ** Types and formats+ OpenApiType (..),+ OpenApiTypeValue (..),+ singleType,+ Format,+ Definitions,+ Style (..),++ -- ** Parameters+ Param (..),+ ParamLocation (..),+ ParamName,+ Header (..),+ HeaderName,+ Example (..),+ RequestBody (..),+ MediaTypeObject (..),+ Encoding (..),++ -- ** Schemas+ Schema (..),+ NamedSchema (..),+ OpenApiItems (..),+ Xml (..),+ Pattern,+ AdditionalProperties (..),+ Discriminator (..),++ -- ** Responses+ Responses (..),+ Response (..),+ HttpStatusCode,+ Link (..),+ Callback (..),++ -- ** Security+ SecurityScheme (..),+ SecuritySchemeType (..),+ HttpSchemeType (..),+ SecurityDefinitions (..),+ SecurityRequirement (..),++ -- *** API key+ ApiKeyParams (..),+ ApiKeyLocation (..),++ -- *** OAuth2+ OAuth2Flows (..),+ OAuth2Flow (..),+ OAuth2ImplicitFlow (..),+ OAuth2PasswordFlow (..),+ OAuth2ClientCredentialsFlow (..),+ OAuth2AuthorizationCodeFlow (..),+ AuthorizationURL,+ TokenURL,++ -- ** External documentation+ ExternalDocs (..),++ -- ** References+ Reference (..),+ Referenced (..),++ -- ** Miscellaneous+ MimeList (..),+ URL (..),+ )+where++import Data.OpenApi.Internal+import Data.OpenApi.Lens+import Data.OpenApi.Operation+import Data.OpenApi.Optics ()+import Data.OpenApi.ParamSchema+import Data.OpenApi.Schema+import Data.OpenApi.Schema.Validation++-- $setup+-- >>> import Control.Lens+-- >>> import Data.Aeson+-- >>> import Data.Monoid+-- >>> import Data.Proxy+-- >>> import GHC.Generics+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL+-- >>> import Data.OpenApi.Internal+-- >>> import Data.OpenApi.Internal.Schema+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM+-- >>> import Data.OpenApi.Internal.Utils+-- >>> import Data.OpenApi.Lens+-- >>> :set -XDeriveGeneric+-- >>> :set -XOverloadedStrings+-- >>> :set -fno-warn-missing-methods++-- $howto+--+-- This section explains how to use this library to work with the OpenAPI specification.++-- $monoids+--+-- Virtually all types representing the OpenAPI specification have @'Monoid'@ instances.+-- The @'Monoid'@ type class provides two methods — @'mempty'@ and @'mappend'@.+--+-- In this library you can use @'mempty'@ for a default/empty value. For instance:+--+-- >>> BSL.putStrLn $ encodePretty (mempty :: OpenApi)+-- {+-- "components": {},+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.1.0",+-- "paths": {}+-- }+--+-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty.+-- That is because these properties are actually required ones.+--+-- You /should/ always override the default (empty) value for these properties,+-- although it is not strictly necessary:+--+-- >>> BSL.putStrLn $ encodePretty mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }+-- {+-- "title": "Todo API",+-- "version": "1.0"+-- }+--+-- You can merge two values using @'mappend'@ or its infix version @('<>')@:+--+-- >>> BSL.putStrLn $ encodePretty $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }+-- {+-- "title": "Todo API",+-- "version": "1.0"+-- }++--+-- This can be useful for combining specifications of endpoints into a whole API specification:+--+-- @+-- \-\- /account subAPI specification+-- accountAPI :: OpenApi+--+-- \-\- /task subAPI specification+-- taskAPI :: OpenApi+--+-- \-\- while API specification is just a combination+-- \-\- of subAPIs' specifications+-- api :: OpenApi+-- api = accountAPI <> taskAPI+-- @++-- $lens+--+-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.OpenApi.Optics".+--+-- Since @'OpenApi'@ has a fairly complex structure, lenses and prisms are used+-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses+-- make it fairly simple to construct/modify any part of the specification:+--+-- >>> :{+-- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)+-- & components . schemas .~ IOHM.fromList [ ("User", mempty & type_ ?~ OpenApiTypeSingle OpenApiString) ]+-- & paths .~+-- IOHM.fromList [ ("/user", mempty & get ?~ (mempty+-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User")))+-- & at 404 ?~ "User info not found")) ]+-- :}+-- {+-- "components": {+-- "schemas": {+-- "User": {+-- "type": "string"+-- }+-- }+-- },+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.1.0",+-- "paths": {+-- "/user": {+-- "get": {+-- "responses": {+-- "200": {+-- "content": {+-- "application/json": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- },+-- "description": "OK"+-- },+-- "404": {+-- "description": "User info not found"+-- }+-- }+-- }+-- }+-- }+-- }+--+-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@+-- which produces @application/json@ output. It should respond with code @200@ and body specified+-- by schema @User@ which is defined in the @'components'@ property of the OpenAPI specification.+-- Alternatively it may respond with code @404@ meaning that user info is not found.+--+-- For convenience, @openapi-hs@ uses /classy field lenses/. It means that+-- field accessor names can be overloaded for different types. One such+-- common field is @'description'@. Many components of an OpenAPI specification+-- can have descriptions, and you can use the same name for them:+--+-- >>> BSL.putStrLn $ encodePretty $ (mempty :: Response) & description .~ "No content"+-- {+-- "description": "No content"+-- }+-- >>> :{+-- BSL.putStrLn $ encodePretty $ (mempty :: Schema)+-- & type_ ?~ OpenApiTypeSingle OpenApiBoolean+-- & description ?~ "To be or not to be"+-- :}+-- {+-- "description": "To be or not to be",+-- "type": "boolean"+-- }+--+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@+-- have direct access to it via @at code@. Example:+--+-- >>> :{+-- BSL.putStrLn $ encodePretty $ (mempty :: Operation)+-- & at 404 ?~ "Not found"+-- :}+-- {+-- "responses": {+-- "404": {+-- "description": "Not found"+-- }+-- }+-- }+--+-- You might've noticed that @'type_'@ has an extra underscore in its name+-- compared to, say, @'description'@ field accessor.+-- This is because @type@ is a keyword in Haskell.+-- A few other field accessors are modified in this way:+--+-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);+-- - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);+-- - @'enum_'@ (as conflicting with @Control.Lens@).++-- $schema+--+-- @'Schema'@ is the core type for data model specification: an OpenAPI 3.1+-- Schema Object, which is a JSON Schema 2020-12 document. Its @type@ and @items@+-- keywords are described by @'OpenApiType'@ and @'OpenApiItems'@.+--+-- The same @'Schema'@ type covers both primitive endpoint parameters and+-- request/response bodies; unlike OpenAPI 3.0 and earlier, 3.1 has no separate+-- parameter-schema type.+--+-- In most cases you will have a Haskell data type for which you would like to+-- define a corresponding schema. To facilitate this use case+-- @openapi-hs@ provides two classes for schema encoding.+-- Both these classes provide means to encode /types/ as OpenAPI /schemas/.+--+-- @'ToParamSchema'@ is intended to be used for primitive API endpoint parameters,+-- such as query parameters, headers and URL path pieces.+-- Its corresponding value-encoding class is @ToHttpApiData@ (from @http-api-data@ package).+--+-- @'ToSchema'@ is used for request and response bodies and mostly differ from+-- primitive parameters by allowing objects/mappings in addition to primitive types and arrays.+-- Its corresponding value-encoding class is @ToJSON@ (from @aeson@ package).+--+-- While lenses and prisms make it easy to define schemas, it might be that you don't need to:+-- @'ToSchema'@ and @'ToParamSchema'@ classes both have default @Generic@-based implementations!+--+-- @'ToSchema'@ default implementation is also aligned with @ToJSON@ default implementation with+-- the only difference being for sum encoding. @ToJSON@ defaults sum encoding to @defaultTaggedObject@,+-- while @'ToSchema'@ defaults to something which corresponds to @ObjectWithSingleField@. This is due to+-- @defaultTaggedObject@ behavior being hard to specify in OpenAPI.+--+-- Here's an example showing @ToJSON@–@'ToSchema'@ correspondance:+--+-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic+-- >>> instance ToJSON Person+-- >>> instance ToSchema Person+-- >>> BSL.putStrLn $ encodePretty (Person "David" 28)+-- {+-- "age": 28,+-- "name": "David"+-- }+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Person)+-- {+-- "properties": {+-- "age": {+-- "type": "integer"+-- },+-- "name": {+-- "type": "string"+-- }+-- },+-- "required": [+-- "name",+-- "age"+-- ],+-- "type": "object"+-- }+--+-- This package implements the OpenAPI 3.1 spec, which supports @oneOf@ in schemas, allowing any sum types+-- to be faithfully represented. All sum encodings supported by @aeson@ are supported here as well, with+-- an exception of 'Data.Aeson.TwoElemArray', since OpenAPI spec does not support heterogeneous arrays.+--+-- An example with 'Data.Aeson.TaggedObject' encoding:+--+-- >>> data Error = ErrorNoUser { userId :: Int } | ErrorAccessDenied { requiredPermission :: String } deriving Generic+-- >>> instance ToJSON Error+-- >>> instance ToSchema Error+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Error)+-- {+-- "oneOf": [+-- {+-- "properties": {+-- "tag": {+-- "enum": [+-- "ErrorNoUser"+-- ],+-- "type": "string"+-- },+-- "userId": {+-- "maximum": 9223372036854775807,+-- "minimum": -9223372036854775808,+-- "type": "integer"+-- }+-- },+-- "required": [+-- "userId",+-- "tag"+-- ],+-- "title": "ErrorNoUser",+-- "type": "object"+-- },+-- {+-- "properties": {+-- "requiredPermission": {+-- "type": "string"+-- },+-- "tag": {+-- "enum": [+-- "ErrorAccessDenied"+-- ],+-- "type": "string"+-- }+-- },+-- "required": [+-- "requiredPermission",+-- "tag"+-- ],+-- "title": "ErrorAccessDenied",+-- "type": "object"+-- }+-- ]+-- }++-- $manipulation+-- Sometimes you have to work with an imported or generated @'OpenApi'@.+-- For instance, <https://hackage.haskell.org/package/servant-openapi3 servant-openapi3> generates a basic @'OpenApi'@+-- for a type-level servant API.+--+-- Lenses and prisms can be used to manipulate such specification to add additional information, tags, extra responses, etc.+-- To facilitate common needs, @"Data.OpenApi.Operation"@ module provides useful helpers.++-- $validation+-- While @'ToParamSchema'@ and @'ToSchema'@ provide means to easily obtain schemas for Haskell types,+-- there is no static mechanism to ensure those instances correspond to the @ToHttpApiData@ or @ToJSON@ instances.+--+-- @"Data.OpenApi.Schema.Validation"@ addresses @ToJSON@/@'ToSchema'@ validation.
+ src/Data/OpenApi/Aeson/Compat.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}++-- |+-- Module: Data.OpenApi.Aeson.Compat+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Internal compatibility shims over aeson's @Key@/@KeyMap@ API across versions.+-- No API stability guarantees.+module Data.OpenApi.Aeson.Compat where++#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson (Key)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as HM+#endif+import Data.Bifunctor (first)+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.Text qualified as T++#if MIN_VERSION_aeson(2,0,0)+deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v+deleteKey = KeyMap.delete++objectToList :: KeyMap.KeyMap v -> [(Key, v)]+objectToList = KeyMap.toList++objectKeys :: KeyMap.KeyMap v -> [T.Text]+objectKeys = map Key.toText . KeyMap.keys++stringToKey :: String -> Key+stringToKey = Key.fromString++keyToString :: Key -> String+keyToString = Key.toString++keyToText :: Key -> T.Text+keyToText = Key.toText++toInsOrdHashMap :: KeyMap.KeyMap v -> InsOrdHashMap.InsOrdHashMap T.Text v+toInsOrdHashMap = InsOrdHashMap.fromList . fmap (first Key.toText) . KeyMap.toList++fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> KeyMap.KeyMap v+fromInsOrdHashMap = KeyMap.fromList . fmap (first Key.fromText) . InsOrdHashMap.toList++lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v+lookupKey = KeyMap.lookup . Key.fromText++insertKey :: T.Text -> v -> KeyMap.KeyMap v -> KeyMap.KeyMap v+insertKey = KeyMap.insert . Key.fromText++hasKey :: T.Text -> KeyMap.KeyMap a -> Bool+hasKey = KeyMap.member . Key.fromText+#else+deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v+deleteKey = HM.delete++objectToList :: HM.HashMap T.Text v -> [(T.Text, v)]+objectToList = HM.toList++objectKeys :: HM.HashMap T.Text v -> [T.Text]+objectKeys = HM.keys++stringToKey :: String -> T.Text+stringToKey = T.pack++keyToString :: T.Text -> String+keyToString = T.unpack++keyToText :: T.Text -> T.Text+keyToText = id++toInsOrdHashMap :: HM.HashMap T.Text v -> InsOrdHashMap.InsOrdHashMap T.Text v+toInsOrdHashMap = InsOrdHashMap.fromHashMap++fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> HM.HashMap T.Text v+fromInsOrdHashMap = InsOrdHashMap.toHashMap++lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v+lookupKey = HM.lookup++insertKey :: T.Text -> v -> HM.HashMap T.Text v -> HM.HashMap T.Text v+insertKey = HM.insert++hasKey :: T.Text -> HM.HashMap T.Text a -> Bool+hasKey = HM.member+#endif
+ src/Data/OpenApi/Declare.hs view
@@ -0,0 +1,188 @@+-- |+-- Module: Data.OpenApi.Declare+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Declare monad transformer and associated functions.+module Data.OpenApi.Declare where++import Control.Monad+import Control.Monad.Cont (ContT)+import Control.Monad.Reader (ReaderT)+import Control.Monad.Trans+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Trans.RWS.Lazy as Lazy+import Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict+import Data.Functor.Identity+import Prelude.Compat+import Prelude ()++-- | A declare monad transformer parametrized by:+--+-- * @d@ — the output to accumulate (declarations);+--+-- * @m@ — the inner monad.+--+-- This monad transformer is similar to both state and writer monad transformers.+-- Thus it can be seen as+--+-- * a restricted append-only version of a state monad transformer or+--+-- * a writer monad transformer with the extra ability to read all previous output.+newtype DeclareT d m a = DeclareT {runDeclareT :: d -> m (d, a)}+ deriving stock (Functor)++instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where+ pure x = DeclareT (\_ -> pure (mempty, x))+ DeclareT df <*> DeclareT dx = DeclareT $ \d -> do+ ~(d', f) <- df d+ ~(d'', x) <- dx (mappend d d')+ return (mappend d' d'', f x)++instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where+ DeclareT dx >>= f = DeclareT $ \d -> do+ ~(d', x) <- dx d+ ~(d'', y) <- runDeclareT (f x) (mappend d d')+ return (mappend d' d'', y)++instance (Monoid d) => MonadTrans (DeclareT d) where+ lift m = DeclareT (\_ -> (,) mempty <$> m)++-- |+-- Definitions of @declare@ and @look@ must satisfy the following laws:+--+-- [/monoid homomorphism (mempty)/]+-- @'declare' mempty == return ()@+--+-- [/monoid homomorphism (mappend)/]+-- @'declare' x >> 'declare' y == 'declare' (x <> y)@+-- for every @x@, @y@+--+-- [/@declare@-@look@/]+-- @'declare' x >> 'look' == 'fmap' (<> x) 'look' <* 'declare' x@+-- for every @x@+--+-- [/@look@ as left identity/]+-- @'look' >> m == m@+-- for every @m@+class (Applicative m, Monad m) => MonadDeclare d m | m -> d where+ -- | @'declare' x@ is an action that produces the output @x@.+ declare :: d -> m ()++ -- | @'look'@ is an action that returns all the output so far.+ look :: m d++instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where+ declare d = DeclareT (\_ -> return (d, ()))+ look = DeclareT (\d -> return (mempty, d))++-- | Lift a computation from the simple Declare monad.+liftDeclare :: (MonadDeclare d m) => Declare d a -> m a+liftDeclare da = do+ (d', a) <- looks (runDeclare da)+ declare d'+ pure a++-- | Retrieve a function of all the output so far.+looks :: (MonadDeclare d m) => (d -> a) -> m a+looks f = f <$> look++-- | Evaluate @'DeclareT' d m a@ computation,+-- ignoring new output @d@.+evalDeclareT :: (Monad m) => DeclareT d m a -> d -> m a+evalDeclareT (DeclareT f) d = snd <$> f d++-- | Execute @'DeclareT' d m a@ computation,+-- ignoring result and only producing new output @d@.+execDeclareT :: (Monad m) => DeclareT d m a -> d -> m d+execDeclareT (DeclareT f) d = fst <$> f d++-- | Evaluate @'DeclareT' d m a@ computation,+-- starting with empty output history.+undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a+undeclareT = flip evalDeclareT mempty++-- | A declare monad parametrized by @d@ — the output to accumulate (declarations).+--+-- This monad is similar to both state and writer monads.+-- Thus it can be seen as+--+-- * a restricted append-only version of a state monad or+--+-- * a writer monad with the extra ability to read all previous output.+type Declare d = DeclareT d Identity++-- | Run @'Declare' d a@ computation with output history @d@,+-- producing result @a@ and new output @d@.+runDeclare :: Declare d a -> d -> (d, a)+runDeclare m = runIdentity . runDeclareT m++-- | Evaluate @'Declare' d a@ computation, ignoring output @d@.+evalDeclare :: Declare d a -> d -> a+evalDeclare m = runIdentity . evalDeclareT m++-- | Execute @'Declare' d a@ computation, ignoring result and only+-- producing output @d@.+execDeclare :: Declare d a -> d -> d+execDeclare m = runIdentity . execDeclareT m++-- | Evaluate @'DeclareT' d m a@ computation,+-- starting with empty output history.+undeclare :: (Monoid d) => Declare d a -> a+undeclare = runIdentity . undeclareT++-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition.++instance (MonadDeclare d m) => MonadDeclare d (ContT r m) where+ declare = lift . declare+ look = lift look++instance (MonadDeclare d m) => MonadDeclare d (ExceptT e m) where+ declare = lift . declare+ look = lift look++instance (MonadDeclare d m) => MonadDeclare d (IdentityT m) where+ declare = lift . declare+ look = lift look++instance (MonadDeclare d m) => MonadDeclare d (MaybeT m) where+ declare = lift . declare+ look = lift look++instance (MonadDeclare d m) => MonadDeclare d (ReaderT r m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.RWST r w s m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.RWST r w s m) where+ declare = lift . declare+ look = lift look++instance (MonadDeclare d m) => MonadDeclare d (Lazy.StateT s m) where+ declare = lift . declare+ look = lift look++instance (MonadDeclare d m) => MonadDeclare d (Strict.StateT s m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.WriterT w m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.WriterT w m) where+ declare = lift . declare+ look = lift look
+ src/Data/OpenApi/Internal.hs view
@@ -0,0 +1,1855 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- Module: Data.OpenApi.Internal+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Internal module defining the OpenAPI 3.1 data model and its JSON instances.+-- No API stability guarantees — import "Data.OpenApi" instead.+module Data.OpenApi.Internal where++import Control.Applicative+import Control.Lens ((&), (.~), (?~))+import Data.Aeson hiding (Encoding)+import Prelude.Compat+import Prelude ()+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#endif+import Control.Monad (unless)+import Data.Aeson.Types qualified as JSON+import Data.Data+ ( Constr,+ Data (..),+ DataType,+ Fixity (..),+ Typeable,+ constrIndex,+ mkConstr,+ mkDataType,+ )+import Data.HashMap.Strict qualified as HashMap+import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap)+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.HashSet.InsOrd (InsOrdHashSet)+import Data.Hashable (Hashable (..))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Monoid (Monoid (..))+import Data.OpenApi.Aeson.Compat (deleteKey)+import Data.OpenApi.Internal.AesonUtils+ ( AesonDefaultValue (..),+ HasOpenApiAesonOptions (..),+ applyKeyRenamesParseJSON,+ applyKeyRenamesToJSON,+ mkOpenApiAesonOptions,+ saoAdditionalPairs,+ saoSubObject,+ sopOpenApiGenericParseJSON,+ sopOpenApiGenericToEncoding,+ sopOpenApiGenericToJSON,+ sopOpenApiGenericToJSONWithOpts,+ )+import Data.OpenApi.Internal.Utils+import Data.Scientific (Scientific)+import Data.Semigroup.Compat (Semigroup (..))+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding (encodeUtf8)+import Data.Version+import GHC.Generics (Generic)+import Generics.SOP.TH (deriveGeneric)+import Network.HTTP.Media+ ( MediaType,+ mainType,+ parameters,+ parseAccept,+ subType,+ (//),+ (/:),+ )+import Text.ParserCombinators.ReadP (readP_to_S)+import Text.Read (readMaybe)++-- $setup+-- >>> :seti -XDataKinds+-- >>> import Data.Aeson+-- >>> import Data.ByteString.Lazy.Char8 as BSL+-- >>> import Data.OpenApi.Internal.Utils++-- | A list of definitions that can be used in references.+type Definitions = InsOrdHashMap Text++-- | This is the root document object for the API specification.+data OpenApi = OpenApi+ { -- | Provides metadata about the API.+ -- The metadata can be used by the clients if needed.+ _openApiInfo :: Info,+ -- | An array of Server Objects, which provide connectivity information+ -- to a target server. If the servers property is not provided, or is an empty array,+ -- the default value would be a 'Server' object with a url value of @/@.+ _openApiServers :: [Server],+ -- | The available paths and operations for the API.+ _openApiPaths :: InsOrdHashMap FilePath PathItem,+ -- | The incoming webhooks that MAY be received as part of this API,+ -- and that the API consumer MAY choose to implement. (OpenAPI 3.1)+ -- Each value is a Path Item Object or a Reference Object.+ _openApiWebhooks :: InsOrdHashMap Text (Referenced PathItem),+ -- | An element to hold various schemas for the specification.+ _openApiComponents :: Components,+ -- | A declaration of which security mechanisms can be used across the API.+ -- The list of values includes alternative security requirement objects that can be used.+ -- Only one of the security requirement objects need to be satisfied to authorize a request.+ -- Individual operations can override this definition.+ -- To make security optional, an empty security requirement can be included in the array.+ _openApiSecurity :: [SecurityRequirement],+ -- | A list of tags used by the specification with additional metadata.+ -- The order of the tags can be used to reflect on their order by the parsing tools.+ -- Not all tags that are used by the 'Operation' Object must be declared.+ -- The tags that are not declared MAY be organized randomly or based on the tools' logic.+ -- Each tag name in the list MUST be unique.+ _openApiTags :: InsOrdHashSet Tag,+ -- | Additional external documentation.+ _openApiExternalDocs :: Maybe ExternalDocs,+ -- | The spec of OpenApi this spec adheres to. Must be between 'lowerOpenApiSpecVersion' and 'upperOpenApiSpecVersion'+ _openApiOpenapi :: OpenApiSpecVersion+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | This is the lower version of the OpenApi Spec this library can parse or produce+lowerOpenApiSpecVersion :: Version+lowerOpenApiSpecVersion = makeVersion [3, 1, 0]++-- | This is the upper version of the OpenApi Spec this library can parse or produce+upperOpenApiSpecVersion :: Version+upperOpenApiSpecVersion = makeVersion [3, 1, 1]++-- | Coarse major version of an OpenAPI document, used to route a parsed document+-- to the appropriate decoder (e.g. EP-7's @Value@-layer 3.0→3.1 migration helpers).+-- This is NOT stored on any type and does not keep two representations alive; it+-- only tells a reader which migration path to take.+data OpenApiMajorVersion = OpenApi30 | OpenApi31+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Classify an 'OpenApiSpecVersion' as 3.0.x or 3.1.x (anything @>= 3.1@ is treated+-- as 3.1).+detectVersion :: OpenApiSpecVersion -> OpenApiMajorVersion+detectVersion v+ | versionBranch (getVersion v) >= [3, 1] = OpenApi31+ | otherwise = OpenApi30++-- | The object provides metadata about the API.+-- The metadata MAY be used by the clients if needed,+-- and MAY be presented in editing or documentation generation tools for convenience.+data Info = Info+ { -- | The title of the API.+ _infoTitle :: Text,+ -- | A short summary of the API. (OpenAPI 3.1)+ _infoSummary :: Maybe Text,+ -- | A short description of the API.+ -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.+ _infoDescription :: Maybe Text,+ -- | A URL to the Terms of Service for the API. MUST be in the format of a URL.+ _infoTermsOfService :: Maybe Text,+ -- | The contact information for the exposed API.+ _infoContact :: Maybe Contact,+ -- | The license information for the exposed API.+ _infoLicense :: Maybe License,+ -- | The version of the OpenAPI document (which is distinct from the+ -- OpenAPI Specification version or the API implementation version).+ _infoVersion :: Text+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Contact information for the exposed API.+data Contact = Contact+ { -- | The identifying name of the contact person/organization.+ _contactName :: Maybe Text,+ -- | The URL pointing to the contact information.+ _contactUrl :: Maybe URL,+ -- | The email address of the contact person/organization.+ _contactEmail :: Maybe Text+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | License information for the exposed API.+data License = License+ { -- | The license name used for the API.+ _licenseName :: Text,+ -- | An [SPDX](https://spdx.org/licenses/) license expression for the API,+ -- e.g. @"MIT"@ or @"Apache-2.0"@. (OpenAPI 3.1)+ --+ -- The OpenAPI 3.1 specification states that @identifier@ and '_licenseUrl'+ -- are mutually exclusive: a license is identified by /either/ an SPDX+ -- identifier /or/ a URL, never both. This library does not enforce that+ -- constraint at decode time (see EP-5 Decision Log); it round-trips+ -- whatever is present.+ _licenseIdentifier :: Maybe Text,+ -- | A URL to the license used for the API.+ _licenseUrl :: Maybe URL+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++instance IsString License where+ fromString s = License (fromString s) Nothing Nothing++-- | An object representing a Server.+data Server = Server+ { -- | A URL to the target host. This URL supports Server Variables and MAY be relative,+ -- to indicate that the host location is relative to the location where+ -- the OpenAPI document is being served. Variable substitutions will be made when+ -- a variable is named in @{brackets}@.+ _serverUrl :: Text,+ -- | An optional string describing the host designated by the URL.+ -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.+ _serverDescription :: Maybe Text,+ -- | A map between a variable name and its value.+ -- The value is used for substitution in the server's URL template.+ _serverVariables :: InsOrdHashMap Text ServerVariable+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | A variable substituted into a 'Server' URL template, as described by the+-- OpenAPI Server Variable Object.+data ServerVariable = ServerVariable+ { -- | An enumeration of string values to be used if the substitution options+ -- are from a limited set. The array SHOULD NOT be empty.+ _serverVariableEnum :: Maybe (InsOrdHashSet Text), -- TODO NonEmpty++ -- | The default value to use for substitution, which SHALL be sent if an alternate value+ -- is not supplied. Note this behavior is different than the 'Schema\ Object's treatment+ -- of default values, because in those cases parameter values are optional.+ -- If the '_serverVariableEnum' is defined, the value SHOULD exist in the enum's values.+ _serverVariableDefault :: Text,+ -- | An optional description for the server variable.+ -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.+ _serverVariableDescription :: Maybe Text+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++instance IsString Server where+ fromString s = Server (fromString s) Nothing mempty++-- | Holds a set of reusable objects for different aspects of the OAS.+-- All objects defined within the components object will have no effect on the API+-- unless they are explicitly referenced from properties outside the components object.+data Components = Components+ { _componentsSchemas :: Definitions Schema,+ _componentsResponses :: Definitions Response,+ _componentsParameters :: Definitions Param,+ _componentsExamples :: Definitions Example,+ _componentsRequestBodies :: Definitions RequestBody,+ _componentsHeaders :: Definitions Header,+ _componentsSecuritySchemes :: SecurityDefinitions,+ _componentsLinks :: Definitions Link,+ _componentsCallbacks :: Definitions Callback+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Describes the operations available on a single path.+-- A @'PathItem'@ may be empty, due to ACL constraints.+-- The path itself is still exposed to the documentation viewer+-- but they will not know which operations and parameters are available.+data PathItem = PathItem+ { -- | A reference (@$ref@) to an externally-defined Path Item Object,+ -- whose definition replaces this one, with @summary@ and @description@+ -- providing optional overrides. (OpenAPI 3.1)+ _pathItemRef :: Maybe Text,+ -- | An optional, string summary, intended to apply to all operations in this path.+ _pathItemSummary :: Maybe Text,+ -- | An optional, string description, intended to apply to all operations in this path.+ -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.+ _pathItemDescription :: Maybe Text,+ -- | A definition of a GET operation on this path.+ _pathItemGet :: Maybe Operation,+ -- | A definition of a PUT operation on this path.+ _pathItemPut :: Maybe Operation,+ -- | A definition of a POST operation on this path.+ _pathItemPost :: Maybe Operation,+ -- | A definition of a DELETE operation on this path.+ _pathItemDelete :: Maybe Operation,+ -- | A definition of a OPTIONS operation on this path.+ _pathItemOptions :: Maybe Operation,+ -- | A definition of a HEAD operation on this path.+ _pathItemHead :: Maybe Operation,+ -- | A definition of a PATCH operation on this path.+ _pathItemPatch :: Maybe Operation,+ -- | A definition of a TRACE operation on this path.+ _pathItemTrace :: Maybe Operation,+ -- | An alternative server array to service all operations in this path.+ _pathItemServers :: [Server],+ -- | A list of parameters that are applicable for all the operations described under this path.+ -- These parameters can be overridden at the operation level, but cannot be removed there.+ -- The list MUST NOT include duplicated parameters.+ -- A unique parameter is defined by a combination of a name and location.+ _pathItemParameters :: [Referenced Param]+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Describes a single API operation on a path.+data Operation = Operation+ { -- | A list of tags for API documentation control.+ -- Tags can be used for logical grouping of operations by resources or any other qualifier.+ _operationTags :: InsOrdHashSet TagName,+ -- | A short summary of what the operation does.+ -- For maximum readability in rendering tools, this field SHOULD be less than 120 characters.+ _operationSummary :: Maybe Text,+ -- | A verbose explanation of the operation behavior.+ -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation.+ _operationDescription :: Maybe Text,+ -- | Additional external documentation for this operation.+ _operationExternalDocs :: Maybe ExternalDocs,+ -- | Unique string used to identify the operation.+ -- The id MUST be unique among all operations described in the API.+ -- The operationId value is **case-sensitive**.+ -- Tools and libraries MAY use the operationId to uniquely identify an operation, therefore,+ -- it is RECOMMENDED to follow common programming naming conventions.+ _operationOperationId :: Maybe Text,+ -- | A list of parameters that are applicable for this operation.+ -- If a parameter is already defined at the @'PathItem'@,+ -- the new definition will override it, but can never remove it.+ -- The list MUST NOT include duplicated parameters.+ -- A unique parameter is defined by a combination of a name and location.+ _operationParameters :: [Referenced Param],+ -- | The request body applicable for this operation.+ -- The requestBody is only supported in HTTP methods where the HTTP 1.1+ -- specification [RFC7231](https://tools.ietf.org/html/rfc7231#section-4.3.1)+ -- has explicitly defined semantics for request bodies.+ -- In other cases where the HTTP spec is vague, requestBody SHALL be ignored by consumers.+ _operationRequestBody :: Maybe (Referenced RequestBody),+ -- | The list of possible responses as they are returned from executing this operation.+ _operationResponses :: Responses,+ -- | A map of possible out-of band callbacks related to the parent operation.+ -- The key is a unique identifier for the 'Callback' Object.+ -- Each value in the map is a 'Callback' Object that describes a request+ -- that may be initiated by the API provider and the expected responses.+ _operationCallbacks :: InsOrdHashMap Text (Referenced Callback),+ -- | Declares this operation to be deprecated.+ -- Usage of the declared operation should be refrained.+ -- Default value is @False@.+ _operationDeprecated :: Maybe Bool,+ -- | A declaration of which security schemes are applied for this operation.+ -- The list of values describes alternative security schemes that can be used+ -- (that is, there is a logical OR between the security requirements).+ -- This definition overrides any declared top-level security.+ -- To remove a top-level security declaration, @Just []@ can be used.+ _operationSecurity :: [SecurityRequirement],+ -- | An alternative server array to service this operation.+ -- If an alternative server object is specified at the 'PathItem' Object or Root level,+ -- it will be overridden by this value.+ _operationServers :: [Server]+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- This instance should be in @http-media@.+instance Data MediaType where+ gunfold k z c = case constrIndex c of+ 1 -> k (k (k (z (\main sub params -> foldl (/:) (main // sub) (Map.toList params)))))+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MediaType."++ toConstr _ = mediaTypeConstr++ dataTypeOf _ = mediaTypeData++mediaTypeConstr :: Constr+mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix++mediaTypeData :: DataType+mediaTypeData = mkDataType "MediaType" [mediaTypeConstr]++instance Hashable MediaType where+ hashWithSalt salt mt = salt `hashWithSalt` show mt++-- | Describes a single request body.+data RequestBody = RequestBody+ { -- | A brief description of the request body. This could contain examples of use.+ -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.+ _requestBodyDescription :: Maybe Text,+ -- | The content of the request body.+ -- The key is a media type or media type range and the value describes it.+ -- For requests that match multiple keys, only the most specific key is applicable.+ -- e.g. @text/plain@ overrides @text/\*@+ _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject,+ -- | Determines if the request body is required in the request.+ -- Defaults to 'False'.+ _requestBodyRequired :: Maybe Bool+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Each Media Type Object provides schema and examples for the media type identified by its key.+data MediaTypeObject = MediaTypeObject+ { _mediaTypeObjectSchema :: Maybe (Referenced Schema),+ -- | Example of the media type.+ -- The example object SHOULD be in the correct format as specified by the media type.+ _mediaTypeObjectExample :: Maybe Value,+ -- | Examples of the media type.+ -- Each example object SHOULD match the media type and specified schema if present.+ _mediaTypeObjectExamples :: InsOrdHashMap Text (Referenced Example),+ -- | A map between a property name and its encoding information.+ -- The key, being the property name, MUST exist in the schema as a property.+ -- The encoding object SHALL only apply to 'RequestBody' objects when the media type+ -- is @multipart@ or @application/x-www-form-urlencoded@.+ _mediaTypeObjectEncoding :: InsOrdHashMap Text Encoding+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | In order to support common ways of serializing simple parameters, a set of style values are defined.+data Style+ = -- | Path-style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).+ StyleMatrix+ | -- | Label style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).+ StyleLabel+ | -- | Form style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).+ -- This option replaces @collectionFormat@ with a @csv@ (when @explode@ is false) or @multi@+ -- (when explode is true) value from OpenAPI 2.0.+ StyleForm+ | -- | Simple style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).+ -- This option replaces @collectionFormat@ with a @csv@ value from OpenAPI 2.0.+ StyleSimple+ | -- | Space separated array values.+ -- This option replaces @collectionFormat@ equal to @ssv@ from OpenAPI 2.0.+ StyleSpaceDelimited+ | -- | Pipe separated array values.+ -- This option replaces @collectionFormat@ equal to @pipes@ from OpenAPI 2.0.+ StylePipeDelimited+ | -- | Provides a simple way of rendering nested objects using form parameters.+ StyleDeepObject+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | A single encoding definition applied to a request-body property, as+-- described by the OpenAPI Encoding Object (used inside 'MediaTypeObject').+data Encoding = Encoding+ { -- | The Content-Type for encoding a specific property.+ -- Default value depends on the property type: for @string@+ -- with format being @binary@ – @application/octet-stream@;+ -- for other primitive types – @text/plain@; for object - @application/json@;+ -- for array – the default is defined based on the inner type.+ -- The value can be a specific media type (e.g. @application/json@),+ -- a wildcard media type (e.g. @image/\*@), or a comma-separated list of the two types.+ _encodingContentType :: Maybe MediaType,+ -- | A map allowing additional information to be provided as headers,+ -- for example @Content-Disposition@. @Content-Type@ is described separately+ -- and SHALL be ignored in this section.+ -- This property SHALL be ignored if the request body media type is not a @multipart@.+ _encodingHeaders :: InsOrdHashMap Text (Referenced Header),+ -- | Describes how a specific property value will be serialized depending on its type.+ -- See 'Param' Object for details on the style property.+ -- The behavior follows the same values as query parameters, including default values.+ -- This property SHALL be ignored if the request body media type+ -- is not @application/x-www-form-urlencoded@.+ _encodingStyle :: Maybe Style,+ -- | When this is true, property values of type @array@ or @object@ generate+ -- separate parameters for each value of the array,+ -- or key-value-pair of the map.+ -- For other types of properties this property has no effect.+ -- When style is form, the default value is @true@. For all other styles,+ -- the default value is @false@. This property SHALL be ignored+ -- if the request body media type is not @application/x-www-form-urlencoded@.+ _encodingExplode :: Maybe Bool,+ -- | Determines whether the parameter value SHOULD allow reserved characters,+ -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2)+ -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding.+ -- The default value is @false@. This property SHALL be ignored if the request body media type+ -- is not @application/x-www-form-urlencoded@.+ _encodingAllowReserved :: Maybe Bool+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | A list of media types, used wherever the spec lists @produces@/@consumes@-style+-- content types.+newtype MimeList = MimeList {getMimeList :: [MediaType]}+ deriving stock (Eq, Show, Typeable)+ deriving newtype (Semigroup, Monoid)++mimeListConstr :: Constr+mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix++mimeListDataType :: DataType+mimeListDataType = mkDataType "Data.OpenApi.MimeList" [mimeListConstr]++instance Data MimeList where+ gunfold k z c = case constrIndex c of+ 1 -> k (z (MimeList . map fromString))+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."+ toConstr (MimeList _) = mimeListConstr+ dataTypeOf _ = mimeListDataType++-- | Describes a single operation parameter.+-- A unique parameter is defined by a combination of a name and location.+data Param = Param+ { -- | The name of the parameter.+ -- Parameter names are case sensitive.+ _paramName :: Text,+ -- | A brief description of the parameter.+ -- This could contain examples of use.+ -- CommonMark syntax MAY be used for rich text representation.+ _paramDescription :: Maybe Text,+ -- | Determines whether this parameter is mandatory.+ -- If the parameter is in "path", this property is required and its value MUST be true.+ -- Otherwise, the property MAY be included and its default value is @False@.+ _paramRequired :: Maybe Bool,+ -- | Specifies that a parameter is deprecated and SHOULD be transitioned out of usage.+ -- Default value is @false@.+ _paramDeprecated :: Maybe Bool,+ -- | The location of the parameter.+ _paramIn :: ParamLocation,+ -- | Sets the ability to pass empty-valued parameters.+ -- This is valid only for 'ParamQuery' parameters and allows sending+ -- a parameter with an empty value. Default value is @false@.+ _paramAllowEmptyValue :: Maybe Bool,+ -- | Determines whether the parameter value SHOULD allow reserved characters,+ -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2)+ -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding.+ -- This property only applies to parameters with an '_paramIn' value of 'ParamQuery'.+ -- The default value is 'False'.+ _paramAllowReserved :: Maybe Bool,+ -- | Parameter schema.+ _paramSchema :: Maybe (Referenced Schema),+ -- | Describes how the parameter value will be serialized depending+ -- on the type of the parameter value. Default values (based on value of '_paramIn'):+ -- for 'ParamQuery' - 'StyleForm'; for 'ParamPath' - 'StyleSimple'; for 'ParamHeader' - 'StyleSimple';+ -- for 'ParamCookie' - 'StyleForm'.+ _paramStyle :: Maybe Style,+ -- | When this is true, parameter values of type @array@ or @object@+ -- generate separate parameters for each value of the array or key-value pair of the map.+ -- For other types of parameters this property has no effect.+ -- When style is @form@, the default value is true. For all other styles, the default value is false.+ _paramExplode :: Maybe Bool,+ -- | Example of the parameter's potential value.+ -- The example SHOULD match the specified schema and encoding properties if present.+ -- The '_paramExample' field is mutually exclusive of the '_paramExamples' field.+ -- Furthermore, if referencing a schema that contains an example, the example value+ -- SHALL override the example provided by the schema. To represent examples of media types+ -- that cannot naturally be represented in JSON or YAML, a string value can contain+ -- the example with escaping where necessary.+ _paramExample :: Maybe Value,+ -- | Examples of the parameter's potential value.+ -- Each example SHOULD contain a value in the correct format as specified+ -- in the parameter encoding. The '_paramExamples' field is mutually exclusive of the '_paramExample' field.+ -- Furthermore, if referencing a schema that contains an example,+ -- the examples value SHALL override the example provided by the schema.+ _paramExamples :: InsOrdHashMap Text (Referenced Example)+ -- TODO+ -- _paramContent :: InsOrdHashMap MediaType MediaTypeObject+ -- should be singleton. mutually exclusive with _paramSchema.+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | An example value for a media type, parameter, or header, as described by+-- the OpenAPI Example Object.+data Example = Example+ { -- | Short description for the example.+ _exampleSummary :: Maybe Text,+ -- | Long description for the example.+ -- CommonMark syntax MAY be used for rich text representation.+ _exampleDescription :: Maybe Text,+ -- | Embedded literal example.+ -- The '_exampleValue' field and '_exampleExternalValue' field are mutually exclusive.+ --+ -- To represent examples of media types that cannot naturally represented in JSON or YAML,+ -- use a string value to contain the example, escaping where necessary.+ _exampleValue :: Maybe Value,+ -- | A URL that points to the literal example.+ -- This provides the capability to reference examples that cannot easily be included+ -- in JSON or YAML documents. The '_exampleValue' field+ -- and '_exampleExternalValue' field are mutually exclusive.+ _exampleExternalValue :: Maybe URL+ }+ deriving stock (Eq, Show, Generic, Typeable, Data)++data ExpressionOrValue+ = Expression Text+ | Value Value+ deriving stock (Eq, Show, Generic, Typeable, Data)++-- | The Link object represents a possible design-time link for a response.+-- The presence of a link does not guarantee the caller's ability to successfully invoke it,+-- rather it provides a known relationship and traversal mechanism between responses and other operations.+data Link = Link+ { -- | A relative or absolute URI reference to an OAS operation.+ -- This field is mutually exclusive of the '_linkOperationId' field,+ -- and MUST point to an 'Operation' Object. Relative '_linkOperationRef'+ -- values MAY be used to locate an existing 'Operation' Object in the OpenAPI definition.+ _linkOperationRef :: Maybe Text,+ -- | The name of an /existing/, resolvable OAS operation, as defined with a unique+ -- '_operationOperationId'. This field is mutually exclusive of the '_linkOperationRef' field.+ _linkOperationId :: Maybe Text,+ -- | A map representing parameters to pass to an operation as specified with '_linkOperationId'+ -- or identified via '_linkOperationRef'. The key is the parameter name to be used, whereas+ -- the value can be a constant or an expression to be evaluated and passed to the linked operation.+ -- The parameter name can be qualified using the parameter location @[{in}.]{name}@+ -- for operations that use the same parameter name in different locations (e.g. path.id).+ _linkParameters :: InsOrdHashMap Text ExpressionOrValue,+ -- | A literal value or @{expression}@ to use as a request body when calling the target operation.+ _linkRequestBody :: Maybe ExpressionOrValue,+ -- | A description of the link.+ _linkDescription :: Maybe Text,+ -- | A server object to be used by the target operation.+ _linkServer :: Maybe Server+ }+ deriving stock (Eq, Show, Generic, Typeable, Data)++-- | The @items@ keyword. In OpenAPI 3.1 / JSON Schema 2020-12, @items@ is a single+-- schema or a boolean (@items: false@ means "no additional array items are allowed").+--+-- @'OpenApiItemsObject'@ specifies the schema every array element must satisfy.+--+-- @'OpenApiItemsBoolean'@ specifies @items: true@ or @items: false@.+--+-- Tuple validation (the old @items: [schema, ...]@ array form) is expressed via the+-- separate @_schemaPrefixItems@ field (positional schemas) together with @items: false@.+data OpenApiItems where+ OpenApiItemsObject :: Referenced Schema -> OpenApiItems+ OpenApiItemsBoolean :: Bool -> OpenApiItems+ deriving stock (Eq, Show, Typeable, Data)++-- | A single JSON Schema primitive type, i.e. one element of a schema's @type@+-- keyword. Note 3.1 adds @"null"@ ('OpenApiNull'), used in type arrays to+-- express nullability.+data OpenApiType where+ OpenApiString :: OpenApiType+ OpenApiNumber :: OpenApiType+ OpenApiInteger :: OpenApiType+ OpenApiBoolean :: OpenApiType+ OpenApiArray :: OpenApiType+ OpenApiNull :: OpenApiType+ OpenApiObject :: OpenApiType+ deriving stock (Eq, Show, Typeable, Generic, Data)++-- | The value of a schema's @type@ keyword. In OpenAPI 3.1 / JSON Schema 2020-12,+-- @type@ may be a single type (@"string"@) or an array of types (@["string","null"]@,+-- the 3.1 way to express nullability — there is no @nullable@ keyword any more).+data OpenApiTypeValue+ = OpenApiTypeSingle OpenApiType+ | OpenApiTypeArray [OpenApiType]+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Extract a single type if the @type@ value is a single type (not an array).+-- Returns 'Nothing' for a type array.+singleType :: OpenApiTypeValue -> Maybe OpenApiType+singleType (OpenApiTypeSingle t) = Just t+singleType (OpenApiTypeArray _) = Nothing++-- | The location (@in@) of a 'Param': query string, header, path, or cookie.+data ParamLocation+ = -- | Parameters that are appended to the URL.+ -- For example, in @/items?id=###@, the query parameter is @id@.+ ParamQuery+ | -- | Custom headers that are expected as part of the request.+ ParamHeader+ | -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.+ -- This does not include the host or base path of the API.+ -- For example, in @/items/{itemId}@, the path parameter is @itemId@.+ ParamPath+ | -- | Used to pass a specific cookie value to the API.+ ParamCookie+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | The @format@ modifier of a schema or parameter (e.g. @"date-time"@,+-- @"int64"@). Open-ended free-form text per JSON Schema.+type Format = Text++-- | The name of a 'Param' or a required property of a 'Schema'.+type ParamName = Text++-- | An OpenAPI 3.1 Schema Object: a JSON Schema 2020-12 document describing the+-- shape of a JSON value. This is the central type of the library.+data Schema = Schema+ { _schemaTitle :: Maybe Text,+ _schemaDescription :: Maybe Text,+ _schemaRequired :: [ParamName],+ _schemaAllOf :: Maybe [Referenced Schema],+ _schemaOneOf :: Maybe [Referenced Schema],+ _schemaNot :: Maybe (Referenced Schema),+ _schemaAnyOf :: Maybe [Referenced Schema],+ _schemaProperties :: InsOrdHashMap Text (Referenced Schema),+ _schemaAdditionalProperties :: Maybe AdditionalProperties,+ _schemaDiscriminator :: Maybe Discriminator,+ _schemaReadOnly :: Maybe Bool,+ _schemaWriteOnly :: Maybe Bool,+ _schemaXml :: Maybe Xml,+ _schemaExternalDocs :: Maybe ExternalDocs,+ _schemaExample :: Maybe Value,+ _schemaDeprecated :: Maybe Bool,+ _schemaMaxProperties :: Maybe Integer,+ _schemaMinProperties :: Maybe Integer,+ -- | Declares the value of the parameter that the server will use if none is provided,+ -- for example a @"count"@ to control the number of results per page might default to @100@+ -- if not supplied by the client in the request.+ -- (Note: "default" has no meaning for required parameters.)+ -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.+ _schemaDefault :: Maybe Value,+ _schemaType :: Maybe OpenApiTypeValue,+ _schemaFormat :: Maybe Format,+ _schemaItems :: Maybe OpenApiItems,+ _schemaMaximum :: Maybe Scientific,+ _schemaExclusiveMaximum :: Maybe Scientific,+ _schemaMinimum :: Maybe Scientific,+ _schemaExclusiveMinimum :: Maybe Scientific,+ _schemaMaxLength :: Maybe Integer,+ _schemaMinLength :: Maybe Integer,+ _schemaPattern :: Maybe Pattern,+ _schemaMaxItems :: Maybe Integer,+ _schemaMinItems :: Maybe Integer,+ _schemaUniqueItems :: Maybe Bool,+ _schemaEnum :: Maybe [Value],+ _schemaMultipleOf :: Maybe Scientific,+ -- JSON Schema 2020-12 additions (OpenAPI 3.1) — EP-4+ _schemaConst :: Maybe Value,+ _schemaPrefixItems :: Maybe [Referenced Schema],+ _schemaContains :: Maybe (Referenced Schema),+ _schemaMinContains :: Maybe Integer,+ _schemaMaxContains :: Maybe Integer,+ _schemaIf :: Maybe (Referenced Schema),+ _schemaThen :: Maybe (Referenced Schema),+ _schemaElse :: Maybe (Referenced Schema),+ _schemaDependentSchemas :: Maybe (InsOrdHashMap Text (Referenced Schema)),+ _schemaDependentRequired :: Maybe (InsOrdHashMap Text [Text]),+ _schemaUnevaluatedProperties :: Maybe AdditionalProperties,+ _schemaUnevaluatedItems :: Maybe (Referenced Schema),+ _schemaPropertyNames :: Maybe (Referenced Schema),+ _schemaContentEncoding :: Maybe Text,+ _schemaContentMediaType :: Maybe Text,+ _schemaContentSchema :: Maybe (Referenced Schema),+ _schemaExamples :: Maybe [Value],+ -- JSON Schema 2020-12 identification / reference keywords ($-prefixed) — EP-4+ _schemaId :: Maybe Text,+ _schemaAnchor :: Maybe Text,+ _schemaDefs :: Maybe (InsOrdHashMap Text (Referenced Schema)),+ _schemaRef :: Maybe Text,+ -- \$ref (siblings allowed; see Decision Log)+ _schemaDynamicRef :: Maybe Text,+ _schemaDynamicAnchor :: Maybe Text+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++{-# DEPRECATED _schemaExample "Use _schemaExamples (JSON Schema examples) in OpenAPI 3.1" #-}++-- | Regex pattern for @string@ type.+type Pattern = Text++-- | Adds support for polymorphism via the OpenAPI Discriminator Object: names+-- the payload property that selects which schema (of an @oneOf@/@anyOf@) a value+-- conforms to.+data Discriminator = Discriminator+ { -- | The name of the property in the payload that will hold the discriminator value.+ _discriminatorPropertyName :: Text,+ -- | An object to hold mappings between payload values and schema names or references.+ _discriminatorMapping :: InsOrdHashMap Text Text+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | A @'Schema'@ with an optional name.+-- This name can be used in references.+data NamedSchema = NamedSchema+ { _namedSchemaName :: Maybe Text,+ _namedSchemaSchema :: Schema+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Metadata for fine-tuning the XML representation of a schema, as described+-- by the OpenAPI XML Object.+data Xml = Xml+ { -- | Replaces the name of the element/attribute used for the described schema property.+ -- When defined within the @'OpenApiItems'@ (items), it will affect the name of the individual XML elements within the list.+ -- When defined alongside type being array (outside the items),+ -- it will affect the wrapping element and only if wrapped is true.+ -- If wrapped is false, it will be ignored.+ _xmlName :: Maybe Text,+ -- | The URL of the namespace definition.+ -- Value SHOULD be in the form of a URL.+ _xmlNamespace :: Maybe Text,+ -- | The prefix to be used for the name.+ _xmlPrefix :: Maybe Text,+ -- | Declares whether the property definition translates to an attribute instead of an element.+ -- Default value is @False@.+ _xmlAttribute :: Maybe Bool,+ -- | MAY be used only for an array definition.+ -- Signifies whether the array is wrapped+ -- (for example, @\<books\>\<book/\>\<book/\>\</books\>@)+ -- or unwrapped (@\<book/\>\<book/\>@).+ -- Default value is @False@.+ -- The definition takes effect only when defined alongside type being array (outside the items).+ _xmlWrapped :: Maybe Bool+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | A container for the expected responses of an operation.+-- The container maps a HTTP response code to the expected response.+-- It is not expected from the documentation to necessarily cover all possible HTTP response codes,+-- since they may not be known in advance.+-- However, it is expected from the documentation to cover a successful operation response and any known errors.+data Responses = Responses+ { -- | The documentation of responses other than the ones declared for specific HTTP response codes.+ -- It can be used to cover undeclared responses.+ _responsesDefault :: Maybe (Referenced Response),+ -- | Any HTTP status code can be used as the property name (one property per HTTP status code).+ -- Describes the expected response for those HTTP status codes.+ _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | An HTTP status code keying an entry in 'Responses' (e.g. @200@, @404@).+type HttpStatusCode = Int++-- | Describes a single response from an API Operation.+data Response = Response+ { -- | A short description of the response.+ -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation.+ _responseDescription :: Text,+ -- | A map containing descriptions of potential response payloads.+ -- The key is a media type or media type range and the value describes it.+ -- For responses that match multiple keys, only the most specific key is applicable.+ -- e.g. @text/plain@ overrides @text/\*@.+ _responseContent :: InsOrdHashMap MediaType MediaTypeObject,+ -- | Maps a header name to its definition.+ _responseHeaders :: InsOrdHashMap HeaderName (Referenced Header),+ -- | A map of operations links that can be followed from the response.+ -- The key of the map is a short name for the link, following the naming+ -- constraints of the names for @'Components'@ Objects.+ _responseLinks :: InsOrdHashMap Text (Referenced Link)+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++instance IsString Response where+ fromString s = Response (fromString s) mempty mempty mempty++-- | A map of possible out-of band callbacks related to the parent operation.+-- Each value in the map is a 'PathItem' Object that describes a set of requests that+-- may be initiated by the API provider and the expected responses.+-- The key value used to identify the path item object is an expression, evaluated at runtime,+-- that identifies a URL to use for the callback operation.+newtype Callback = Callback (InsOrdHashMap Text PathItem)+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | The name of a response 'Header'.+type HeaderName = Text++-- | Header fields have the same meaning as for 'Param'.+--+-- Style is always treated as 'StyleSimple', as it is the only value allowed for headers.+data Header = Header+ { -- | A short description of the header.+ _headerDescription :: Maybe HeaderName,+ _headerRequired :: Maybe Bool,+ _headerDeprecated :: Maybe Bool,+ _headerAllowEmptyValue :: Maybe Bool,+ _headerExplode :: Maybe Bool,+ _headerExample :: Maybe Value,+ _headerExamples :: InsOrdHashMap Text (Referenced Example),+ _headerSchema :: Maybe (Referenced Schema)+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | The location of the API key.+data ApiKeyLocation+ = ApiKeyQuery+ | ApiKeyHeader+ | ApiKeyCookie+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Configuration for an @apiKey@ 'SecurityScheme': the name and location of+-- the key.+data ApiKeyParams = ApiKeyParams+ { -- | The name of the header or query parameter to be used.+ _apiKeyName :: Text,+ -- | The location of the API key.+ _apiKeyIn :: ApiKeyLocation+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.+type AuthorizationURL = Text++-- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.+type TokenURL = Text++-- | Flow-specific parameters for the OAuth2 implicit flow.+newtype OAuth2ImplicitFlow+ = OAuth2ImplicitFlow {_oAuth2ImplicitFlowAuthorizationUrl :: AuthorizationURL}+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Flow-specific parameters for the OAuth2 resource-owner password flow.+newtype OAuth2PasswordFlow+ = OAuth2PasswordFlow {_oAuth2PasswordFlowTokenUrl :: TokenURL}+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Flow-specific parameters for the OAuth2 client-credentials flow.+newtype OAuth2ClientCredentialsFlow+ = OAuth2ClientCredentialsFlow {_oAuth2ClientCredentialsFlowTokenUrl :: TokenURL}+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Flow-specific parameters for the OAuth2 authorization-code flow.+data OAuth2AuthorizationCodeFlow = OAuth2AuthorizationCodeFlow+ { _oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL,+ _oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | A single OAuth2 flow, as described by the OpenAPI OAuth Flow Object. The+-- flow-specific parameters @p@ are one of the @OAuth2*Flow@ types above.+data OAuth2Flow p = OAuth2Flow+ { _oAuth2Params :: p,+ -- | The URL to be used for obtaining refresh tokens.+ _oAath2RefreshUrl :: Maybe URL,+ -- | The available scopes for the OAuth2 security scheme.+ -- A map between the scope name and a short description for it.+ -- The map MAY be empty.+ _oAuth2Scopes :: InsOrdHashMap Text Text+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | The set of OAuth2 flows supported by a 'SecurityScheme', as described by+-- the OpenAPI OAuth Flows Object. Each flow is optional.+data OAuth2Flows = OAuth2Flows+ { -- | Configuration for the OAuth Implicit flow+ _oAuth2FlowsImplicit :: Maybe (OAuth2Flow OAuth2ImplicitFlow),+ -- | Configuration for the OAuth Resource Owner Password flow+ _oAuth2FlowsPassword :: Maybe (OAuth2Flow OAuth2PasswordFlow),+ -- | Configuration for the OAuth Client Credentials flow+ _oAuth2FlowsClientCredentials :: Maybe (OAuth2Flow OAuth2ClientCredentialsFlow),+ -- | Configuration for the OAuth Authorization Code flow+ _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow)+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++type BearerFormat = Text++-- | The scheme of an @http@ 'SecurityScheme' (an [IANA HTTP auth scheme](https://www.iana.org/assignments/http-authschemes/http-authschemes.xhtml)):+-- @bearer@ (with an optional @bearerFormat@), @basic@, or a custom scheme name.+data HttpSchemeType+ = HttpSchemeBearer (Maybe BearerFormat)+ | HttpSchemeBasic+ | HttpSchemeCustom Text+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- |+--+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer Nothing))+-- {+-- "scheme": "bearer",+-- "type": "http"+-- }+--+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer (Just "jwt")))+-- {+-- "bearerFormat": "jwt",+-- "scheme": "bearer",+-- "type": "http"+-- }+--+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp HttpSchemeBasic)+-- {+-- "scheme": "basic",+-- "type": "http"+-- }+--+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeCustom "CANARY"))+-- {+-- "scheme": "CANARY",+-- "type": "http"+-- }+--+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie))+-- {+-- "in": "cookie",+-- "name": "id",+-- "type": "apiKey"+-- }+data SecuritySchemeType+ = SecuritySchemeHttp HttpSchemeType+ | SecuritySchemeApiKey ApiKeyParams+ | SecuritySchemeOAuth2 OAuth2Flows+ | SecuritySchemeOpenIdConnect URL+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Defines a security scheme that can be used by an operation, as described by+-- the OpenAPI Security Scheme Object.+data SecurityScheme = SecurityScheme+ { -- | The type of the security scheme.+ _securitySchemeType :: SecuritySchemeType,+ -- | A short description for security scheme.+ _securitySchemeDescription :: Maybe Text+ }+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | The named 'SecurityScheme' definitions held under @components.securitySchemes@.+newtype SecurityDefinitions+ = SecurityDefinitions (Definitions SecurityScheme)+ deriving stock (Eq, Show, Generic, Data, Typeable)++-- | Lists the required security schemes to execute this operation.+-- The object can have multiple security schemes declared in it which are all required+-- (that is, there is a logical AND between the schemes).+newtype SecurityRequirement = SecurityRequirement+ { getSecurityRequirement :: InsOrdHashMap Text [Text]+ }+ deriving stock (Eq, Read, Show, Data, Typeable)+ deriving newtype (Semigroup, Monoid, ToJSON, FromJSON)++-- | Tag name.+type TagName = Text++-- | Allows adding meta data to a single tag that is used by @Operation@.+-- It is not mandatory to have a @Tag@ per tag used there.+data Tag = Tag+ { -- | The name of the tag.+ _tagName :: TagName,+ -- | A short description for the tag.+ -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.+ _tagDescription :: Maybe Text,+ -- | Additional external documentation for this tag.+ _tagExternalDocs :: Maybe ExternalDocs+ }+ deriving stock (Eq, Ord, Show, Generic, Data, Typeable)++instance Hashable Tag++instance IsString Tag where+ fromString s = Tag (fromString s) Nothing Nothing++-- | Allows referencing an external resource for extended documentation.+data ExternalDocs = ExternalDocs+ { -- | A short description of the target documentation.+ -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.+ _externalDocsDescription :: Maybe Text,+ -- | The URL for the target documentation.+ _externalDocsUrl :: URL+ }+ deriving stock (Eq, Ord, Show, Generic, Data, Typeable)++instance Hashable ExternalDocs++-- | A simple object to allow referencing other definitions in the specification.+-- It can be used to reference parameters and responses that are defined at the top level for reuse.+newtype Reference = Reference {getReference :: Text}+ deriving stock (Eq, Show, Data, Typeable)++-- | Either an inline value of type @a@ or a 'Reference' to one declared+-- elsewhere (e.g. under @components@). Most spec fields that may be reused are+-- @'Referenced' a@.+data Referenced a+ = Ref Reference+ | Inline a+ deriving stock (Eq, Show, Functor, Data, Typeable)++instance (IsString a) => IsString (Referenced a) where+ fromString = Inline . fromString++-- | A URL string, used for links, terms of service, external docs, and the like.+newtype URL = URL {getUrl :: Text}+ deriving stock (Eq, Ord, Show, Data, Typeable)+ deriving newtype (Hashable, ToJSON, FromJSON)++-- | A schema's @additionalProperties@: either a boolean allowing or forbidding+-- properties beyond those listed, or a 'Schema' every additional property must+-- satisfy.+data AdditionalProperties+ = AdditionalPropertiesAllowed Bool+ | AdditionalPropertiesSchema (Referenced Schema)+ deriving stock (Eq, Show, Data, Typeable)++newtype OpenApiSpecVersion = OpenApiSpecVersion {getVersion :: Version} deriving stock (Eq, Show, Generic, Data, Typeable)++-------------------------------------------------------------------------------+-- Generic instances+-------------------------------------------------------------------------------++deriveGeneric ''Server+deriveGeneric ''Components+deriveGeneric ''Header+deriveGeneric ''OAuth2Flow+deriveGeneric ''OAuth2Flows+deriveGeneric ''Operation+deriveGeneric ''Param+deriveGeneric ''PathItem+deriveGeneric ''Response+deriveGeneric ''RequestBody+deriveGeneric ''MediaTypeObject+deriveGeneric ''Responses+deriveGeneric ''SecurityScheme+deriveGeneric ''Schema+deriveGeneric ''OpenApi+deriveGeneric ''Example+deriveGeneric ''Encoding+deriveGeneric ''Link+deriveGeneric ''OpenApiSpecVersion++-- =======================================================================+-- Monoid instances+-- =======================================================================++instance Semigroup OpenApiSpecVersion where+ (<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b++instance Monoid OpenApiSpecVersion where+ mempty = OpenApiSpecVersion (makeVersion [3, 1, 0])+ mappend = (<>)++instance Semigroup OpenApi where+ (<>) = genericMappend++instance Monoid OpenApi where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Info where+ (<>) = genericMappend++instance Monoid Info where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Contact where+ (<>) = genericMappend++instance Monoid Contact where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Components where+ (<>) = genericMappend++instance Monoid Components where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup PathItem where+ (<>) = genericMappend++instance Monoid PathItem where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Schema where+ (<>) = genericMappend++instance Monoid Schema where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Param where+ (<>) = genericMappend++instance Monoid Param where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Header where+ (<>) = genericMappend++instance Monoid Header where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Responses where+ (<>) = genericMappend++instance Monoid Responses where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Response where+ (<>) = genericMappend++instance Monoid Response where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup MediaTypeObject where+ (<>) = genericMappend++instance Monoid MediaTypeObject where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Encoding where+ (<>) = genericMappend++instance Monoid Encoding where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup ExternalDocs where+ (<>) = genericMappend++instance Monoid ExternalDocs where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup Operation where+ (<>) = genericMappend++instance Monoid Operation where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup (OAuth2Flow p) where+ l@OAuth2Flow {_oAath2RefreshUrl = lUrl, _oAuth2Scopes = lScopes}+ <> OAuth2Flow {_oAath2RefreshUrl = rUrl, _oAuth2Scopes = rScopes} =+ l {_oAath2RefreshUrl = openApiMappend lUrl rUrl, _oAuth2Scopes = lScopes <> rScopes}++-- openApiMappend has First-like semantics, and here we need mappend'ing under Maybes.+instance Semigroup OAuth2Flows where+ l <> r =+ OAuth2Flows+ { _oAuth2FlowsImplicit = _oAuth2FlowsImplicit l <> _oAuth2FlowsImplicit r,+ _oAuth2FlowsPassword = _oAuth2FlowsPassword l <> _oAuth2FlowsPassword r,+ _oAuth2FlowsClientCredentials = _oAuth2FlowsClientCredentials l <> _oAuth2FlowsClientCredentials r,+ _oAuth2FlowsAuthorizationCode = _oAuth2FlowsAuthorizationCode l <> _oAuth2FlowsAuthorizationCode r+ }++instance Monoid OAuth2Flows where+ mempty = genericMempty+ mappend = (<>)++instance Semigroup SecurityScheme where+ SecurityScheme (SecuritySchemeOAuth2 lFlows) lDesc+ <> SecurityScheme (SecuritySchemeOAuth2 rFlows) rDesc =+ SecurityScheme (SecuritySchemeOAuth2 $ lFlows <> rFlows) (openApiMappend lDesc rDesc)+ l <> _ = l++instance Semigroup SecurityDefinitions where+ (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =+ SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2++instance Monoid SecurityDefinitions where+ mempty = SecurityDefinitions InsOrdHashMap.empty+ mappend = (<>)++instance Semigroup RequestBody where+ (<>) = genericMappend++instance Monoid RequestBody where+ mempty = genericMempty+ mappend = (<>)++-- =======================================================================+-- OpenApiMonoid helper instances+-- =======================================================================++instance OpenApiMonoid Info++instance OpenApiMonoid Components++instance OpenApiMonoid PathItem++instance OpenApiMonoid Schema++instance OpenApiMonoid Param++instance OpenApiMonoid Responses++instance OpenApiMonoid Response++instance OpenApiMonoid ExternalDocs++instance OpenApiMonoid Operation++instance (Eq a, Hashable a) => OpenApiMonoid (InsOrdHashSet a)++instance OpenApiMonoid SecurityDefinitions++instance OpenApiMonoid OpenApiSpecVersion++instance OpenApiMonoid MimeList++deriving newtype instance OpenApiMonoid URL++instance OpenApiMonoid OpenApiType where+ openApiMempty = OpenApiString+ openApiMappend _ y = y++instance OpenApiMonoid OpenApiTypeValue where+ openApiMempty = OpenApiTypeSingle OpenApiString+ openApiMappend _ y = y++instance OpenApiMonoid ParamLocation where+ openApiMempty = ParamQuery+ openApiMappend _ y = y++instance {-# OVERLAPPING #-} OpenApiMonoid (InsOrdHashMap FilePath PathItem) where+ openApiMempty = InsOrdHashMap.empty+ openApiMappend = InsOrdHashMap.unionWith mappend++instance (Monoid a) => OpenApiMonoid (Referenced a) where+ openApiMempty = Inline mempty+ openApiMappend (Inline x) (Inline y) = Inline (mappend x y)+ openApiMappend _ y = y++-- =======================================================================+-- Simple Generic-based ToJSON instances+-- =======================================================================++instance ToJSON Style where+ toJSON = genericToJSON (jsonPrefix "Style")++instance ToJSON OpenApiType where+ toJSON = genericToJSON (jsonPrefix "OpenApi")++instance ToJSON ParamLocation where+ toJSON = genericToJSON (jsonPrefix "Param")++instance ToJSON Info where+ toJSON = genericToJSON (jsonPrefix "Info")++instance ToJSON Contact where+ toJSON = genericToJSON (jsonPrefix "Contact")++instance ToJSON License where+ toJSON = genericToJSON (jsonPrefix "License")++instance ToJSON ServerVariable where+ toJSON = genericToJSON (jsonPrefix "ServerVariable")++instance ToJSON ApiKeyLocation where+ toJSON = genericToJSON (jsonPrefix "ApiKey")++instance ToJSON ApiKeyParams where+ toJSON = genericToJSON (jsonPrefix "apiKey")++instance ToJSON Tag where+ toJSON = genericToJSON (jsonPrefix "Tag")++instance ToJSON ExternalDocs where+ toJSON = genericToJSON (jsonPrefix "ExternalDocs")++instance ToJSON Xml where+ toJSON = genericToJSON (jsonPrefix "Xml")++instance ToJSON Discriminator where+ toJSON = genericToJSON (jsonPrefix "Discriminator")++instance ToJSON OAuth2ImplicitFlow where+ toJSON = genericToJSON (jsonPrefix "OAuth2ImplicitFlow")++instance ToJSON OAuth2PasswordFlow where+ toJSON = genericToJSON (jsonPrefix "OAuth2PasswordFlow")++instance ToJSON OAuth2ClientCredentialsFlow where+ toJSON = genericToJSON (jsonPrefix "OAuth2ClientCredentialsFlow")++instance ToJSON OAuth2AuthorizationCodeFlow where+ toJSON = genericToJSON (jsonPrefix "OAuth2AuthorizationCodeFlow")++-- =======================================================================+-- Simple Generic-based FromJSON instances+-- =======================================================================++instance FromJSON Style where+ parseJSON = genericParseJSON (jsonPrefix "Style")++instance FromJSON OpenApiType where+ parseJSON = genericParseJSON (jsonPrefix "OpenApi")++instance ToJSON OpenApiTypeValue where+ toJSON (OpenApiTypeSingle t) = toJSON t -- reuses ToJSON OpenApiType -> a JSON string+ toJSON (OpenApiTypeArray ts) = toJSON ts -- a JSON array of strings++instance FromJSON OpenApiTypeValue where+ parseJSON v@(String _) = OpenApiTypeSingle <$> parseJSON v+ parseJSON v@(Array _) = OpenApiTypeArray <$> parseJSON v+ parseJSON _ = fail "type must be a string or an array of strings"++instance FromJSON ParamLocation where+ parseJSON = genericParseJSON (jsonPrefix "Param")++instance FromJSON Info where+ parseJSON = genericParseJSON (jsonPrefix "Info")++instance FromJSON Contact where+ parseJSON = genericParseJSON (jsonPrefix "Contact")++instance FromJSON License where+ parseJSON = genericParseJSON (jsonPrefix "License")++instance FromJSON ServerVariable where+ parseJSON = genericParseJSON (jsonPrefix "ServerVariable")++instance FromJSON ApiKeyLocation where+ parseJSON = genericParseJSON (jsonPrefix "ApiKey")++instance FromJSON ApiKeyParams where+ parseJSON = genericParseJSON (jsonPrefix "apiKey")++instance FromJSON Tag where+ parseJSON = genericParseJSON (jsonPrefix "Tag")++instance FromJSON ExternalDocs where+ parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")++instance FromJSON Discriminator where+ parseJSON = genericParseJSON (jsonPrefix "Discriminator")++instance FromJSON OAuth2ImplicitFlow where+ parseJSON = genericParseJSON (jsonPrefix "OAuth2ImplicitFlow")++instance FromJSON OAuth2PasswordFlow where+ parseJSON = genericParseJSON (jsonPrefix "OAuth2PasswordFlow")++instance FromJSON OAuth2ClientCredentialsFlow where+ parseJSON = genericParseJSON (jsonPrefix "OAuth2ClientCredentialsFlow")++instance FromJSON OAuth2AuthorizationCodeFlow where+ parseJSON = genericParseJSON (jsonPrefix "OAuth2AuthorizationCodeFlow")++-- =======================================================================+-- Manual ToJSON instances+-- =======================================================================++instance ToJSON OpenApiSpecVersion where+ toJSON (OpenApiSpecVersion v) = toJSON . showVersion $ v++instance ToJSON MediaType where+ toJSON = toJSON . show+ toEncoding = toEncoding . show++instance ToJSONKey MediaType where+ toJSONKey = JSON.toJSONKeyText (Text.pack . show)++instance (Eq p, ToJSON p, AesonDefaultValue p) => ToJSON (OAuth2Flow p) where+ toJSON a =+ sopOpenApiGenericToJSON a+ & if InsOrdHashMap.null (_oAuth2Scopes a)+ then (<+> object ["scopes" .= object []])+ else id+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON OAuth2Flows where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON SecuritySchemeType where+ toJSON (SecuritySchemeHttp ty) = case ty of+ HttpSchemeBearer mFmt ->+ object+ $ [ "type" .= ("http" :: Text),+ "scheme" .= ("bearer" :: Text)+ ]+ <> maybe [] (\t -> ["bearerFormat" .= t]) mFmt+ HttpSchemeBasic ->+ object+ [ "type" .= ("http" :: Text),+ "scheme" .= ("basic" :: Text)+ ]+ HttpSchemeCustom t ->+ object+ [ "type" .= ("http" :: Text),+ "scheme" .= t+ ]+ toJSON (SecuritySchemeApiKey params) =+ toJSON params+ <+> object ["type" .= ("apiKey" :: Text)]+ toJSON (SecuritySchemeOAuth2 params) =+ object+ [ "type" .= ("oauth2" :: Text),+ "flows" .= toJSON params+ ]+ toJSON (SecuritySchemeOpenIdConnect url) =+ object+ [ "type" .= ("openIdConnect" :: Text),+ "openIdConnectUrl" .= url+ ]++instance ToJSON OpenApi where+ toJSON a =+ sopOpenApiGenericToJSON a+ & if InsOrdHashMap.null (_openApiPaths a)+ then (<+> object ["paths" .= object []])+ else id+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON Server where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON SecurityScheme where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++-- | The canonical rename table mapping the plain keys produced by the generic+-- field-name rule to their JSON Schema 2020-12 @$@-prefixed spellings. Owned by+-- EP-4 (Integration Point IP-3); EP-5 imports the helpers and supplies its own table.+schemaDollarKeyRenames :: [(Text, Text)]+schemaDollarKeyRenames =+ [ ("id", "$id"),+ ("anchor", "$anchor"),+ ("defs", "$defs"),+ ("ref", "$ref"),+ ("dynamicRef", "$dynamicRef"),+ ("dynamicAnchor", "$dynamicAnchor")+ ]++instance ToJSON Schema where+ toJSON =+ applyKeyRenamesToJSON schemaDollarKeyRenames+ . sopOpenApiGenericToJSONWithOpts+ (mkOpenApiAesonOptions "schema" & saoSubObject ?~ "items")++instance ToJSON Header where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++-- | Both cases wrap the value in a single @"items"@ key. The @ToJSON Schema@+-- instance uses @saoSubObject ?~ "items"@, which lifts that single key up into the+-- parent schema object — so an object emits @"items": {..}@ and a boolean emits+-- @"items": true|false@.+instance ToJSON OpenApiItems where+ toJSON (OpenApiItemsObject x) = object ["items" .= x]+ toJSON (OpenApiItemsBoolean b) = object ["items" .= b]++instance ToJSON Components where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON MimeList where+ toJSON (MimeList xs) = toJSON (map show xs)++instance ToJSON Param where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON Responses where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON Response where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON Operation where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++-- | @PathItem@'s only @$@-prefixed key. Reuses EP-4's shared helper (IP-3).+pathItemDollarKeyRenames :: [(Text, Text)]+pathItemDollarKeyRenames = [("ref", "$ref")]++instance ToJSON PathItem where+ toJSON = applyKeyRenamesToJSON pathItemDollarKeyRenames . sopOpenApiGenericToJSON++-- No hand-rolled toEncoding: it would bypass the $ref rename pass; let aeson+-- derive toEncoding from toJSON so the rename always runs.++instance ToJSON RequestBody where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON MediaTypeObject where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON Example where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON Encoding where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON Link where+ toJSON = sopOpenApiGenericToJSON+ toEncoding = sopOpenApiGenericToEncoding++instance ToJSON SecurityDefinitions where+ toJSON (SecurityDefinitions sd) = toJSON sd++instance ToJSON Reference where+ toJSON (Reference ref) = object ["$ref" .= ref]++referencedToJSON :: (ToJSON a) => Text -> Referenced a -> Value+referencedToJSON prefix (Ref (Reference ref)) = object ["$ref" .= (prefix <> ref)]+referencedToJSON _ (Inline x) = toJSON x++instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/components/schemas/"++instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/components/parameters/"++instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/components/responses/"++instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/components/requestBodies/"++instance ToJSON (Referenced Example) where toJSON = referencedToJSON "#/components/examples/"++instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/components/headers/"++instance ToJSON (Referenced Link) where toJSON = referencedToJSON "#/components/links/"++instance ToJSON (Referenced Callback) where toJSON = referencedToJSON "#/components/callbacks/"++instance ToJSON (Referenced PathItem) where toJSON = referencedToJSON "#/components/pathItems/"++instance ToJSON AdditionalProperties where+ toJSON (AdditionalPropertiesAllowed b) = toJSON b+ toJSON (AdditionalPropertiesSchema s) = toJSON s++instance ToJSON ExpressionOrValue where+ toJSON (Expression expr) = toJSON expr+ toJSON (Value val) = toJSON val++instance ToJSON Callback where+ toJSON (Callback ps) = toJSON ps++-- =======================================================================+-- Manual FromJSON instances+-- =======================================================================++instance FromJSON OpenApiSpecVersion where+ parseJSON = withText "OpenApiSpecVersion" $ \str ->+ let validatedVersion :: Either String Version+ validatedVersion = do+ parsedVersion <- readVersion str+ unless ((parsedVersion >= lowerOpenApiSpecVersion) && (parsedVersion <= upperOpenApiSpecVersion))+ $ Left ("The provided version " <> showVersion parsedVersion <> " is out of the allowed range >=" <> showVersion lowerOpenApiSpecVersion <> " && <=" <> showVersion upperOpenApiSpecVersion)+ return parsedVersion+ in either fail (return . OpenApiSpecVersion) validatedVersion+ where+ readVersion :: Text -> Either String Version+ readVersion v = case readP_to_S parseVersion (Text.unpack v) of+ [] -> Left $ "Failed to parse as a version string " <> Text.unpack v+ solutions -> Right (fst . last $ solutions)++instance FromJSON MediaType where+ parseJSON = withText "MediaType" $ \str ->+ maybe (fail $ "Invalid media type literal " <> Text.unpack str) pure $ parseAccept $ encodeUtf8 str++instance FromJSONKey MediaType where+ fromJSONKey = FromJSONKeyTextParser (parseJSON . String)++instance (Eq p, FromJSON p, AesonDefaultValue p) => FromJSON (OAuth2Flow p) where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON OAuth2Flows where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON SecuritySchemeType where+ parseJSON js@(Object o) = do+ (t :: Text) <- o .: "type"+ case t of+ "http" -> do+ scheme <- o .: "scheme"+ SecuritySchemeHttp <$> case scheme of+ "bearer" -> HttpSchemeBearer <$> (o .:! "bearerFormat")+ "basic" -> pure HttpSchemeBasic+ t -> pure $ HttpSchemeCustom t+ "apiKey" -> SecuritySchemeApiKey <$> parseJSON js+ "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows")+ "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl")+ _ -> empty+ parseJSON _ = empty++instance FromJSON OpenApi where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Server where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON SecurityScheme where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Schema where+ parseJSON = withObject "Schema" $ \o ->+ sopOpenApiGenericParseJSON (Object (applyKeyRenamesParseJSON schemaDollarKeyRenames o))++instance FromJSON Header where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON OpenApiItems where+ parseJSON (Bool b) = pure (OpenApiItemsBoolean b)+ parseJSON js@(Object _) = OpenApiItemsObject <$> parseJSON js+ parseJSON _ = fail "items must be a schema object or a boolean"++instance FromJSON Components where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON MimeList where+ parseJSON js = MimeList . map fromString <$> parseJSON js++instance FromJSON Param where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Responses where+ parseJSON (Object o) =+ Responses+ <$> o .:? "default"+ <*> parseJSON (Object (deleteKey "default" o))+ parseJSON _ = empty++instance FromJSON Example where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Response where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Operation where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON PathItem where+ parseJSON = withObject "PathItem" $ \o ->+ sopOpenApiGenericParseJSON (Object (applyKeyRenamesParseJSON pathItemDollarKeyRenames o))++instance FromJSON SecurityDefinitions where+ parseJSON js = SecurityDefinitions <$> parseJSON js++instance FromJSON RequestBody where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON MediaTypeObject where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Encoding where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Link where+ parseJSON = sopOpenApiGenericParseJSON++instance FromJSON Reference where+ parseJSON (Object o) = Reference <$> o .: "$ref"+ parseJSON _ = empty++referencedParseJSON :: (FromJSON a) => Text -> Value -> JSON.Parser (Referenced a)+referencedParseJSON prefix js@(Object o) = do+ ms <- o .:? "$ref"+ case ms of+ Nothing -> Inline <$> parseJSON js+ Just s -> case Text.stripPrefix prefix s of+ -- Pure component reference (sole @$ref@ key, value under the component+ -- prefix) stays a 'Ref'. Anything else — siblings present, or a @$ref@ that+ -- does not target a component (e.g. @#/$defs/A@) — is a JSON Schema 2020-12+ -- inline schema that carries @$ref@ alongside other keywords (see Decision Log).+ Just suffix | KeyMap.size o == 1 -> pure (Ref (Reference suffix))+ _ -> Inline <$> parseJSON js+-- JSON Schema 2020-12 boolean schemas: @true@ accepts everything, @false@ rejects+-- everything. Decode them to canonical inline schemas (see Decision Log).+referencedParseJSON _ (Bool True) = Inline <$> parseJSON (Object mempty)+referencedParseJSON _ (Bool False) = Inline <$> parseJSON (object ["not" .= object []])+referencedParseJSON _ _ = fail "referenceParseJSON: not an object or boolean"++instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/components/schemas/"++instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/components/parameters/"++instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/components/responses/"++instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/components/requestBodies/"++instance FromJSON (Referenced Example) where parseJSON = referencedParseJSON "#/components/examples/"++instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "#/components/headers/"++instance FromJSON (Referenced Link) where parseJSON = referencedParseJSON "#/components/links/"++instance FromJSON (Referenced Callback) where parseJSON = referencedParseJSON "#/components/callbacks/"++instance FromJSON (Referenced PathItem) where parseJSON = referencedParseJSON "#/components/pathItems/"++instance FromJSON Xml where+ parseJSON = genericParseJSON (jsonPrefix "xml")++instance FromJSON AdditionalProperties where+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js++-- | All strings are parsed as expressions+instance FromJSON ExpressionOrValue where+ parseJSON (String expr) = pure $ Expression expr+ parseJSON v = pure $ Value v++instance FromJSON Callback where+ parseJSON = fmap Callback . parseJSON++instance HasOpenApiAesonOptions Server where+ openApiAesonOptions _ = mkOpenApiAesonOptions "server"++instance HasOpenApiAesonOptions Components where+ openApiAesonOptions _ = mkOpenApiAesonOptions "components"++instance HasOpenApiAesonOptions Header where+ openApiAesonOptions _ = mkOpenApiAesonOptions "header"++instance (AesonDefaultValue p) => HasOpenApiAesonOptions (OAuth2Flow p) where+ openApiAesonOptions _ = mkOpenApiAesonOptions "oauth2" & saoSubObject ?~ "params"++instance HasOpenApiAesonOptions OAuth2Flows where+ openApiAesonOptions _ = mkOpenApiAesonOptions "oauth2Flows"++instance HasOpenApiAesonOptions Operation where+ openApiAesonOptions _ = mkOpenApiAesonOptions "operation"++instance HasOpenApiAesonOptions Param where+ openApiAesonOptions _ = mkOpenApiAesonOptions "param"++instance HasOpenApiAesonOptions PathItem where+ openApiAesonOptions _ = mkOpenApiAesonOptions "pathItem"++instance HasOpenApiAesonOptions Response where+ openApiAesonOptions _ = mkOpenApiAesonOptions "response"++instance HasOpenApiAesonOptions RequestBody where+ openApiAesonOptions _ = mkOpenApiAesonOptions "requestBody"++instance HasOpenApiAesonOptions MediaTypeObject where+ openApiAesonOptions _ = mkOpenApiAesonOptions "mediaTypeObject"++instance HasOpenApiAesonOptions Responses where+ openApiAesonOptions _ = mkOpenApiAesonOptions "responses" & saoSubObject ?~ "responses"++instance HasOpenApiAesonOptions SecurityScheme where+ openApiAesonOptions _ = mkOpenApiAesonOptions "securityScheme" & saoSubObject ?~ "type"++instance HasOpenApiAesonOptions Schema where+ openApiAesonOptions _ = mkOpenApiAesonOptions "schema" & saoSubObject ?~ "paramSchema"++instance HasOpenApiAesonOptions OpenApiSpecVersion where+ openApiAesonOptions _ = mkOpenApiAesonOptions "openapi"++instance HasOpenApiAesonOptions OpenApi where+ openApiAesonOptions _ = mkOpenApiAesonOptions "openApi"++instance HasOpenApiAesonOptions Example where+ openApiAesonOptions _ = mkOpenApiAesonOptions "example"++instance HasOpenApiAesonOptions Encoding where+ openApiAesonOptions _ = mkOpenApiAesonOptions "encoding"++instance HasOpenApiAesonOptions Link where+ openApiAesonOptions _ = mkOpenApiAesonOptions "link"++instance AesonDefaultValue Version where+ defaultValue = Just (makeVersion [3, 1, 0])++instance AesonDefaultValue OpenApiSpecVersion++instance AesonDefaultValue Server++instance AesonDefaultValue Components++instance AesonDefaultValue OAuth2ImplicitFlow++instance AesonDefaultValue OAuth2PasswordFlow++instance AesonDefaultValue OAuth2ClientCredentialsFlow++instance AesonDefaultValue OAuth2AuthorizationCodeFlow++instance (AesonDefaultValue p) => AesonDefaultValue (OAuth2Flow p)++instance AesonDefaultValue Responses++instance AesonDefaultValue SecuritySchemeType++instance AesonDefaultValue OpenApiType++instance AesonDefaultValue MimeList where defaultValue = Just mempty++instance AesonDefaultValue Info++instance AesonDefaultValue ParamLocation++instance AesonDefaultValue Link++instance AesonDefaultValue SecurityDefinitions where+ defaultValue = Just mempty
+ src/Data/OpenApi/Internal/AesonUtils.hs view
@@ -0,0 +1,355 @@+-- |+-- Module: Data.OpenApi.Internal.AesonUtils+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Internal generic-SOP helpers for deriving the library's aeson instances. No+-- API stability guarantees.+module Data.OpenApi.Internal.AesonUtils+ ( -- * Generic functions+ AesonDefaultValue (..),+ sopOpenApiGenericToJSON,+ sopOpenApiGenericToEncoding,+ sopOpenApiGenericToJSONWithOpts,+ sopOpenApiGenericParseJSON,++ -- * Options+ HasOpenApiAesonOptions (..),+ OpenApiAesonOptions,+ mkOpenApiAesonOptions,+ saoPrefix,+ saoAdditionalPairs,+ saoSubObject,++ -- * Dollar-prefixed keys (JSON Schema 2020-12: $id, $ref, $defs, …)+ applyKeyRenamesToJSON,+ applyKeyRenamesParseJSON,+ )+where++import Control.Applicative ((<|>))+import Control.Lens (makeLenses, (^.))+import Control.Monad (unless)+import Data.Aeson (Encoding, FromJSON (..), Object, Series, ToJSON (..), Value (..), object, pairs, withObject, (.!=), (.:), (.:?), (.=))+import Data.Aeson.Types (Pair, Parser)+import Data.Char (isUpper, toLower)+import Data.Foldable (foldl', traverse_)+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrd+import Data.HashSet.InsOrd qualified as InsOrdHS+import Data.OpenApi.Aeson.Compat (deleteKey, insertKey, keyToString, lookupKey, objectToList, stringToKey)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Generics.SOP+import Prelude.Compat+import Prelude ()++-------------------------------------------------------------------------------+-- Dollar-prefixed keys (JSON Schema 2020-12)+-------------------------------------------------------------------------------++-- | Rewrite a generated JSON 'Value': for each @(plain, dollar)@ pair, if the+-- top-level object has the @plain@ key, move its value to the @dollar@ key. The+-- generic field-name rule cannot emit a key beginning with @$@, so this post-pass+-- injects them (e.g. @"ref"@ → @"$ref"@). Non-object values are returned unchanged.+applyKeyRenamesToJSON :: [(Text, Text)] -> Value -> Value+applyKeyRenamesToJSON renames (Object o) = Object (foldl' renameOne o renames)+ where+ renameOne obj (plain, dollar) =+ case lookupKey plain obj of+ Nothing -> obj+ Just v -> insertKey dollar v (deleteKey (stringToKey (T.unpack plain)) obj)+applyKeyRenamesToJSON _ v = v++-- | The inverse of 'applyKeyRenamesToJSON': move each @dollar@ key back to its+-- @plain@ key before the generic parser runs (e.g. @"$ref"@ → @"ref"@).+applyKeyRenamesParseJSON :: [(Text, Text)] -> Object -> Object+applyKeyRenamesParseJSON renames o = foldl' renameOne o renames+ where+ renameOne obj (plain, dollar) =+ case lookupKey dollar obj of+ Nothing -> obj+ Just v -> insertKey plain v (deleteKey (stringToKey (T.unpack dollar)) obj)++-------------------------------------------------------------------------------+-- OpenApiAesonOptions+-------------------------------------------------------------------------------++data OpenApiAesonOptions = OpenApiAesonOptions+ { _saoPrefix :: String,+ _saoAdditionalPairs :: [Pair],+ _saoSubObject :: Maybe String+ }++mkOpenApiAesonOptions ::+ -- | prefix+ String ->+ OpenApiAesonOptions+mkOpenApiAesonOptions pfx = OpenApiAesonOptions pfx [] Nothing++makeLenses ''OpenApiAesonOptions++class (Generic a, All2 AesonDefaultValue (Code a)) => HasOpenApiAesonOptions a where+ openApiAesonOptions :: Proxy a -> OpenApiAesonOptions++ -- So far we use only default definitions+ aesonDefaults :: Proxy a -> POP Maybe (Code a)+ aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue++-------------------------------------------------------------------------------+-- Generics+-------------------------------------------------------------------------------++class AesonDefaultValue a where+ defaultValue :: Maybe a+ defaultValue = Nothing++instance AesonDefaultValue Text where defaultValue = Nothing++instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing++instance AesonDefaultValue [a] where defaultValue = Just []++instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty++instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty++instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty++-------------------------------------------------------------------------------+-- ToJSON+-------------------------------------------------------------------------------++-- | Generic serialisation for OpenAPI records.+--+-- Features+--+-- * omits nulls, empty objects and empty arrays (configurable)+-- * possible to add fields+-- * possible to merge sub-object+sopOpenApiGenericToJSON ::+ forall a xs.+ ( HasDatatypeInfo a,+ HasOpenApiAesonOptions a,+ All2 ToJSON (Code a),+ All2 Eq (Code a),+ Code a ~ '[xs]+ ) =>+ a ->+ Value+sopOpenApiGenericToJSON x =+ let ps = sopOpenApiGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)+ in object (opts ^. saoAdditionalPairs ++ ps)+ where+ proxy = Proxy :: Proxy a+ opts = openApiAesonOptions proxy++-- | *TODO:* This is only used by ToJSON (ParamSchema for the schema kind)+--+-- Also uses default `aesonDefaults`+sopOpenApiGenericToJSONWithOpts ::+ forall a xs.+ ( Generic a,+ All2 AesonDefaultValue (Code a),+ HasDatatypeInfo a,+ All2 ToJSON (Code a),+ All2 Eq (Code a),+ Code a ~ '[xs]+ ) =>+ OpenApiAesonOptions ->+ a ->+ Value+sopOpenApiGenericToJSONWithOpts opts x =+ let ps = sopOpenApiGenericToJSON' opts (from x) (datatypeInfo proxy) defs+ in object (opts ^. saoAdditionalPairs ++ ps)+ where+ proxy = Proxy :: Proxy a+ defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue++sopOpenApiGenericToJSON' ::+ (All2 ToJSON '[xs], All2 Eq '[xs]) =>+ OpenApiAesonOptions ->+ SOP I '[xs] ->+ DatatypeInfo '[xs] ->+ POP Maybe '[xs] ->+ [Pair]+sopOpenApiGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =+ sopOpenApiGenericToJSON'' opts fields fieldsInfo defs+sopOpenApiGenericToJSON' _ _ _ _ = error "sopOpenApiGenericToJSON: unsupported type"++sopOpenApiGenericToJSON'' ::+ (All ToJSON xs, All Eq xs) =>+ OpenApiAesonOptions ->+ NP I xs ->+ NP FieldInfo xs ->+ NP Maybe xs ->+ [Pair]+sopOpenApiGenericToJSON'' (OpenApiAesonOptions prefix _ sub) = go+ where+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]+ go Nil Nil Nil = []+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)+ | Just name' == sub = case json of+ Object m -> objectToList m ++ rest+ Null -> rest+ _ -> error $ "sopOpenApiGenericToJSON: subjson is not an object: " ++ show json+ -- If default value: omit it.+ | Just x == def =+ rest+ | otherwise =+ (stringToKey name', json) : rest+ where+ json = toJSON x+ name' = fieldNameModifier name+ rest = go xs names defs++ fieldNameModifier = modifier . drop 1+ modifier = lowerFirstUppers . drop (length prefix)+ lowerFirstUppers s = map toLower x ++ y+ where+ (x, y) = span isUpper s++-------------------------------------------------------------------------------+-- FromJSON+-------------------------------------------------------------------------------++sopOpenApiGenericParseJSON ::+ forall a xs.+ ( HasDatatypeInfo a,+ HasOpenApiAesonOptions a,+ All2 FromJSON (Code a),+ All2 Eq (Code a),+ Code a ~ '[xs]+ ) =>+ Value ->+ Parser a+sopOpenApiGenericParseJSON = withObject "OpenAPI Record Object" $ \obj ->+ let ps = sopOpenApiGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)+ in do+ traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)+ to <$> ps+ where+ proxy = Proxy :: Proxy a+ opts = openApiAesonOptions proxy++ parseAdditionalField :: Object -> Pair -> Parser ()+ parseAdditionalField obj (k, v) = do+ v' <- obj .: k+ unless (v == v')+ $ fail+ $ "Additonal field don't match for key "+ ++ keyToString k+ ++ ": "+ ++ show v+ ++ " /= "+ ++ show v'++sopOpenApiGenericParseJSON' ::+ (All2 FromJSON '[xs], All2 Eq '[xs]) =>+ OpenApiAesonOptions ->+ Object ->+ DatatypeInfo '[xs] ->+ POP Maybe '[xs] ->+ Parser (SOP I '[xs])+sopOpenApiGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =+ SOP . Z <$> sopOpenApiGenericParseJSON'' opts obj fieldsInfo defs+sopOpenApiGenericParseJSON' _ _ _ _ = error "sopOpenApiGenericParseJSON: unsupported type"++sopOpenApiGenericParseJSON'' ::+ (All FromJSON xs, All Eq xs) =>+ OpenApiAesonOptions ->+ Object ->+ NP FieldInfo xs ->+ NP Maybe xs ->+ Parser (NP I xs)+sopOpenApiGenericParseJSON'' (OpenApiAesonOptions prefix _ sub) obj = go+ where+ go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)+ go Nil Nil = pure Nil+ go (FieldInfo name :* names) (def :* defs)+ | Just name' == sub =+ -- Note: we might strip fields of outer structure.+ cons <$> (withDef $ parseJSON $ Object obj) <*> rest+ | otherwise = case def of+ Just def' -> cons <$> obj .:? stringToKey name' .!= def' <*> rest+ Nothing -> cons <$> obj .: stringToKey name' <*> rest+ where+ cons h t = I h :* t+ name' = fieldNameModifier name+ rest = go names defs++ withDef = case def of+ Just def' -> (<|> pure def')+ Nothing -> id++ fieldNameModifier = modifier . drop 1+ modifier = lowerFirstUppers . drop (length prefix)+ lowerFirstUppers s = map toLower x ++ y+ where+ (x, y) = span isUpper s++-------------------------------------------------------------------------------+-- ToEncoding+-------------------------------------------------------------------------------++sopOpenApiGenericToEncoding ::+ forall a xs.+ ( HasDatatypeInfo a,+ HasOpenApiAesonOptions a,+ All2 ToJSON (Code a),+ All2 Eq (Code a),+ Code a ~ '[xs]+ ) =>+ a ->+ Encoding+sopOpenApiGenericToEncoding x =+ let ps = sopOpenApiGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)+ in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)+ where+ proxy = Proxy :: Proxy a+ opts = openApiAesonOptions proxy++pairsToSeries :: [Pair] -> Series+pairsToSeries = foldMap (\(k, v) -> (k .= v))++sopOpenApiGenericToEncoding' ::+ (All2 ToJSON '[xs], All2 Eq '[xs]) =>+ OpenApiAesonOptions ->+ SOP I '[xs] ->+ DatatypeInfo '[xs] ->+ POP Maybe '[xs] ->+ Series+sopOpenApiGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =+ sopOpenApiGenericToEncoding'' opts fields fieldsInfo defs+sopOpenApiGenericToEncoding' _ _ _ _ = error "sopOpenApiGenericToEncoding: unsupported type"++sopOpenApiGenericToEncoding'' ::+ (All ToJSON xs, All Eq xs) =>+ OpenApiAesonOptions ->+ NP I xs ->+ NP FieldInfo xs ->+ NP Maybe xs ->+ Series+sopOpenApiGenericToEncoding'' (OpenApiAesonOptions prefix _ sub) = go+ where+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series+ go Nil Nil Nil = mempty+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)+ | Just name' == sub = case toJSON x of+ Object m -> pairsToSeries (objectToList m) <> rest+ Null -> rest+ _ -> error $ "sopOpenApiGenericToJSON: subjson is not an object: " ++ show (toJSON x)+ -- If default value: omit it.+ | Just x == def =+ rest+ | otherwise =+ (stringToKey name' .= x) <> rest+ where+ name' = fieldNameModifier name+ rest = go xs names defs++ fieldNameModifier = modifier . drop 1+ modifier = lowerFirstUppers . drop (length prefix)+ lowerFirstUppers s = map toLower x ++ y+ where+ (x, y) = span isUpper s
+ src/Data/OpenApi/Internal/ParamSchema.hs view
@@ -0,0 +1,386 @@+-- Generic a is redundant in ToParamSchema a default imple+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+-- For TypeErrors+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}++-- |+-- Module: Data.OpenApi.Internal.ParamSchema+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Internal module implementing 'ToParamSchema' generic derivation. No API+-- stability guarantees — import "Data.OpenApi.ParamSchema" instead.+module Data.OpenApi.Internal.ParamSchema where++import Control.Lens+import Data.Aeson (ToJSON (..))+import Data.ByteString qualified as BS+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Fixed (Fixed, HasResolution (..), Pico)+import Data.Int+import Data.Kind (Type)+import Data.Monoid+import Data.OpenApi.Internal+import Data.OpenApi.Lens+import Data.OpenApi.SchemaOptions+import Data.Proxy+import Data.Scientific+import Data.Set (Set)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time+import Data.UUID.Types (UUID)+import Data.Vector qualified as V+import Data.Vector.Primitive qualified as VP+import Data.Vector.Storable qualified as VS+import Data.Vector.Unboxed qualified as VU+import Data.Version (Version)+import Data.Word+import GHC.Generics+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Numeric.Natural.Compat (Natural)+import Web.Cookie (SetCookie)+import "unordered-containers" Data.HashSet (HashSet)++-- | Default schema for binary data (any sequence of octets).+binarySchema :: Schema+binarySchema =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ "binary"++-- | Default schema for binary data (base64 encoded).+byteSchema :: Schema+byteSchema =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ "byte"++-- | Default schema for password string.+-- @"password"@ format is used to hint UIs the input needs to be obscured.+passwordSchema :: Schema+passwordSchema =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ "password"++-- | Convert a type into a plain @'Schema'@.+--+-- In previous versions of the package there was a separate type called @ParamSchema@, which was+-- included in a greater 'Schema'. Now this is a single class, but distinction for schema generators+-- for "simple" types is preserved.+--+-- 'ToParamSchema' is suited only for primitive-like types without nested fields and such.+--+-- An example type and instance:+--+-- @+-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals+--+-- import Control.Lens+--+-- data Direction = Up | Down+--+-- instance ToParamSchema Direction where+-- toParamSchema _ = mempty+-- & type_ ?~ OpenApiTypeSingle OpenApiString+-- & enum_ ?~ [ \"Up\", \"Down\" ]+-- @+--+-- Instead of manually writing your @'ToParamSchema'@ instance you can+-- use a default generic implementation of @'toParamSchema'@.+--+-- To do that, simply add @deriving 'Generic'@ clause to your datatype+-- and declare a @'ToParamSchema'@ instance for your datatype without+-- giving definition for @'toParamSchema'@.+--+-- For instance, the previous example can be simplified into this:+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- import GHC.Generics (Generic)+--+-- data Direction = Up | Down deriving Generic+--+-- instance ToParamSchema Direction+-- @+class ToParamSchema a where+ -- | Convert a type into a plain parameter schema.+ --+ -- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy Integer)+ -- {+ -- "type": "integer"+ -- }+ toParamSchema :: Proxy a -> Schema+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema+ toParamSchema = genericToParamSchema defaultSchemaOptions++instance {-# OVERLAPPING #-} ToParamSchema String where+ toParamSchema _ = mempty & type_ ?~ OpenApiTypeSingle OpenApiString++instance ToParamSchema Bool where+ toParamSchema _ = mempty & type_ ?~ OpenApiTypeSingle OpenApiBoolean++instance ToParamSchema Integer where+ toParamSchema _ = mempty & type_ ?~ OpenApiTypeSingle OpenApiInteger++instance ToParamSchema Natural where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & minimum_ ?~ 0++-- 3.1: exclusiveMinimum is numeric, not a boolean flag. A Natural is >= 0,+-- which is exactly @minimum: 0@ with no exclusiveMinimum.++instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral++instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral++instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral++instance ToParamSchema Int32 where+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"++instance ToParamSchema Int64 where+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"++instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral++instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral++instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral++instance ToParamSchema Word32 where+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"++instance ToParamSchema Word64 where+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"++-- | Default plain schema for @'Bounded'@, @'Integral'@ types.+--+-- >>> BSL.putStrLn $ encodePretty $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)+-- {+-- "maximum": 127,+-- "minimum": -128,+-- "type": "integer"+-- }+toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema+toParamSchemaBoundedIntegral _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & minimum_ ?~ fromInteger (toInteger (minBound :: a))+ & maximum_ ?~ fromInteger (toInteger (maxBound :: a))++instance ToParamSchema Char where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & maxLength ?~ 1+ & minLength ?~ 1++instance ToParamSchema Scientific where+ toParamSchema _ = mempty & type_ ?~ OpenApiTypeSingle OpenApiNumber++instance (HasResolution a) => ToParamSchema (Fixed a) where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiNumber+ & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))++instance ToParamSchema Double where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiNumber+ & format ?~ "double"++instance ToParamSchema Float where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiNumber+ & format ?~ "float"++timeParamSchema :: String -> Schema+timeParamSchema fmt =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ T.pack fmt++-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.+instance ToParamSchema Day where+ toParamSchema _ = timeParamSchema "date"++-- |+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format+-- Just "hh:MM:ss"+instance ToParamSchema TimeOfDay where+ toParamSchema _ = timeParamSchema "hh:MM:ss"++-- |+-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format+-- Just "yyyy-mm-ddThh:MM:ss"+instance ToParamSchema LocalTime where+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss"++-- |+-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format+-- Just "date-time"+instance ToParamSchema ZonedTime where+ toParamSchema _ = timeParamSchema "date-time"++-- |+-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format+-- Just "yyyy-mm-ddThh:MM:ssZ"+instance ToParamSchema UTCTime where+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"++instance ToParamSchema NominalDiffTime where+ toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)++instance ToParamSchema T.Text where+ toParamSchema _ = toParamSchema (Proxy :: Proxy String)++instance ToParamSchema TL.Text where+ toParamSchema _ = toParamSchema (Proxy :: Proxy String)++instance ToParamSchema Version where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & pattern ?~ "^\\d+(\\.\\d+)*$"++instance ToParamSchema SetCookie where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString++type family ToParamSchemaByteStringError bs where+ ToParamSchemaByteStringError bs =+ TypeError+ ( 'Text "Impossible to have an instance "+ :<>: ShowType (ToParamSchema bs)+ :<>: Text "."+ :$$: 'Text "Please, use a newtype wrapper around "+ :<>: ShowType bs+ :<>: Text " instead."+ :$$: 'Text "Consider using byteParamSchema or binaryParamSchemaemplates."+ )++instance (ToParamSchemaByteStringError BS.ByteString) => ToParamSchema BS.ByteString where toParamSchema = error "impossible"++instance (ToParamSchemaByteStringError BSL.ByteString) => ToParamSchema BSL.ByteString where toParamSchema = error "impossible"++instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)++instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)++instance (ToParamSchema a) => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)++instance (ToParamSchema a) => ToParamSchema (Product a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)++instance (ToParamSchema a) => ToParamSchema (First a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)++instance (ToParamSchema a) => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)++instance (ToParamSchema a) => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)++instance (ToParamSchema a) => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)++instance (ToParamSchema a) => ToParamSchema [a] where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiArray+ & items ?~ OpenApiItemsObject (Inline $ toParamSchema (Proxy :: Proxy a))++instance (ToParamSchema a) => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])++instance (ToParamSchema a) => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])++instance (ToParamSchema a) => ToParamSchema (VS.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])++instance (ToParamSchema a) => ToParamSchema (VU.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])++instance (ToParamSchema a) => ToParamSchema (Set a) where+ toParamSchema _ =+ toParamSchema (Proxy :: Proxy [a])+ & uniqueItems ?~ True++instance (ToParamSchema a) => ToParamSchema (HashSet a) where+ toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))++-- |+-- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy ())+-- {+-- "enum": [+-- "_"+-- ],+-- "type": "string"+-- }+instance ToParamSchema () where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & enum_ ?~ ["_"]++instance ToParamSchema UUID where+ toParamSchema _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ "uuid"++-- | A configurable generic @'Schema'@ creator.+--+-- >>> :set -XDeriveGeneric+-- >>> data Color = Red | Blue deriving Generic+-- >>> BSL.putStrLn $ encodePretty $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)+-- {+-- "enum": [+-- "Red",+-- "Blue"+-- ],+-- "type": "string"+-- }+genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema+genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty++class GToParamSchema (f :: Type -> Type) where+ gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema++instance (GToParamSchema f) => GToParamSchema (D1 d f) where+ gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)++instance (Constructor c) => GToParamSchema (C1 c U1) where+ gtoParamSchema = genumParamSchema++instance (GToParamSchema f) => GToParamSchema (C1 c (S1 s f)) where+ gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)++instance (ToParamSchema c) => GToParamSchema (K1 i c) where+ gtoParamSchema _ _ _ = toParamSchema (Proxy :: Proxy c)++instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where+ gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))++class GEnumParamSchema (f :: Type -> Type) where+ genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema++instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where+ genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)++instance (Constructor c) => GEnumParamSchema (C1 c U1) where+ genumParamSchema opts _ s =+ s+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & enum_ %~ addEnumValue tag+ where+ tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))++ addEnumValue x Nothing = Just [x]+ addEnumValue x (Just xs) = Just (x : xs)++data Proxy3 a b c = Proxy3++-- $setup+-- >>> import Data.Aeson (encode)+-- >>> import Data.OpenApi.Internal.Utils
+ src/Data/OpenApi/Internal/Schema.hs view
@@ -0,0 +1,1236 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+-- For TypeErrors+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}++-- |+-- Module: Data.OpenApi.Internal.Schema+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Internal module implementing 'ToSchema' generic derivation. No API stability+-- guarantees — import "Data.OpenApi.Schema" instead.+module Data.OpenApi.Internal.Schema where++import Control.Applicative ((<|>))+import Control.Lens hiding (allOf, anyOf)+import Control.Monad+import Control.Monad.Writer hiding (First, Last)+import Data.Aeson+ ( Object (..),+ SumEncoding (..),+ ToJSON (..),+ ToJSONKey (..),+ ToJSONKeyFunction (..),+ Value (..),+ )+import Data.ByteString qualified as BS+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Char+import Data.Data (Data)+import Data.Data.Lens (template)+import Data.Fixed (Fixed, HasResolution, Pico)+import Data.Foldable (traverse_)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.Int+import Data.IntMap (IntMap)+import Data.IntSet (IntSet)+import Data.Kind (Type)+import Data.List (sort)+import Data.List.NonEmpty.Compat (NonEmpty)+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)+import Data.OpenApi.Declare+import Data.OpenApi.Internal+import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))+import Data.OpenApi.Internal.TypeShape+import Data.OpenApi.Lens hiding (name, schema)+import Data.OpenApi.Lens qualified as OpenApiLens+import Data.OpenApi.SchemaOptions+import Data.Proxy+import Data.Scientific (Scientific)+import Data.Semigroup+import Data.Set (Set)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time+import Data.UUID.Types qualified as UUID+import Data.Vector qualified as V+import Data.Vector.Primitive qualified as VP+import Data.Vector.Storable qualified as VS+import Data.Vector.Unboxed qualified as VU+import Data.Version (Version)+import Data.Word+import GHC.Generics+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Numeric.Natural.Compat (Natural)+import Prelude.Compat+import Type.Reflection (Typeable, typeRep)+import "unordered-containers" Data.HashSet (HashSet)+import "unordered-containers" Data.HashSet qualified as HashSet+import Prelude ()++unnamed :: Schema -> NamedSchema+unnamed schema = NamedSchema Nothing schema++named :: T.Text -> Schema -> NamedSchema+named name schema = NamedSchema (Just name) schema++plain :: Schema -> Declare (Definitions Schema) NamedSchema+plain = pure . unnamed++unname :: NamedSchema -> NamedSchema+unname (NamedSchema _ schema) = unnamed schema++rename :: Maybe T.Text -> NamedSchema -> NamedSchema+rename name (NamedSchema _ schema) = NamedSchema name schema++-- $setup+-- >>> import Data.Aeson.Types (toJSONKeyText)+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL+-- >>> import Data.OpenApi.Internal+-- >>> import Data.OpenApi.Internal.Utils (encodePretty)+-- >>> import Data.OpenApi.Lens (name, schema)++-- | Convert a type into @Schema@.+--+-- An example type and instance:+--+-- @+-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals+-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists+--+-- import Control.Lens+-- import Data.Proxy+-- import Data.OpenApi+--+-- data Coord = Coord { x :: Double, y :: Double }+--+-- instance ToSchema Coord where+-- declareNamedSchema _ = do+-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)+-- return $ NamedSchema (Just \"Coord\") $ mempty+-- & type_ ?~ OpenApiTypeSingle OpenApiObject+-- & properties .~+-- [ (\"x\", doubleSchema)+-- , (\"y\", doubleSchema)+-- ]+-- & required .~ [ \"x\", \"y\" ]+-- @+--+-- Instead of manually writing your @'ToSchema'@ instance you can+-- use a default generic implementation of @'declareNamedSchema'@.+--+-- To do that, simply add @deriving 'Generic'@ clause to your datatype+-- and declare a @'ToSchema'@ instance for your datatype without+-- giving definition for @'declareNamedSchema'@.+--+-- For instance, the previous example can be simplified into this:+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- import GHC.Generics (Generic)+--+-- data Coord = Coord { x :: Double, y :: Double } deriving Generic+--+-- instance ToSchema Coord+-- @+class (Typeable a) => ToSchema a where+ -- | Convert a type into an optionally named schema+ -- together with all used definitions.+ -- Note that the schema itself is included in definitions+ -- only if it is recursive (and thus needs its definition in scope).+ declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema+ default declareNamedSchema ::+ (Generic a, GToSchema (Rep a)) =>+ Proxy a -> Declare (Definitions Schema) NamedSchema+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions++instance ToSchema TimeOfDay where+ declareNamedSchema _ =+ pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"+ & example ?~ toJSON (TimeOfDay 12 33 15)++-- | Convert a type into a schema and declare all used schema definitions.+declareSchema :: (ToSchema a) => Proxy a -> Declare (Definitions Schema) Schema+declareSchema = fmap _namedSchemaSchema . declareNamedSchema++-- | Convert a type into an optionally named schema.+--+-- >>> toNamedSchema (Proxy :: Proxy String) ^. name+-- Nothing+-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy String) ^. schema)+-- {+-- "type": "string"+-- }+--+-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name+-- Just "Day"+-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy Day) ^. schema)+-- {+-- "example": "2016-07-22",+-- "format": "date",+-- "type": "string"+-- }+toNamedSchema :: (ToSchema a) => Proxy a -> NamedSchema+toNamedSchema = undeclare . declareNamedSchema++-- | Get type's schema name according to its @'ToSchema'@ instance.+--+-- >>> schemaName (Proxy :: Proxy Int)+-- Nothing+--+-- >>> schemaName (Proxy :: Proxy UTCTime)+-- Just "UTCTime"+schemaName :: (ToSchema a) => Proxy a -> Maybe T.Text+schemaName = _namedSchemaName . toNamedSchema++-- | Convert a type into a schema.+--+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Int8)+-- {+-- "maximum": 127,+-- "minimum": -128,+-- "type": "integer"+-- }+--+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy [Day])+-- {+-- "items": {+-- "$ref": "#/components/schemas/Day"+-- },+-- "type": "array"+-- }+toSchema :: (ToSchema a) => Proxy a -> Schema+toSchema = _namedSchemaSchema . toNamedSchema++-- | Convert a type into a referenced schema if possible.+-- Only named schemas can be referenced, nameless schemas are inlined.+--+-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Integer)+-- {+-- "type": "integer"+-- }+--+-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Day)+-- {+-- "$ref": "#/components/schemas/Day"+-- }+toSchemaRef :: (ToSchema a) => Proxy a -> Referenced Schema+toSchemaRef = undeclare . declareSchemaRef++-- | Convert a type into a referenced schema if possible+-- and declare all used schema definitions.+-- Only named schemas can be referenced, nameless schemas are inlined.+--+-- Schema definitions are typically declared for every referenced schema.+-- If @'declareSchemaRef'@ returns a reference, a corresponding schema+-- will be declared (regardless of whether it is recusive or not).+declareSchemaRef :: (ToSchema a) => Proxy a -> Declare (Definitions Schema) (Referenced Schema)+declareSchemaRef proxy = do+ case toNamedSchema proxy of+ NamedSchema (Just name) schema -> do+ -- This check is very important as it allows generically+ -- derive used definitions for recursive schemas.+ -- Lazy Declare monad allows toNamedSchema to ignore+ -- any declarations (which would otherwise loop) and+ -- retrieve the schema and its name to check if we+ -- have already declared it.+ -- If we have, we don't need to declare anything for+ -- this schema this time and thus simply return the reference.+ known <- looks (InsOrdHashMap.member name)+ when (not known) $ do+ declare [(name, schema)]+ void $ declareNamedSchema proxy+ return $ Ref (Reference name)+ _ -> Inline <$> declareSchema proxy++-- | Inline any referenced schema if its name satisfies given predicate.+--+-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored+-- and schema stays referenced.+--+-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas+-- when inlining recursive schemas.+inlineSchemasWhen :: (Data s) => (T.Text -> Bool) -> (Definitions Schema) -> s -> s+inlineSchemasWhen p defs = template %~ deref+ where+ deref r@(Ref (Reference name))+ | p name =+ case InsOrdHashMap.lookup name defs of+ Just schema -> Inline (inlineSchemasWhen p defs schema)+ Nothing -> r+ | otherwise = r+ deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)++-- | Inline any referenced schema if its name is in the given list.+--+-- /NOTE:/ if a referenced schema is not found in definitions+-- it stays referenced even if it appears in the list of names.+--+-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas+-- when inlining recursive schemas.+inlineSchemas :: (Data s) => [T.Text] -> (Definitions Schema) -> s -> s+inlineSchemas names = inlineSchemasWhen (`elem` names)++-- | Inline all schema references for which the definition+-- can be found in @'Definitions'@.+--+-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas+-- when inlining recursive schemas.+inlineAllSchemas :: (Data s) => (Definitions Schema) -> s -> s+inlineAllSchemas = inlineSchemasWhen (const True)++-- | Convert a type into a schema without references.+--+-- >>> BSL.putStrLn $ encodePretty $ toInlinedSchema (Proxy :: Proxy [Day])+-- {+-- "items": {+-- "example": "2016-07-22",+-- "format": "date",+-- "type": "string"+-- },+-- "type": "array"+-- }+--+-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema+-- when inlining recursive schemas.+toInlinedSchema :: (ToSchema a) => Proxy a -> Schema+toInlinedSchema proxy = inlineAllSchemas defs schema+ where+ (defs, schema) = runDeclare (declareSchema proxy) mempty++-- | Inline all /non-recursive/ schemas for which the definition+-- can be found in @'Definitions'@.+inlineNonRecursiveSchemas :: (Data s) => (Definitions Schema) -> s -> s+inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs+ where+ nonRecursive name =+ case InsOrdHashMap.lookup name defs of+ Just schema -> name `notElem` execDeclare (usedNames schema) mempty+ Nothing -> False++ usedNames schema = traverse_ schemaRefNames (schema ^.. template)++ schemaRefNames :: Referenced Schema -> Declare [T.Text] ()+ schemaRefNames ref = case ref of+ Ref (Reference name) -> do+ seen <- looks (name `elem`)+ when (not seen) $ do+ declare [name]+ traverse_ usedNames (InsOrdHashMap.lookup name defs)+ Inline subschema -> usedNames subschema++-- | Make an unrestrictive sketch of a @Schema@ based on a @ToJSON@ instance.+-- Produced schema can be used for further refinement.+--+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema "hello"+-- {+-- "example": "hello",+-- "type": "string"+-- }+--+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (1, 2, 3)+-- {+-- "example": [+-- 1,+-- 2,+-- 3+-- ],+-- "items": {+-- "type": "number"+-- },+-- "type": "array"+-- }+--+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema ("Jack", 25)+-- {+-- "example": [+-- "Jack",+-- 25+-- ],+-- "prefixItems": [+-- {+-- "type": "string"+-- },+-- {+-- "type": "number"+-- }+-- ],+-- "type": "array"+-- }+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)+-- >>> instance ToJSON Person+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (Person "Jack" 25)+-- {+-- "example": {+-- "age": 25,+-- "name": "Jack"+-- },+-- "properties": {+-- "age": {+-- "type": "number"+-- },+-- "name": {+-- "type": "string"+-- }+-- },+-- "required": [+-- "age",+-- "name"+-- ],+-- "type": "object"+-- }+sketchSchema :: (ToJSON a) => a -> Schema+sketchSchema = sketch . toJSON+ where+ sketch Null = go Null+ sketch js@(Bool _) = go js+ sketch js = go js & example ?~ js++ go Null = mempty & type_ ?~ OpenApiTypeSingle OpenApiNull+ go (Bool _) = mempty & type_ ?~ OpenApiTypeSingle OpenApiBoolean+ go (String _) = mempty & type_ ?~ OpenApiTypeSingle OpenApiString+ go (Number _) = mempty & type_ ?~ OpenApiTypeSingle OpenApiNumber+ go (Array xs) =+ case ischema of+ -- homogeneous array: a single @items@ element schema describes every member.+ Just s ->+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiArray+ & items ?~ OpenApiItemsObject (Inline s)+ -- heterogeneous array: positional @prefixItems@ (JSON Schema 2020-12 tuple).+ -- Trailing elements are left unconstrained, matching the unrestrictive intent.+ Nothing ->+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiArray+ & prefixItems ?~ map Inline ys+ where+ ys = map go (V.toList xs)+ allSame = and ((zipWith (==)) ys (tail ys))++ ischema = case ys of+ (z : _) | allSame -> Just z+ _ -> Nothing+ go (Object o) =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & required .~ sort (objectKeys o)+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)++-- | Make a restrictive sketch of a @Schema@ based on a @ToJSON@ instance.+-- Produced schema uses as much constraints as possible.+--+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema "hello"+-- {+-- "enum": [+-- "hello"+-- ],+-- "maxLength": 5,+-- "minLength": 5,+-- "pattern": "hello",+-- "type": "string"+-- }+--+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (1, 2, 3)+-- {+-- "enum": [+-- [+-- 1,+-- 2,+-- 3+-- ]+-- ],+-- "items": false,+-- "maxItems": 3,+-- "minItems": 3,+-- "prefixItems": [+-- {+-- "enum": [+-- 1+-- ],+-- "maximum": 1,+-- "minimum": 1,+-- "multipleOf": 1,+-- "type": "number"+-- },+-- {+-- "enum": [+-- 2+-- ],+-- "maximum": 2,+-- "minimum": 2,+-- "multipleOf": 2,+-- "type": "number"+-- },+-- {+-- "enum": [+-- 3+-- ],+-- "maximum": 3,+-- "minimum": 3,+-- "multipleOf": 3,+-- "type": "number"+-- }+-- ],+-- "type": "array",+-- "uniqueItems": true+-- }+--+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema ("Jack", 25)+-- {+-- "enum": [+-- [+-- "Jack",+-- 25+-- ]+-- ],+-- "items": false,+-- "maxItems": 2,+-- "minItems": 2,+-- "prefixItems": [+-- {+-- "enum": [+-- "Jack"+-- ],+-- "maxLength": 4,+-- "minLength": 4,+-- "pattern": "Jack",+-- "type": "string"+-- },+-- {+-- "enum": [+-- 25+-- ],+-- "maximum": 25,+-- "minimum": 25,+-- "multipleOf": 25,+-- "type": "number"+-- }+-- ],+-- "type": "array",+-- "uniqueItems": true+-- }+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)+-- >>> instance ToJSON Person+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (Person "Jack" 25)+-- {+-- "enum": [+-- {+-- "age": 25,+-- "name": "Jack"+-- }+-- ],+-- "maxProperties": 2,+-- "minProperties": 2,+-- "properties": {+-- "age": {+-- "enum": [+-- 25+-- ],+-- "maximum": 25,+-- "minimum": 25,+-- "multipleOf": 25,+-- "type": "number"+-- },+-- "name": {+-- "enum": [+-- "Jack"+-- ],+-- "maxLength": 4,+-- "minLength": 4,+-- "pattern": "Jack",+-- "type": "string"+-- }+-- },+-- "required": [+-- "age",+-- "name"+-- ],+-- "type": "object"+-- }+sketchStrictSchema :: (ToJSON a) => a -> Schema+sketchStrictSchema = go . toJSON+ where+ go Null = mempty & type_ ?~ OpenApiTypeSingle OpenApiNull+ go js@(Bool _) =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiBoolean+ & enum_ ?~ [js]+ go js@(String s) =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & maxLength ?~ fromIntegral (T.length s)+ & minLength ?~ fromIntegral (T.length s)+ & pattern ?~ s+ & enum_ ?~ [js]+ go js@(Number n) =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiNumber+ & maximum_ ?~ n+ & minimum_ ?~ n+ & multipleOf ?~ n+ & enum_ ?~ [js]+ go js@(Array xs) =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiArray+ & maxItems ?~ fromIntegral sz+ & minItems ?~ fromIntegral sz+ -- Restrictive tuple: each element pinned positionally via @prefixItems@,+ -- with @items: false@ forbidding any element beyond the fixed length.+ & prefixItems ?~ map (Inline . go) (V.toList xs)+ & items ?~ OpenApiItemsBoolean False+ & uniqueItems ?~ allUnique+ & enum_ ?~ [js]+ where+ sz = length xs+ allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))+ go js@(Object o) =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & required .~ sort names+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)+ & maxProperties ?~ fromIntegral (length names)+ & minProperties ?~ fromIntegral (length names)+ & enum_ ?~ [js]+ where+ names = objectKeys o++class GToSchema (f :: Type -> Type) where+ gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema++instance {-# OVERLAPPABLE #-} (ToSchema a) => ToSchema [a] where+ declareNamedSchema _ = do+ ref <- declareSchemaRef (Proxy :: Proxy a)+ return $ unnamed $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiArray+ & items ?~ OpenApiItemsObject ref++instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Char where+ declareNamedSchema proxy =+ plain (paramSchemaToSchema proxy)+ & mapped . OpenApiLens.schema . example ?~ toJSON '?'++instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema++instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema++instance (ToSchema a) => ToSchema (Maybe a) where+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)++instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where+ -- To match Aeson instance+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions {sumEncoding = ObjectWithSingleField}++instance ToSchema () where+ declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)++-- | For @ToJSON@ instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.+instance ToSchema UUID.UUID where+ declareNamedSchema p =+ pure $ named "UUID" $ paramSchemaToSchema p+ & example ?~ toJSON (UUID.toText UUID.nil)++instance (ToSchema a, ToSchema b) => ToSchema (a, b) where+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions++instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions++instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions++instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions++instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions++instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions++timeSchema :: T.Text -> Schema+timeSchema fmt =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ fmt++-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.+instance ToSchema Day where+ declareNamedSchema _ =+ pure $ named "Day" $ timeSchema "date"+ & example ?~ toJSON (fromGregorian 2016 7 22)++-- |+-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format+-- Just "yyyy-mm-ddThh:MM:ss"+instance ToSchema LocalTime where+ declareNamedSchema _ =+ pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"+ & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))++-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.+instance ToSchema ZonedTime where+ declareNamedSchema _ =+ pure $ named "ZonedTime" $ timeSchema "date-time"+ & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))++instance ToSchema NominalDiffTime where+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)++-- |+-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format+-- Just "yyyy-mm-ddThh:MM:ssZ"+instance ToSchema UTCTime where+ declareNamedSchema _ =+ pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"+ & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)++instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema++type family ToSchemaByteStringError bs where+ ToSchemaByteStringError bs =+ TypeError+ ( Text "Impossible to have an instance "+ :<>: ShowType (ToSchema bs)+ :<>: Text "."+ :$$: Text "Please, use a newtype wrapper around "+ :<>: ShowType bs+ :<>: Text " instead."+ :$$: Text "Consider using byteSchema or binarySchema templates."+ )++instance (ToSchemaByteStringError BS.ByteString) => ToSchema BS.ByteString where declareNamedSchema = error "impossible"++instance (ToSchemaByteStringError BSL.ByteString) => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"++instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))++-- | NOTE: This schema does not account for the uniqueness of keys.+instance (ToSchema a) => ToSchema (IntMap a) where+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])++instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where+ declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of+ ToJSONKeyText _ _ -> declareObjectMapSchema+ ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])+ where+ declareObjectMapSchema = do+ schema <- declareSchemaRef (Proxy :: Proxy v)+ return $ unnamed $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & additionalProperties ?~ AdditionalPropertiesSchema schema++instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))++instance {-# OVERLAPPING #-} ToSchema Object where+ declareNamedSchema _ =+ pure $ NamedSchema (Just "Object") $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & description ?~ "Arbitrary JSON object."+ & additionalProperties ?~ AdditionalPropertiesAllowed True++instance (ToSchema a) => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])++instance (ToSchema a) => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])++instance (ToSchema a) => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])++instance (ToSchema a) => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])++instance (ToSchema a) => ToSchema (Set a) where+ declareNamedSchema _ = do+ schema <- declareSchema (Proxy :: Proxy [a])+ return $ unnamed $ schema+ & uniqueItems ?~ True++instance (ToSchema a) => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))++-- | @since 2.2.1+instance (ToSchema a) => ToSchema (NonEmpty a) where+ declareNamedSchema _ = do+ schema <- declareSchema (Proxy :: Proxy [a])+ return $ unnamed $ schema+ & minItems .~ Just 1++instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema++instance (ToSchema a) => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)++instance (ToSchema a) => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)++instance (ToSchema a) => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)++instance (ToSchema a) => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)++instance (ToSchema a) => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)++instance (ToSchema a) => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)++-- | Default schema for @'Bounded'@, @'Integral'@ types.+--+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)+-- {+-- "maximum": 32767,+-- "minimum": -32768,+-- "type": "integer"+-- }+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema+toSchemaBoundedIntegral _ =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & minimum_ ?~ fromInteger (toInteger (minBound :: a))+ & maximum_ ?~ fromInteger (toInteger (maxBound :: a))++-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.+genericToNamedSchemaBoundedIntegral ::+ forall a d f.+ ( Bounded a,+ Integral a,+ Generic a,+ Rep a ~ D1 d f,+ Datatype d+ ) =>+ SchemaOptions -> Proxy a -> NamedSchema+genericToNamedSchemaBoundedIntegral opts proxy =+ genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)++-- | Declare a named schema for a @newtype@ wrapper.+genericDeclareNamedSchemaNewtype ::+ forall a d c s i inner.+ (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner)))) =>+ -- | How to derive the name.+ SchemaOptions ->+ -- | How to create a schema for the wrapped type.+ (Proxy inner -> Declare (Definitions Schema) Schema) ->+ Proxy a ->+ Declare (Definitions Schema) NamedSchema+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)++-- | Declare @Schema@ for a mapping with 'Bounded' 'Enum' keys.+-- This makes a much more useful schema when there aren't many options for key values.+--+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)+-- >>> instance ToJSON ButtonState+-- >>> instance ToSchema ButtonState+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)+-- >>> type ImageUrl = T.Text+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))+-- {+-- "properties": {+-- "Active": {+-- "type": "string"+-- },+-- "Disabled": {+-- "type": "string"+-- },+-- "Focus": {+-- "type": "string"+-- },+-- "Hover": {+-- "type": "string"+-- },+-- "Neutral": {+-- "type": "string"+-- }+-- },+-- "type": "object"+-- }+--+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.+declareSchemaBoundedEnumKeyMapping ::+ forall map key value.+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) =>+ Proxy (map key value) -> Declare (Definitions Schema) Schema+declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of+ ToJSONKeyText getKey _ -> objectSchema getKey+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])+ where+ objectSchema getKey = do+ valueRef <- declareSchemaRef (Proxy :: Proxy value)+ let allKeys = [minBound .. maxBound :: key]+ mkPair k = (keyToText $ getKey k, valueRef)+ return $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)++-- | A @Schema@ for a mapping with 'Bounded' 'Enum' keys.+-- This makes a much more useful schema when there aren't many options for key values.+--+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)+-- >>> instance ToJSON ButtonState+-- >>> instance ToSchema ButtonState+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)+-- >>> type ImageUrl = T.Text+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))+-- {+-- "properties": {+-- "Active": {+-- "type": "string"+-- },+-- "Disabled": {+-- "type": "string"+-- },+-- "Focus": {+-- "type": "string"+-- },+-- "Hover": {+-- "type": "string"+-- },+-- "Neutral": {+-- "type": "string"+-- }+-- },+-- "type": "object"+-- }+--+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.+toSchemaBoundedEnumKeyMapping ::+ forall map key value.+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) =>+ Proxy (map key value) -> Schema+toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping++-- | A configurable generic @Schema@ creator.+genericDeclareSchema ::+ (Generic a, GToSchema (Rep a), Typeable a) =>+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy++-- | A configurable generic @'NamedSchema'@ creator.+-- This function applied to @'defaultSchemaOptions'@+-- is used as the default for @'declareNamedSchema'@+-- when the type is an instance of @'Generic'@.+--+-- Default implementation will use the name from 'Typeable' instance, including concrete+-- instantioations of type variables.+--+-- For example:+--+-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))+-- Just "Either_Int_Bool"+genericDeclareNamedSchema ::+ forall a.+ (Generic a, GToSchema (Rep a), Typeable a) =>+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema+genericDeclareNamedSchema opts _ =+ rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty+ where+ unspace ' ' = '_'+ unspace x = x+ orig = fmap unspace $ show $ typeRep @a+ name = datatypeNameModifier opts orig++-- | Derive a 'Generic'-based name for a datatype and assign it to a given @Schema@.+genericNameSchema ::+ forall a d f.+ (Generic a, Rep a ~ D1 d f, Datatype d) =>+ SchemaOptions -> Proxy a -> Schema -> NamedSchema+genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))++gdatatypeSchemaName :: forall d. (Datatype d) => SchemaOptions -> Proxy d -> Maybe T.Text+gdatatypeSchemaName opts _ = case orig of+ (c : _) | isAlpha c && isUpper c -> Just (T.pack name)+ _ -> Nothing+ where+ orig = datatypeName (Proxy3 :: Proxy3 d f a)+ name = datatypeNameModifier opts orig++-- | Construct 'NamedSchema' using @ToParamSchema@.+paramSchemaToNamedSchema ::+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>+ SchemaOptions -> Proxy a -> NamedSchema+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)++-- | Construct @Schema@ using @ToParamSchema@.+paramSchemaToSchema :: (ToParamSchema a) => Proxy a -> Schema+paramSchemaToSchema = toParamSchema++nullarySchema :: Schema+nullarySchema =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiArray+ & maxItems ?~ 0++gtoNamedSchema :: (GToSchema f) => SchemaOptions -> Proxy f -> NamedSchema+gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty++gdeclareSchema :: (GToSchema f) => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema+gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty++instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where+ gdeclareNamedSchema opts _ schema = do+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema+ gdeclareNamedSchema opts (Proxy :: Proxy g) gschema++instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where+ gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s+ where+ name = gdatatypeSchemaName opts (Proxy :: Proxy d)++instance {-# OVERLAPPABLE #-} (GToSchema f) => GToSchema (C1 c f) where+ gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)++instance {-# OVERLAPPING #-} (Constructor c) => GToSchema (C1 c U1) where+ gdeclareNamedSchema = gdeclareNamedSumSchema++-- | Single field constructor.+instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where+ gdeclareNamedSchema opts _ s+ | unwrapUnaryRecords opts = fieldSchema+ | otherwise =+ case schema ^. prefixItems of+ -- A single-field non-record constructor was treated as a 1-tuple+ -- (one @prefixItems@ entry); unwrap it to the field's own schema, since+ -- aeson encodes such a constructor as the bare value, not a 1-element array.+ Just [_] -> fieldSchema+ _ -> do+ -- We have to run recordSchema instead of just using its defs,+ -- since those can be recursive and will lead to infinite loop,+ -- see https://github.com/biocad/openapi3/pull/37+ NamedSchema _ schema' <- recordSchema+ return (unnamed schema')+ where+ (_, NamedSchema _ schema) = runDeclare recordSchema mempty+ recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s+ fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s++gdeclareSchemaRef :: (GToSchema a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)+gdeclareSchemaRef opts proxy = do+ case gtoNamedSchema opts proxy of+ NamedSchema (Just name) schema -> do+ -- This check is very important as it allows generically+ -- derive used definitions for recursive schemas.+ -- Lazy Declare monad allows toNamedSchema to ignore+ -- any declarations (which would otherwise loop) and+ -- retrieve the schema and its name to check if we+ -- have already declared it.+ -- If we have, we don't need to declare anything for+ -- this schema this time and thus simply return the reference.+ known <- looks (InsOrdHashMap.member name)+ when (not known) $ do+ declare [(name, schema)]+ void $ gdeclareNamedSchema opts proxy mempty+ return $ Ref (Reference name)+ _ -> Inline <$> gdeclareSchema opts proxy++withFieldSchema ::+ forall proxy s f.+ (Selector s, GToSchema f) =>+ SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema+withFieldSchema opts _ isRequiredField schema = do+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)+ return+ $ if T.null fname+ then+ -- Positional tuple (unnamed product field): accumulate each member schema+ -- into @prefixItems@ and forbid trailing elements with @items: false@. This+ -- is the JSON Schema 2020-12 tuple form, so positional type information is+ -- preserved for validation and round-tripping.+ schema+ & type_ ?~ OpenApiTypeSingle OpenApiArray+ & prefixItems %~ Just . maybe [ref] (++ [ref])+ & items ?~ OpenApiItemsBoolean False+ & maxItems %~ Just . maybe 1 (+ 1) -- increment maxItems+ & minItems %~ Just . maybe 1 (+ 1) -- increment minItems+ else+ schema+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties . at fname ?~ ref+ & if isRequiredField+ then required %~ (++ [fname])+ else id+ where+ fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))++-- | Optional record fields.+instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False++-- | Record fields.+instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True++instance {-# OVERLAPPING #-} (ToSchema c) => GToSchema (K1 i (Maybe c)) where+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)++instance {-# OVERLAPPABLE #-} (ToSchema c) => GToSchema (K1 i c) where+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)++instance+ ( GSumToSchema f,+ GSumToSchema g+ ) =>+ GToSchema (f :+: g)+ where+ -- Aeson does not unwrap unary record in sum types.+ gdeclareNamedSchema opts = gdeclareNamedSumSchema (opts {unwrapUnaryRecords = False})++gdeclareNamedSumSchema :: (GSumToSchema f) => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema+gdeclareNamedSumSchema opts proxy _+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas)+ | otherwise = do+ (schemas, _) <- runWriterT declareSumSchema+ return $ unnamed $ mempty+ & oneOf ?~ (snd <$> schemas)+ where+ declareSumSchema = gsumToSchema opts proxy+ (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)++ toStringTag schemas =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & enum_ ?~ map (String . fst) sumSchemas++type AllNullary = All++class GSumToSchema (f :: Type -> Type) where+ gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)]++instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where+ gsumToSchema opts _ =+ (<>) <$> gsumToSchema opts (Proxy :: Proxy f) <*> gsumToSchema opts (Proxy :: Proxy g)++-- | Convert one component of the sum to schema, to be later combined with @oneOf@.+gsumConToSchemaWith ::+ forall c f.+ (GToSchema (C1 c f), Constructor c) =>+ Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema)+gsumConToSchemaWith ref opts _ = (tag, withTitle)+ where+ -- Give sub-schemas @title@ attribute with constructor name, if none present.+ -- This will look prettier in rendering tools.+ withTitle = case schema of+ Inline sub ->+ Inline $ sub+ & title %~ (<|> Just (T.pack constructorName))+ s -> s++ schema = case sumEncoding opts of+ TaggedObject tagField contentsField ->+ case ref of+ -- If subschema is an object and constructor is a record, we add tag directly+ -- to the record, as Aeson does it.+ Just (Inline sub)+ | (singleType =<< sub ^. type_) == Just OpenApiObject && isRecord ->+ Inline $ sub+ & required <>~ [T.pack tagField]+ & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString & enum_ ?~ [String tag])+ -- If it is not a record, we need to put subschema into "contents" field.+ _+ | not isRecord ->+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & required .~ [T.pack tagField]+ & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString & enum_ ?~ [String tag])+ -- If constructor is nullary, there is no content.+ & case ref of+ Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField])+ Nothing -> id+ -- In the remaining cases we combine "tag" object and "contents" object using allOf.+ _ ->+ Inline $ mempty+ & allOf+ ?~ [ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])+ & properties . at (T.pack tagField) ?~ Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString & enum_ ?~ [String tag])+ ]+ & if isRecord+ then allOf . _Just <>~ [refOrNullary]+ else allOf . _Just <>~ [Inline $ mempty & type_ ?~ OpenApiTypeSingle OpenApiObject & properties . at (T.pack contentsField) ?~ refOrNullary]+ UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.+ ObjectWithSingleField ->+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & required .~ [tag]+ & properties . at tag ?~ refOrNullary+ TwoElemArray -> error "unrepresentable in OpenAPI 3"++ constructorName = conName (Proxy3 :: Proxy3 c f p)+ tag = T.pack (constructorTagModifier opts constructorName)+ isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)+ refOrNullary = fromMaybe (Inline nullarySchema) ref+ refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ OpenApiTypeSingle OpenApiString & enum_ ?~ [String tag]) ref++gsumConToSchema ::+ (GToSchema (C1 c f), Constructor c) =>+ SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)]+gsumConToSchema opts proxy = do+ ref <- gdeclareSchemaRef opts proxy+ return [gsumConToSchemaWith (Just ref) opts proxy]++instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where+ gsumToSchema opts proxy = do+ tell (All False)+ lift $ gsumConToSchema opts proxy++instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where+ gsumToSchema opts proxy = do+ tell (All False)+ lift $ gsumConToSchema opts proxy++instance (Constructor c) => GSumToSchema (C1 c U1) where+ gsumToSchema opts proxy = pure $ (: []) $ gsumConToSchemaWith Nothing opts proxy++data Proxy2 a b = Proxy2++data Proxy3 a b c = Proxy3++-- $setup+-- >>> import Data.OpenApi+-- >>> import Data.Aeson (encode)+-- >>> import Data.Aeson.Types (toJSONKeyText)+-- >>> import Data.OpenApi.Internal.Utils+-- >>> :set -XScopedTypeVariables+-- >>> :set -XDeriveAnyClass+-- >>> :set -XStandaloneDeriving+-- >>> :set -XTypeApplications
+ src/Data/OpenApi/Internal/Schema/Validation.hs view
@@ -0,0 +1,715 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}++-- |+-- Module: Data.OpenApi.Internal.Schema.Validation+-- Copyright: (c) 2015 GetShopTV+-- License: BSD3+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Validate JSON values with OpenAPI Schema.+module Data.OpenApi.Internal.Schema.Validation where++import Control.Applicative+import Control.Lens hiding (allOf)+import Control.Monad (forM, forM_, when)+import Data.Aeson hiding (Result)+import Prelude.Compat+import Prelude ()+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#endif+import Data.Foldable+ ( for_,+ sequenceA_,+ traverse_,+ )+#if !MIN_VERSION_aeson(2,0,0)+import Data.HashMap.Strict (HashMap)+#endif+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.Maybe (fromMaybe)+import Data.OpenApi.Aeson.Compat (hasKey, keyToText, lookupKey, objectToList)+import Data.OpenApi.Declare+import Data.OpenApi.Internal+import Data.OpenApi.Internal.Schema+import Data.OpenApi.Internal.Utils+import Data.OpenApi.Lens+import Data.Proxy+import Data.Scientific (Scientific, isInteger)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Encoding qualified as TL+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import "unordered-containers" Data.HashSet qualified as HashSet++-- $setup+-- >>> import Data.OpenApi.Internal.Schema.Validation++-- | Validate @ToJSON@ instance matches @ToSchema@ for a given value.+-- This can be used with QuickCheck to ensure those instances are coherent:+--+-- prop> validateToJSON (x :: Int) == []+--+-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.+-- See @'validateToJSONWithPatternChecker'@.+--+-- See 'renderValidationErrors' on how the output is structured.+validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String+validatePrettyToJSON = renderValidationErrors validateToJSON++-- | Variant of 'validatePrettyToJSON' with typed output.+validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]+validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)++-- | Validate @ToJSON@ instance matches @ToSchema@ for a given value and pattern checker.+-- This can be used with QuickCheck to ensure those instances are coherent.+--+-- For validation without patterns see @'validateToJSON'@. See also:+-- 'renderValidationErrors'.+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]+validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON+ where+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty++-- | Pretty print validation errors+-- together with actual JSON and OpenAPI Schema+-- (using 'encodePretty').+--+-- >>> import Data.Aeson as Aeson+-- >>> import Data.Foldable (traverse_)+-- >>> import GHC.Generics+-- >>> data Phone = Phone { value :: String } deriving (Generic)+-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)+-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]+-- >>> instance ToSchema Phone+-- >>> instance ToSchema Person+-- >>> let person = Person { name = "John", phone = Phone "123456" }+-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person+-- Validation against the schema fails:+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"+-- <BLANKLINE>+-- JSON value:+-- {+-- "name": "John"+-- }+-- <BLANKLINE>+-- OpenAPI Schema:+-- {+-- "properties": {+-- "name": {+-- "type": "string"+-- },+-- "phone": {+-- "$ref": "#/components/schemas/Phone"+-- }+-- },+-- "required": [+-- "name",+-- "phone"+-- ],+-- "type": "object"+-- }+-- <BLANKLINE>+-- OpenAPI Description Context:+-- {+-- "Phone": {+-- "properties": {+-- "value": {+-- "type": "string"+-- }+-- },+-- "required": [+-- "value"+-- ],+-- "type": "object"+-- }+-- }+-- <BLANKLINE>+renderValidationErrors ::+ forall a.+ (ToJSON a, ToSchema a) =>+ (a -> [ValidationError]) -> a -> Maybe String+renderValidationErrors f x =+ case f x of+ [] -> Nothing+ errors ->+ Just+ $ unlines+ [ "Validation against the schema fails:",+ unlines (map (" * " ++) errors),+ "JSON value:",+ ppJSONString (toJSON x),+ "",+ "OpenAPI Schema:",+ ppJSONString (toJSON schema_),+ "",+ "OpenAPI Description Context:",+ ppJSONString (toJSON refs_)+ ]+ where+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty+ (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty++-- | Validate JSON @Value@ against OpenAPI @Schema@.+--+-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []+--+-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.+-- See @'validateJSONWithPatternChecker'@.+validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]+validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)++-- | Validate JSON @Value@ against OpenAPI @ToSchema@ for a given value and pattern checker.+--+-- For validation without patterns see @'validateJSON'@.+validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]+validateJSONWithPatternChecker checker defs sch js =+ case runValidation (validateWithSchema js) cfg sch of+ Failed xs -> xs+ Passed _ -> mempty+ where+ cfg =+ defaultConfig+ { configPatternChecker = checker,+ configDefinitions = defs+ }++-- | Validation error message.+type ValidationError = String++-- | Validation result type.+data Result a+ = -- | Validation failed with a list of error messages.+ Failed [ValidationError]+ | -- | Validation passed.+ Passed a+ deriving stock (Eq, Show, Functor)++instance Applicative Result where+ pure = Passed+ Passed f <*> Passed x = Passed (f x)+ Failed xs <*> Failed ys = Failed (xs <> ys)+ Failed xs <*> _ = Failed xs+ _ <*> Failed ys = Failed ys++instance Alternative Result where+ empty = Failed mempty+ Passed x <|> _ = Passed x+ _ <|> y = y++instance Monad Result where+ return = pure+ Passed x >>= f = f x+ Failed xs >>= _ = Failed xs++-- | Validation configuration.+data Config = Config+ { -- | Pattern checker for @'_schemaPattern'@ validation.+ configPatternChecker :: Pattern -> Text -> Bool,+ -- | Schema definitions in scope to resolve references.+ configDefinitions :: Definitions Schema+ }++-- | Default @'Config'@:+--+-- @+-- defaultConfig = 'Config'+-- { 'configPatternChecker' = \\_pattern _str -> True+-- , 'configDefinitions' = mempty+-- }+-- @+defaultConfig :: Config+defaultConfig =+ Config+ { configPatternChecker = \_pattern _str -> True,+ configDefinitions = mempty+ }++-- | Value validation.+newtype Validation s a = Validation {runValidation :: Config -> s -> Result a}+ deriving stock (Functor)++instance Applicative (Validation schema) where+ pure x = Validation (\_ _ -> pure x)+ Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)++instance Alternative (Validation schema) where+ empty = Validation (\_ _ -> empty)+ Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)++instance Profunctor Validation where+ dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))++instance Choice Validation where+ left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))+ right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))++instance Monad (Validation s) where+ return = pure+ Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)+ (>>) = (*>)++withConfig :: (Config -> Validation s a) -> Validation s a+withConfig f = Validation (\c -> runValidation (f c) c)++withSchema :: (s -> Validation s a) -> Validation s a+withSchema f = Validation (\c s -> runValidation (f s) c s)++-- | Issue an error message.+invalid :: String -> Validation schema a+invalid msg = Validation (\_ _ -> Failed [msg])++-- | Validation passed.+valid :: Validation schema ()+valid = pure ()++-- | Validate schema's property given a lens into that property+-- and property checker.+checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()+checkMissing missing l g = withSchema $ \sch ->+ case sch ^. l of+ Nothing -> missing+ Just x -> g x++-- | Validate schema's property given a lens into that property+-- and property checker.+-- If property is missing in schema, consider it valid.+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()+check = checkMissing valid++-- | Validate same value with different schema.+sub :: t -> Validation t a -> Validation s a+sub = lmap . const++-- | Validate same value with a part of the original schema.+sub_ :: Getting a s a -> Validation a r -> Validation s r+sub_ = lmap . view++-- | Validate value against a schema given schema reference and validation function.+withRef :: Reference -> (Schema -> Validation s a) -> Validation s a+withRef (Reference ref) f = withConfig $ \cfg ->+ case InsOrdHashMap.lookup ref (configDefinitions cfg) of+ Nothing -> invalid $ "unknown schema " ++ show ref+ Just s -> f s++validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()+validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)+validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)++-- | Validate JSON @Value@ with OpenAPI @Schema@.+validateWithSchema :: Value -> Validation Schema ()+validateWithSchema val = do+ validateSchemaType val+ validateEnum val+ validateConst val -- 3.1: const+ validateConditional val -- 3.1: if/then/else+ validateUnevaluated val -- 3.1: best-effort unevaluatedProperties/unevaluatedItems++-- | @const@: the instance must equal the schema's @const@ value exactly+-- (JSON value equality).+validateConst :: Value -> Validation Schema ()+validateConst val = check const_ $ \expected ->+ when (val /= expected)+ $ invalid ("value " ++ show val ++ " does not equal const " ++ show expected)++-- | @if@/@then@/@else@. Validating against @if@ is only a switch: if it passes,+-- @then@ must pass; otherwise @else@ must pass. The @if@ check itself never+-- contributes an error.+validateConditional :: Value -> Validation Schema ()+validateConditional val = check if_ $ \ifSchema -> withConfig $ \cfg -> withSchema $ \sch ->+ let ifPasses = case runValidation (validateWithSchemaRef ifSchema val) cfg sch of+ Failed _ -> False+ Passed _ -> True+ in if ifPasses+ then maybe valid (\t -> validateWithSchemaRef t val) (sch ^. then_)+ else maybe valid (\e -> validateWithSchemaRef e val) (sch ^. else_)++-- | Best-effort @unevaluatedProperties@ / @unevaluatedItems@.+--+-- LIMITATION (documented, intentional): "evaluated" is approximated as+-- "evaluated by THIS schema object's own local @properties@/@additionalProperties@+-- (for objects) or @prefixItems@/@items@ (for arrays)". Properties or items that a+-- full JSON Schema 2020-12 validator would consider evaluated via in-place+-- applicators (@allOf@/@anyOf@/@oneOf@/@if@/@then@/@else@/@$ref@) are NOT counted+-- here, so this check can be STRICTER than the spec when those applicators are+-- combined with @unevaluated*@. Full annotation-aware evaluation is future work.+-- TODO(annotations).+validateUnevaluated :: Value -> Validation Schema ()+validateUnevaluated (Object o) = check unevaluatedProperties $ \ap -> withSchema $ \sch ->+ let propKeys = InsOrdHashMap.keys (sch ^. properties)+ addlCoversAll = case sch ^. additionalProperties of+ Just (AdditionalPropertiesAllowed True) -> True+ Just (AdditionalPropertiesSchema _) -> True+ _ -> False+ leftover =+ [ (k, v)+ | (keyToText -> k, v) <- objectToList o,+ not addlCoversAll,+ k `notElem` propKeys+ ]+ in for_ leftover $ \(k, v) -> case ap of+ AdditionalPropertiesAllowed True -> valid+ AdditionalPropertiesAllowed False ->+ invalid ("unevaluatedProperties=false but property " ++ show k ++ " was not evaluated")+ AdditionalPropertiesSchema s -> validateWithSchemaRef s v+validateUnevaluated (Array xs) = check unevaluatedItems $ \uSchema -> withSchema $ \sch ->+ let prefixLen = maybe 0 length (sch ^. prefixItems)+ itemsCoversAll = case sch ^. items of+ Just (OpenApiItemsObject _) -> True+ Just (OpenApiItemsBoolean True) -> True+ _ -> False+ leftover = if itemsCoversAll then [] else drop prefixLen (Vector.toList xs)+ in traverse_ (validateWithSchemaRef uSchema) leftover+validateUnevaluated _ = valid++validateInteger :: Scientific -> Validation Schema ()+validateInteger n = do+ when (not (isInteger n))+ $ invalid ("not an integer")+ validateNumber n++validateNumber :: Scientific -> Validation Schema ()+validateNumber n = withConfig $ \_cfg -> withSchema $ \_sch -> do+ -- 3.1 / JSON Schema 2020-12: maximum/minimum are always non-strict, and+ -- exclusiveMaximum/exclusiveMinimum are independent numeric keywords.+ check maximum_ $ \m ->+ when (n > m)+ $ invalid ("value " ++ show n ++ " exceeds maximum (should be <=" ++ show m ++ ")")++ check minimum_ $ \m ->+ when (n < m)+ $ invalid ("value " ++ show n ++ " falls below minimum (should be >=" ++ show m ++ ")")++ check exclusiveMaximum $ \m ->+ when (n >= m)+ $ invalid ("value " ++ show n ++ " is not below exclusiveMaximum (should be <" ++ show m ++ ")")++ check exclusiveMinimum $ \m ->+ when (n <= m)+ $ invalid ("value " ++ show n ++ " is not above exclusiveMinimum (should be >" ++ show m ++ ")")++ check multipleOf $ \k ->+ when (not (isInteger (n / k)))+ $ invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)++validateString :: Text -> Validation Schema ()+validateString s = do+ check maxLength $ \n ->+ when (len > fromInteger n)+ $ invalid ("string is too long (length should be <=" ++ show n ++ ")")++ check minLength $ \n ->+ when (len < fromInteger n)+ $ invalid ("string is too short (length should be >=" ++ show n ++ ")")++ check pattern $ \regex -> do+ withConfig $ \cfg -> do+ when (not (configPatternChecker cfg regex s))+ $ invalid ("string does not match pattern " ++ show regex)+ where+ len = Text.length s++validateArray :: Vector Value -> Validation Schema ()+validateArray xs = do+ check maxItems $ \n ->+ when (len > fromInteger n)+ $ invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")++ check minItems $ \n ->+ when (len < fromInteger n)+ $ invalid ("array is too short (size should be >=" ++ show n ++ ")")++ withSchema $ \sch -> case sch ^. prefixItems of+ -- 3.1 tuple validation: each leading element validates positionally against+ -- its prefix schema; elements beyond the prefix are governed by `items`.+ Just prefixSchemas -> do+ let prefixLen = length prefixSchemas+ sequenceA_+ [ validateWithSchemaRef ps x+ | (ps, x) <- zip prefixSchemas (Vector.toList xs)+ ]+ case sch ^. items of+ Just (OpenApiItemsObject itemSchema) ->+ traverse_ (validateWithSchemaRef itemSchema) (drop prefixLen (Vector.toList xs))+ Just (OpenApiItemsBoolean False)+ | len > prefixLen ->+ invalid+ ( "array has "+ ++ show (len - prefixLen)+ ++ " item(s) beyond prefixItems but items:false forbids them"+ )+ _ -> valid -- items:true or absent: trailing elements unconstrained here+ -- No prefixItems: legacy whole-array `items` behavior.+ Nothing -> check items $ \case+ OpenApiItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs+ -- items: false forbids any array elements; items: true allows anything.+ OpenApiItemsBoolean b ->+ when (not b && not (Vector.null xs))+ $ invalid "array must be empty (items: false)"++ -- 3.1 contains / minContains / maxContains: count elements matching `contains`.+ check contains_ $ \containsSchema -> withConfig $ \cfg -> withSchema $ \sch -> do+ let matchesElem x = case runValidation (validateWithSchemaRef containsSchema x) cfg sch of+ Failed _ -> False+ Passed _ -> True+ matches = length (filter matchesElem (Vector.toList xs))+ minC = maybe 1 fromInteger (sch ^. minContains)+ maxC = fmap fromInteger (sch ^. maxContains)+ when (matches < minC)+ $ invalid+ ( "array must contain at least "+ ++ show minC+ ++ " matching element(s), found "+ ++ show matches+ )+ for_ maxC $ \hi ->+ when (matches > hi)+ $ invalid+ ( "array must contain at most "+ ++ show hi+ ++ " matching element(s), found "+ ++ show matches+ )++ check uniqueItems $ \unique ->+ when (unique && not allUnique)+ $ invalid ("array is expected to contain unique items, but it does not")+ where+ len = Vector.length xs+ allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))++-- | The aeson object representation, which differs across aeson versions.+-- Aliased so 'validateObject' keeps a single-line signature: the formatter+-- cannot parse a type signature split across CPP @#if@ branches.+#if MIN_VERSION_aeson(2,0,0)+type AesonObject = KeyMap.KeyMap Value+#else+type AesonObject = HashMap Text Value+#endif++validateObject :: AesonObject -> Validation Schema ()+validateObject o = withSchema $ \sch ->+ case sch ^. discriminator of+ Just (Discriminator pname types) -> case fromJSON <$> lookupKey pname o of+ Just (Success pvalue) ->+ let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types+ in -- TODO ref may be name or reference+ validateWithSchemaRef (Ref (Reference ref)) (Object o)+ Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)+ Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")+ Nothing -> do+ check maxProperties $ \n ->+ when (size > n)+ $ invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")++ check minProperties $ \n ->+ when (size < n)+ $ invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")++ validateRequired+ validateProps+ where+ size = fromIntegral (length o)++ validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)+ validateReq n =+ when (not (hasKey n o))+ $ invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))++ validateProps = withSchema $ \sch -> do+ for_ (objectToList o) $ \(keyToText -> k, v) ->+ case v of+ Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property+ _ ->+ case InsOrdHashMap.lookup k (sch ^. properties) of+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v+ Just s -> validateWithSchemaRef s v++ validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid+ validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"+ validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v++ unknownProperty :: Text -> Validation s a+ unknownProperty pname =+ invalid+ $ "property "+ <> show pname+ <> " is found in JSON value, but it is not mentioned in OpenAPI schema"++validateEnum :: Value -> Validation Schema ()+validateEnum val = do+ check enum_ $ \xs ->+ when (val `notElem` xs)+ $ invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show val)++-- | Infer schema type based on used properties.+--+-- This is like 'inferParamSchemaTypes', but also works for objects:+--+-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"+-- Just [OpenApiObject]+inferSchemaTypes :: Schema -> [OpenApiType]+inferSchemaTypes sch =+ inferParamSchemaTypes sch+ ++ [ OpenApiObject+ | any+ ($ sch)+ [ has (additionalProperties . _Just),+ has (maxProperties . _Just),+ has (minProperties . _Just),+ has (properties . folded),+ has (required . folded)+ ]+ ]++-- | Infer schema type based on used properties.+--+-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"+-- Just [OpenApiString]+--+-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"+-- Just [OpenApiArray]+--+-- From numeric properties 'OpenApiInteger' type is inferred.+-- If you want 'OpenApiNumber' instead, you must specify it explicitly.+--+-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"+-- Just [OpenApiInteger]+inferParamSchemaTypes :: Schema -> [OpenApiType]+inferParamSchemaTypes sch =+ concat+ [ [ OpenApiArray+ | any+ ($ sch)+ [ has (items . _Just),+ has (maxItems . _Just),+ has (minItems . _Just),+ has (uniqueItems . _Just)+ ]+ ],+ [ OpenApiInteger+ | any+ ($ sch)+ [ has (exclusiveMaximum . _Just),+ has (exclusiveMinimum . _Just),+ has (maximum_ . _Just),+ has (minimum_ . _Just),+ has (multipleOf . _Just)+ ]+ ],+ [ OpenApiString+ | any+ ($ sch)+ [ has (maxLength . _Just),+ has (minLength . _Just),+ has (pattern . _Just)+ ]+ ]+ ]++-- | The list of primitive types a schema's @type@ keyword permits:+-- a single type becomes a singleton list, a type array becomes its list,+-- and an absent @type@ becomes the empty list (callers fall back to the+-- value's natural shape).+schemaTypes :: Schema -> [OpenApiType]+schemaTypes sch = case sch ^. type_ of+ Nothing -> []+ Just (OpenApiTypeSingle t) -> [t]+ Just (OpenApiTypeArray ts) -> ts++-- | Validate a value assuming the schema's @type@ is exactly the given single type.+validateOfType :: OpenApiType -> Value -> Validation Schema ()+validateOfType ty val = case (ty, val) of+ (OpenApiNull, Null) -> valid+ (OpenApiBoolean, Bool _) -> valid+ (OpenApiInteger, Number n) -> validateInteger n+ (OpenApiNumber, Number n) -> validateNumber n+ (OpenApiString, String s) -> validateString s+ (OpenApiArray, Array xs) -> validateArray xs+ (OpenApiObject, Object o) -> validateObject o+ _ -> invalid $ "expected JSON value of type " ++ showType (Just ty, val)++-- | Validate a value when the schema declares no @type@ (fall back to the value's shape).+validateByValueShape :: Value -> Validation Schema ()+validateByValueShape val = case val of+ Null -> valid+ Bool _ -> valid+ Number n -> validateNumber n+ String s -> validateString s+ Array xs -> validateArray xs+ Object o -> validateObject o++validateSchemaType :: Value -> Validation Schema ()+validateSchemaType val = withSchema $ \sch ->+ case sch of+ (view oneOf -> Just variants) -> do+ res <- forM variants $ \var ->+ (True <$ validateWithSchemaRef var val) <|> (return False)+ case length $ filter id res of+ 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show val+ 1 -> valid+ _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show val+ (view allOf -> Just variants) -> do+ -- Default semantics for Validation Monad will abort when at least one+ -- variant does not match.+ forM_ variants $ \var ->+ validateWithSchemaRef var val+ _ ->+ case schemaTypes sch of+ [] -> validateByValueShape val+ [ty] -> validateOfType ty val+ -- 3.1 type array: the value is valid if it matches any listed type.+ tys -> do+ oks <- forM tys $ \ty -> (True <$ validateOfType ty val) <|> return False+ when (not (or oks))+ $ invalid+ $ "expected JSON value of one of types "+ ++ show tys+ ++ " but got "+ ++ showType (Nothing, val)++validateParamSchemaType :: Value -> Validation Schema ()+validateParamSchemaType val = withSchema $ \sch ->+ case schemaTypes sch of+ [] -> validateParamByValueShape val+ [ty] -> validateParamOfType ty val+ tys -> do+ oks <- forM tys $ \ty -> (True <$ validateParamOfType ty val) <|> return False+ when (not (or oks))+ $ invalid+ $ "expected JSON value of one of types "+ ++ show tys+ ++ " but got "+ ++ showType (Nothing, val)++-- | Validate a value assuming a single @type@, restricted to the kinds a+-- parameter schema may have (no @null@ or @object@).+validateParamOfType :: OpenApiType -> Value -> Validation Schema ()+validateParamOfType ty val = case (ty, val) of+ (OpenApiBoolean, Bool _) -> valid+ (OpenApiInteger, Number n) -> validateInteger n+ (OpenApiNumber, Number n) -> validateNumber n+ (OpenApiString, String s) -> validateString s+ (OpenApiArray, Array xs) -> validateArray xs+ _ -> invalid $ "expected JSON value of type " ++ showType (Just ty, val)++validateParamByValueShape :: Value -> Validation Schema ()+validateParamByValueShape val = case val of+ Bool _ -> valid+ Number n -> validateNumber n+ String s -> validateString s+ Array xs -> validateArray xs+ _ -> invalid $ "expected JSON value of type " ++ showType (Nothing, val)++showType :: (Maybe OpenApiType, Value) -> String+showType (Just ty, _) = show ty+showType (Nothing, Null) = "OpenApiNull"+showType (Nothing, Bool _) = "OpenApiBoolean"+showType (Nothing, Number _) = "OpenApiNumber"+showType (Nothing, String _) = "OpenApiString"+showType (Nothing, Array _) = "OpenApiArray"+showType (Nothing, Object _) = "OpenApiObject"
+ src/Data/OpenApi/Internal/TypeShape.hs view
@@ -0,0 +1,66 @@+-- |+-- Module: Data.OpenApi.Internal.TypeShape+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Internal type-level machinery classifying the generic shape of a datatype+-- (used to reject unsupported sum/product mixes). No API stability guarantees.+module Data.OpenApi.Internal.TypeShape where++import Data.Kind (Type)+import Data.Proxy+import GHC.Exts (Constraint)+import GHC.Generics+import GHC.TypeLits++-- | Shape of a datatype.+data TypeShape+ = -- | A simple enumeration.+ Enumeration+ | -- | A product or a sum of non-unit products.+ SumOfProducts+ | -- | Mixed sum type with both unit and non-unit constructors.+ Mixed++-- | A combined shape for a product type.+type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where+ ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products+ ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products+ ProdCombine a b = SumOfProducts++-- | A combined shape for a sum type.+type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where+ SumCombine Enumeration Enumeration = Enumeration+ SumCombine SumOfProducts SumOfProducts = SumOfProducts+ SumCombine a b = Mixed++type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where+ TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))++type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where+ GenericHasSimpleShape t f Enumeration = ()+ GenericHasSimpleShape t f SumOfProducts = ()+ GenericHasSimpleShape t f Mixed =+ TypeError+ ( Text "Cannot derive Generic-based OpenAPI Schema for " :<>: ShowType t+ :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."+ :$$: Text "OpenAPI does not have a good representation for these types."+ :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"+ :$$: Text "that matches aeson's Generic-based toJSON,"+ :$$: Text "but that's not supported by some OpenAPI tools."+ )++-- | Infer a 'TypeShape' for a generic representation of a type.+type family GenericShape (g :: Type -> Type) :: TypeShape++type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)++type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)++type instance GenericShape (D1 d f) = GenericShape f++type instance GenericShape (C1 c U1) = Enumeration++type instance GenericShape (C1 c (S1 s f)) = SumOfProducts++type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
+ src/Data/OpenApi/Internal/Utils.hs view
@@ -0,0 +1,149 @@+-- |+-- Module: Data.OpenApi.Internal.Utils+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Internal shared utilities (Template Haskell lens helpers, JSON/monoid+-- combinators). No API stability guarantees.+module Data.OpenApi.Internal.Utils where++import Control.Lens ((%~), (&))+import Control.Lens.TH+import Data.Aeson+import Data.Aeson.Encode.Pretty qualified as P+import Data.Aeson.Types+import Data.ByteString.Lazy qualified as BSL+import Data.Char+import Data.Data+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap)+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.Hashable (Hashable)+import Data.Map (Map)+import Data.Set (Set)+import Data.Text (Text)+import GHC.Generics+import Language.Haskell.TH (mkName)+import Prelude.Compat+import Prelude ()++openApiFieldRules :: LensRules+openApiFieldRules = defaultFieldRules & lensField %~ openApiFieldNamer+ where+ openApiFieldNamer namer dname fnames fname =+ map fixDefName (namer dname fnames fname)++ fixDefName (MethodName cname mname) = MethodName cname (fixName mname)+ fixDefName (TopName name) = TopName (fixName name)++ fixName = mkName . fixName' . show++ fixName' "in" = "in_" -- keyword+ fixName' "type" = "type_" -- keyword+ fixName' "default" = "default_" -- keyword+ fixName' "if" = "if_" -- keyword+ fixName' "then" = "then_" -- keyword+ fixName' "else" = "else_" -- keyword+ fixName' "minimum" = "minimum_" -- Prelude conflict+ fixName' "maximum" = "maximum_" -- Prelude conflict+ fixName' "enum" = "enum_" -- Control.Lens conflict+ fixName' "head" = "head_" -- Prelude conflict+ fixName' "not" = "not_" -- Prelude conflict+ fixName' "id" = "id_" -- Prelude conflict+ fixName' "const" = "const_" -- Prelude conflict+ fixName' "contains" = "contains_" -- Control.Lens conflict+ fixName' n = n++gunfoldEnum :: String -> [a] -> (forall b r. (Data b) => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a+gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1 ..] xs) of+ Just x -> z x+ Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."++jsonPrefix :: String -> Options+jsonPrefix prefix =+ defaultOptions+ { fieldLabelModifier = modifier . drop 1,+ constructorTagModifier = modifier,+ sumEncoding = ObjectWithSingleField,+ omitNothingFields = True+ }+ where+ modifier = lowerFirstUppers . drop (length prefix)++ lowerFirstUppers s = map toLower x ++ y+ where+ (x, y) = span isUpper s++parseOneOf :: (ToJSON a) => [a] -> Value -> Parser a+parseOneOf xs js =+ case lookup js ys of+ Nothing -> fail $ "invalid json: " ++ show js ++ " (expected one of " ++ show (map fst ys) ++ ")"+ Just x -> pure x+ where+ ys = zip (map toJSON xs) xs++(<+>) :: Value -> Value -> Value+Object x <+> Object y = Object (x <> y)+_ <+> _ = error "<+>: merging non-objects"++genericMempty :: (Generic a, GMonoid (Rep a)) => a+genericMempty = to gmempty++genericMappend :: (Generic a, GMonoid (Rep a)) => a -> a -> a+genericMappend x y = to (gmappend (from x) (from y))++class GMonoid f where+ gmempty :: f p+ gmappend :: f p -> f p -> f p++instance GMonoid U1 where+ gmempty = U1+ gmappend _ _ = U1++instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where+ gmempty = gmempty :*: gmempty+ gmappend (a :*: x) (b :*: y) = gmappend a b :*: gmappend x y++instance (OpenApiMonoid a) => GMonoid (K1 i a) where+ gmempty = K1 openApiMempty+ gmappend (K1 x) (K1 y) = K1 (openApiMappend x y)++instance (GMonoid f) => GMonoid (M1 i t f) where+ gmempty = M1 gmempty+ gmappend (M1 x) (M1 y) = M1 (gmappend x y)++class OpenApiMonoid m where+ openApiMempty :: m+ openApiMappend :: m -> m -> m+ default openApiMempty :: (Monoid m) => m+ openApiMempty = mempty+ default openApiMappend :: (Monoid m) => m -> m -> m+ openApiMappend = mappend++instance OpenApiMonoid [a]++instance (Ord a) => OpenApiMonoid (Set a)++instance (Ord k) => OpenApiMonoid (Map k v)++instance (Eq k, Hashable k) => OpenApiMonoid (HashMap k v) where+ openApiMempty = mempty+ openApiMappend = HashMap.unionWith (\_old new -> new)++instance (Eq k, Hashable k) => OpenApiMonoid (InsOrdHashMap k v) where+ openApiMempty = mempty+ openApiMappend = InsOrdHashMap.unionWith (\_old new -> new)++instance OpenApiMonoid Text where+ openApiMempty = mempty+ openApiMappend x "" = x+ openApiMappend _ y = y++instance OpenApiMonoid (Maybe a) where+ openApiMempty = Nothing+ openApiMappend x Nothing = x+ openApiMappend _ y = y++encodePretty :: (ToJSON a) => a -> BSL.ByteString+encodePretty = P.encodePretty' $ P.defConfig {P.confCompare = P.compare}
+ src/Data/OpenApi/Lens.hs view
@@ -0,0 +1,191 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Data.OpenApi.Lens+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Lenses and prisms for OpenAPI.+module Data.OpenApi.Lens where++import Control.Lens+import Data.Aeson (Value)+import Data.OpenApi.Internal+import Data.OpenApi.Internal.Utils+import Data.Scientific (Scientific)+import Data.Text (Text)++-- * Classy lenses++makeFields ''OpenApi+makeFields ''Components+makeFields ''Server+makeFields ''RequestBody+makeFields ''MediaTypeObject+makeFields ''Info+makeFields ''Contact+makeFields ''License+makeLensesWith openApiFieldRules ''PathItem+makeFields ''Tag+makeFields ''Operation+makeLensesWith openApiFieldRules ''Param+makeFields ''Header+makeLensesWith openApiFieldRules ''Schema+makeFields ''NamedSchema+makeFields ''Xml+makeLensesWith openApiFieldRules ''Responses+makeFields ''Response+makeLensesWith openApiFieldRules ''SecurityScheme+makeFields ''ApiKeyParams+makeFields ''OAuth2ImplicitFlow+makeFields ''OAuth2PasswordFlow+makeFields ''OAuth2ClientCredentialsFlow+makeFields ''OAuth2AuthorizationCodeFlow+makeFields ''OAuth2Flow+makeFields ''OAuth2Flows+makeFields ''ExternalDocs+makeFields ''Encoding+makeFields ''Example+makeFields ''Discriminator+makeFields ''Link++-- * Prisms++-- ** 'SecuritySchemeType' prisms++makePrisms ''SecuritySchemeType++-- ** 'Referenced' prisms++makePrisms ''Referenced++-- ** 'OpenApiItems' prisms++_OpenApiItemsBoolean :: Review OpenApiItems Bool+_OpenApiItemsBoolean =+ unto (\x -> OpenApiItemsBoolean x)++_OpenApiItemsObject :: Review OpenApiItems (Referenced Schema)+_OpenApiItemsObject =+ unto (\x -> OpenApiItemsObject x)++-- =============================================================+-- More helpful instances for easier access to schema properties++type instance Index Responses = HttpStatusCode++type instance Index Operation = HttpStatusCode++type instance IxValue Responses = Referenced Response++type instance IxValue Operation = Referenced Response++instance Ixed Responses where ix n = responses . ix n++instance At Responses where at n = responses . at n++instance Ixed Operation where ix n = responses . ix n++instance At Operation where at n = responses . at n++instance HasType NamedSchema (Maybe OpenApiTypeValue) where type_ = schema . type_++-- OVERLAPPABLE instances++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasFormat s (Maybe Format)+ where+ format = schema . format++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasItems s (Maybe OpenApiItems)+ where+ items = schema . items++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasMaximum s (Maybe Scientific)+ where+ maximum_ = schema . maximum_++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasExclusiveMaximum s (Maybe Scientific)+ where+ exclusiveMaximum = schema . exclusiveMaximum++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasMinimum s (Maybe Scientific)+ where+ minimum_ = schema . minimum_++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasExclusiveMinimum s (Maybe Scientific)+ where+ exclusiveMinimum = schema . exclusiveMinimum++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasMaxLength s (Maybe Integer)+ where+ maxLength = schema . maxLength++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasMinLength s (Maybe Integer)+ where+ minLength = schema . minLength++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasPattern s (Maybe Text)+ where+ pattern = schema . pattern++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasMaxItems s (Maybe Integer)+ where+ maxItems = schema . maxItems++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasMinItems s (Maybe Integer)+ where+ minItems = schema . minItems++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasUniqueItems s (Maybe Bool)+ where+ uniqueItems = schema . uniqueItems++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasEnum s (Maybe [Value])+ where+ enum_ = schema . enum_++instance+ {-# OVERLAPPABLE #-}+ (HasSchema s Schema) =>+ HasMultipleOf s (Maybe Scientific)+ where+ multipleOf = schema . multipleOf
+ src/Data/OpenApi/Migration.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Data.OpenApi.Migration+--+-- Value-layer helpers that rewrite a raw, already-parsed OpenAPI __3.0__+-- 'Data.Aeson.Value' into a __3.1__-shaped 'Value', which then 'Data.Aeson.decode's+-- into the 3.1-only 'Data.OpenApi.Schema' types.+--+-- Under the project's "Strategy A" the 3.1 Haskell types deliberately cannot+-- represent 3.0-only constructs (there is no @nullable@ field, exclusive bounds+-- are numeric, and tuple @items@ arrays are gone). So a user holding a 3.0+-- document must rewrite the parsed JSON before decoding it — that is what these+-- helpers do. They are intentionally deprecated to flag that 3.0 input is+-- transitional.+module Data.OpenApi.Migration+ ( migrate30To31,+ migrate30NullableValue,+ migrate30ExclusiveBoundsValue,+ migrate30ItemsArrayValue,+ migrate30SchemaValue,+ )+where++import Data.Aeson (Object, Value (..))+import Data.OpenApi.Aeson.Compat (deleteKey, insertKey, lookupKey, stringToKey)+import Data.Text qualified as T++-- | Apply a function to a JSON object's underlying map; leave non-objects alone.+overObject :: (Object -> Object) -> Value -> Value+overObject f (Object o) = Object (f o)+overObject _ v = v++-- | Delete a key given as 'T.Text'.+delKey :: T.Text -> Object -> Object+delKey k = deleteKey (stringToKey (T.unpack k))++-- | Rewrite a decoded 3.0 schema JSON object's @nullable@ keyword into a 3.1+-- type array. @nullable:true@ removes the @nullable@ key and adds @"null"@ to the+-- @type@ key (@"string"@ becomes @["string","null"]@; @["string"]@ becomes+-- @["string","null"]@; absent @type@ becomes @["null"]@). @nullable:false@ just+-- removes the @nullable@ key.+migrate30NullableValue :: Value -> Value+migrate30NullableValue = overObject $ \o ->+ case lookupKey "nullable" o of+ Just (Bool True) -> insertKey "type" (addNull (lookupKey "type" o)) (delKey "nullable" o)+ Just (Bool False) -> delKey "nullable" o+ _ -> o+ where+ addNull :: Maybe Value -> Value+ addNull (Just (String t)) = Array [String t, String "null"]+ addNull (Just (Array xs))+ | String "null" `elem` xs = Array xs+ | otherwise = Array (xs <> [String "null"])+ addNull (Just v) = Array [v, String "null"]+ addNull Nothing = Array [String "null"]++-- | Rewrite 3.0 boolean exclusive bounds into 3.1 numeric ones.+--+-- @{"maximum":100,"exclusiveMaximum":true}@ becomes @{"exclusiveMaximum":100}@+-- (the @maximum@ is dropped); @{"maximum":100,"exclusiveMaximum":false}@ becomes+-- @{"maximum":100}@. Symmetric for @minimum@/@exclusiveMinimum@. An already-numeric+-- exclusive bound is left unchanged.+migrate30ExclusiveBoundsValue :: Value -> Value+migrate30ExclusiveBoundsValue =+ overObject (rewriteBound "maximum" "exclusiveMaximum" . rewriteBound "minimum" "exclusiveMinimum")+ where+ rewriteBound boundKey exclKey o =+ case lookupKey exclKey o of+ Just (Bool True) -> case lookupKey boundKey o of+ Just n@(Number _) -> insertKey exclKey n (delKey boundKey o)+ _ -> delKey exclKey o -- exclusive:true but no bound: drop the bool+ Just (Bool False) -> delKey exclKey o+ _ -> o++-- | Rewrite a 3.0 tuple @items@ array into 3.1 @prefixItems@ + @items:false@.+--+-- @{"items":[a,b]}@ becomes @{"prefixItems":[a,b],"items":false}@. Fires only when+-- @items@ is a JSON array; an object or boolean @items@ is left unchanged.+migrate30ItemsArrayValue :: Value -> Value+migrate30ItemsArrayValue = overObject $ \o ->+ case lookupKey "items" o of+ Just (Array xs) ->+ insertKey+ "items"+ (Bool False)+ (insertKey "prefixItems" (Array xs) (delKey "items" o))+ _ -> o++-- | Apply all single-object 3.0->3.1 rewrites to one schema object. The three+-- rewrites operate on disjoint keys, so their order does not matter.+migrate30SchemaValue :: Value -> Value+migrate30SchemaValue =+ migrate30NullableValue . migrate30ExclusiveBoundsValue . migrate30ItemsArrayValue++-- | Recursively rewrite a whole 3.0 document 'Value' into 3.1 shape, applying the+-- schema rewrites to every nested object (so schemas inside @properties@,+-- @prefixItems@, @$defs@, @allOf@, request/response bodies, … are all migrated).+-- Applying the per-object rewrite to every object is safe because each rewrite is+-- a no-op on objects lacking its trigger keys.+migrate30To31 :: Value -> Value+migrate30To31 = go+ where+ go (Object o) = migrate30SchemaValue (Object (fmap go o))+ go (Array xs) = Array (fmap go xs)+ go v = v+{-# DEPRECATED+ migrate30To31,+ migrate30NullableValue,+ migrate30ExclusiveBoundsValue,+ migrate30ItemsArrayValue,+ migrate30SchemaValue+ "3.0 input support is transitional; remove once all inputs are 3.1."+ #-}
+ src/Data/OpenApi/Operation.hs view
@@ -0,0 +1,307 @@+-- |+-- Module: Data.OpenApi.Operation+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Helper traversals and functions for OpenAPI operations manipulations.+-- These might be useful when you already have an OpenAPI specification+-- generated by something else.+module Data.OpenApi.Operation+ ( -- * Operation traversals+ allOperations,+ operationsOf,++ -- * Manipulation++ -- ** Tags+ applyTags,+ applyTagsFor,++ -- ** Responses+ setResponse,+ setResponseWith,+ setResponseFor,+ setResponseForWith,++ -- ** Paths+ prependPath,++ -- * Miscellaneous+ declareResponse,+ )+where++import Control.Lens+import Data.Data.Lens+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.HashSet.InsOrd qualified as InsOrdHS+import Data.List.Compat+import Data.Maybe (mapMaybe)+import Data.OpenApi.Declare+import Data.OpenApi.Internal+import Data.OpenApi.Lens+import Data.OpenApi.Schema+import Data.Proxy+import Data.Set qualified as Set+import Data.Text (Text)+import Network.HTTP.Media (MediaType)+import Prelude.Compat+import Prelude ()++-- $setup+-- >>> import Data.Aeson+-- >>> import Data.Proxy+-- >>> import Data.Time+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM+-- >>> import Data.OpenApi.Internal.Utils++-- | Prepend path piece to all operations of the spec.+-- Leading and trailing slashes are trimmed/added automatically.+--+-- >>> let api = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/info", mempty)]+-- >>> BSL.putStrLn $ encodePretty $ prependPath "user/{user_id}" api ^. paths+-- {+-- "/user/{user_id}/info": {}+-- }+prependPath :: FilePath -> OpenApi -> OpenApi+prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)+ where+ x </> y = case trim y of+ "" -> "/" <> trim x+ y' -> "/" <> trim x <> "/" <> y'++ trim = dropWhile (== '/') . dropWhileEnd (== '/')++-- | All operations of an OpenAPI spec.+allOperations :: Traversal' OpenApi Operation+allOperations = paths . traverse . template++-- | @'operationsOf' sub@ will traverse only those operations+-- that are present in @sub@. Note that @'Operation'@ is determined+-- by both path and method.+--+-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"+-- >>> let api = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ ok & post ?~ ok)]+-- >>> let sub = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)]+-- >>> BSL.putStrLn $ encodePretty api+-- {+-- "components": {},+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.1.0",+-- "paths": {+-- "/user": {+-- "get": {+-- "responses": {+-- "200": {+-- "description": "OK"+-- }+-- }+-- },+-- "post": {+-- "responses": {+-- "200": {+-- "description": "OK"+-- }+-- }+-- }+-- }+-- }+-- }+-- >>> BSL.putStrLn $ encodePretty $ api & operationsOf sub . at 404 ?~ "Not found"+-- {+-- "components": {},+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.1.0",+-- "paths": {+-- "/user": {+-- "get": {+-- "responses": {+-- "200": {+-- "description": "OK"+-- },+-- "404": {+-- "description": "Not found"+-- }+-- }+-- },+-- "post": {+-- "responses": {+-- "200": {+-- "description": "OK"+-- }+-- }+-- }+-- }+-- }+-- }+operationsOf :: OpenApi -> Traversal' OpenApi Operation+operationsOf sub = paths . itraversed . withIndex . subops+ where+ -- \| Traverse operations that correspond to paths and methods of the sub API.+ subops :: Traversal' (FilePath, PathItem) Operation+ subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of+ Just subitem -> (,) path <$> methodsOf subitem f item+ Nothing -> pure (path, item)++ -- \| Traverse operations that exist in a given @'PathItem'@+ -- This is used to traverse only the operations that exist in sub API.+ methodsOf :: PathItem -> Traversal' PathItem Operation+ methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just+ where+ ops = pathItem ^.. template :: [Maybe Operation]+ ns = mapMaybe (fmap fst . sequenceA) $ zip [0 ..] ops++-- | Apply tags to all operations and update the global list of tags.+--+-- @+-- 'applyTags' = 'applyTagsFor' 'allOperations'+-- @+applyTags :: [Tag] -> OpenApi -> OpenApi+applyTags = applyTagsFor allOperations++-- | Apply tags to a part of an OpenAPI spec and update the global+-- list of tags.+applyTagsFor :: Traversal' OpenApi Operation -> [Tag] -> OpenApi -> OpenApi+applyTagsFor ops ts swag =+ swag+ & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))+ & tags %~ (<> InsOrdHS.fromList ts)++-- | Construct a 'Response' whose body, for the given media type, is the schema+-- derived from @a@, declaring any referenced schema definitions in the process.+-- The returned 'Response' has an empty description; set one with the 'description'+-- lens if your spec requires it.+--+-- >>> BSL.putStrLn $ encodePretty $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty+-- [+-- {+-- "Day": {+-- "example": "2016-07-22",+-- "format": "date",+-- "type": "string"+-- }+-- },+-- {+-- "content": {+-- "application/json": {+-- "schema": {+-- "$ref": "#/components/schemas/Day"+-- }+-- }+-- },+-- "description": ""+-- }+-- ]+declareResponse :: (ToSchema a) => MediaType -> Proxy a -> Declare (Definitions Schema) Response+declareResponse cType proxy = do+ s <- declareSchemaRef proxy+ return (mempty & content . at cType ?~ (mempty & schema ?~ s))++-- | Set response for all operations.+-- This will also update global schema definitions.+--+-- If the response already exists it will be overwritten.+--+-- @+-- 'setResponse' = 'setResponseFor' 'allOperations'+-- @+--+-- Example:+--+-- >>> let api = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)]+-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day)+-- >>> BSL.putStrLn $ encodePretty $ api & setResponse 200 res+-- {+-- "components": {+-- "schemas": {+-- "Day": {+-- "example": "2016-07-22",+-- "format": "date",+-- "type": "string"+-- }+-- }+-- },+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.1.0",+-- "paths": {+-- "/user": {+-- "get": {+-- "responses": {+-- "200": {+-- "content": {+-- "application/json": {+-- "schema": {+-- "$ref": "#/components/schemas/Day"+-- }+-- }+-- },+-- "description": ""+-- }+-- }+-- }+-- }+-- }+-- }+--+-- See also @'setResponseWith'@.+setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponse = setResponseFor allOperations++-- | Set or update response for all operations.+-- This will also update global schema definitions.+--+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),+-- then just the new response is used.+--+-- @+-- 'setResponseWith' = 'setResponseForWith' 'allOperations'+-- @+--+-- See also @'setResponse'@.+setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponseWith = setResponseForWith allOperations++-- | Set response for specified operations.+-- This will also update global schema definitions.+--+-- If the response already exists it will be overwritten.+--+-- See also @'setResponseForWith'@.+setResponseFor :: Traversal' OpenApi Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponseFor ops code dres swag =+ swag+ & components . schemas %~ (<> defs)+ & ops . at code ?~ Inline res+ where+ (defs, res) = runDeclare dres mempty++-- | Set or update response for specified operations.+-- This will also update global schema definitions.+--+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),+-- then just the new response is used.+--+-- See also @'setResponseFor'@.+setResponseForWith :: Traversal' OpenApi Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponseForWith ops f code dres swag =+ swag+ & components . schemas %~ (<> defs)+ & ops . at code %~ Just . Inline . combine+ where+ (defs, new) = runDeclare dres mempty++ combine (Just (Ref (Reference n))) = case swag ^. components . responses . at n of+ Just old -> f old new+ Nothing -> new -- response name can't be dereferenced, replacing with new response+ combine (Just (Inline old)) = f old new+ combine Nothing = new
+ src/Data/OpenApi/Optics.hs view
@@ -0,0 +1,379 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Data.OpenApi.Optics+-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>+-- Stability: experimental+--+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>+-- library.+--+-- >>> import Data.Aeson+-- >>> import Optics.Core+-- >>> :set -XOverloadedLabels+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL+-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM+--+-- Example from the "Data.OpenApi" module using @optics@:+--+-- >>> :{+-- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)+-- & #components % #schemas .~ IOHM.fromList [ ("User", mempty & #type ?~ OpenApiString) ]+-- & #paths .~+-- IOHM.fromList [ ("/user", mempty & #get ?~ (mempty+-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User")))+-- & at 404 ?~ "User info not found")) ]+-- :}+-- {+-- "components": {+-- "schemas": {+-- "User": {+-- "type": "string"+-- }+-- }+-- },+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.1.0",+-- "paths": {+-- "/user": {+-- "get": {+-- "responses": {+-- "200": {+-- "content": {+-- "application/json": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- },+-- "description": "OK"+-- },+-- "404": {+-- "description": "User info not found"+-- }+-- }+-- }+-- }+-- }+-- }+--+-- For convenience optics are defined as /labels/. It means that field accessor+-- names can be overloaded for different types. One such common field is+-- @#description@. Many components of an OpenAPI specification can have+-- descriptions, and you can use the same name for them:+--+-- >>> BSL.putStrLn $ encodePretty $ (mempty :: Response) & #description .~ "No content"+-- {+-- "description": "No content"+-- }+-- >>> :{+-- BSL.putStrLn $ encodePretty $ (mempty :: Schema)+-- & #type ?~ OpenApiBoolean+-- & #description ?~ "To be or not to be"+-- :}+-- {+-- "description": "To be or not to be",+-- "type": "boolean"+-- }+--+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:+--+-- >>> :{+-- BSL.putStrLn $ encodePretty $ (mempty :: Operation)+-- & at 404 ?~ "Not found"+-- :}+-- {+-- "responses": {+-- "404": {+-- "description": "Not found"+-- }+-- }+-- }+module Data.OpenApi.Optics () where++import Data.Aeson (Value)+import Data.OpenApi.Internal+import Data.OpenApi.Internal.Utils+import Data.Scientific (Scientific)+import Data.Text (Text)+import Optics.Core+import Optics.TH++-- Lenses++makeFieldLabels ''OpenApi+makeFieldLabels ''Components+makeFieldLabels ''Server+makeFieldLabels ''ServerVariable+makeFieldLabels ''RequestBody+makeFieldLabels ''MediaTypeObject+makeFieldLabels ''Info+makeFieldLabels ''Contact+makeFieldLabels ''License+makeFieldLabels ''PathItem+makeFieldLabels ''Tag+makeFieldLabels ''Operation+makeFieldLabels ''Param+makeFieldLabels ''Header+makeFieldLabels ''Schema+makeFieldLabels ''NamedSchema+makeFieldLabels ''Xml+makeFieldLabels ''Responses+makeFieldLabels ''Response+makeFieldLabels ''SecurityScheme+makeFieldLabels ''ApiKeyParams+makeFieldLabels ''OAuth2ImplicitFlow+makeFieldLabels ''OAuth2PasswordFlow+makeFieldLabels ''OAuth2ClientCredentialsFlow+makeFieldLabels ''OAuth2AuthorizationCodeFlow+makeFieldLabels ''OAuth2Flow+makeFieldLabels ''OAuth2Flows+makeFieldLabels ''ExternalDocs+makeFieldLabels ''Encoding+makeFieldLabels ''Example+makeFieldLabels ''Discriminator+makeFieldLabels ''Link++-- Prisms++makePrismLabels ''SecuritySchemeType+makePrismLabels ''Referenced++-- OpenApiItems prisms++instance+ ( a ~ Bool,+ b ~ Bool+ ) =>+ LabelOptic+ "_OpenApiItemsBoolean"+ A_Review+ OpenApiItems+ OpenApiItems+ a+ b+ where+ labelOptic = unto (\x -> OpenApiItemsBoolean x)+ {-# INLINE labelOptic #-}++instance+ ( a ~ Referenced Schema,+ b ~ Referenced Schema+ ) =>+ LabelOptic+ "_OpenApiItemsObject"+ A_Review+ OpenApiItems+ OpenApiItems+ a+ b+ where+ labelOptic = unto (\x -> OpenApiItemsObject x)+ {-# INLINE labelOptic #-}++-- =============================================================+-- More helpful instances for easier access to schema properties++type instance Index Responses = HttpStatusCode++type instance Index Operation = HttpStatusCode++type instance IxValue Responses = Referenced Response++type instance IxValue Operation = Referenced Response++instance Ixed Responses where+ ix n = #responses % ix n+ {-# INLINE ix #-}++instance At Responses where+ at n = #responses % at n+ {-# INLINE at #-}++instance Ixed Operation where+ ix n = #responses % ix n+ {-# INLINE ix #-}++instance At Operation where+ at n = #responses % at n+ {-# INLINE at #-}++-- #type++instance+ ( a ~ Maybe OpenApiTypeValue,+ b ~ Maybe OpenApiTypeValue+ ) =>+ LabelOptic "type" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #type+ {-# INLINE labelOptic #-}++-- #default++instance+ ( a ~ Maybe Value,+ b ~ Maybe Value+ ) =>+ LabelOptic "default" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #default+ {-# INLINE labelOptic #-}++-- #format++instance+ ( a ~ Maybe Format,+ b ~ Maybe Format+ ) =>+ LabelOptic "format" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #format+ {-# INLINE labelOptic #-}++-- #items++instance+ ( a ~ Maybe OpenApiItems,+ b ~ Maybe OpenApiItems+ ) =>+ LabelOptic "items" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #items+ {-# INLINE labelOptic #-}++-- #maximum++instance+ ( a ~ Maybe Scientific,+ b ~ Maybe Scientific+ ) =>+ LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #maximum+ {-# INLINE labelOptic #-}++-- #exclusiveMaximum++instance+ ( a ~ Maybe Scientific,+ b ~ Maybe Scientific+ ) =>+ LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #exclusiveMaximum+ {-# INLINE labelOptic #-}++-- #minimum++instance+ ( a ~ Maybe Scientific,+ b ~ Maybe Scientific+ ) =>+ LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #minimum+ {-# INLINE labelOptic #-}++-- #exclusiveMinimum++instance+ ( a ~ Maybe Scientific,+ b ~ Maybe Scientific+ ) =>+ LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #exclusiveMinimum+ {-# INLINE labelOptic #-}++-- #maxLength++instance+ ( a ~ Maybe Integer,+ b ~ Maybe Integer+ ) =>+ LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #maxLength+ {-# INLINE labelOptic #-}++-- #minLength++instance+ ( a ~ Maybe Integer,+ b ~ Maybe Integer+ ) =>+ LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #minLength+ {-# INLINE labelOptic #-}++-- #pattern++instance+ ( a ~ Maybe Text,+ b ~ Maybe Text+ ) =>+ LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #pattern+ {-# INLINE labelOptic #-}++-- #maxItems++instance+ ( a ~ Maybe Integer,+ b ~ Maybe Integer+ ) =>+ LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #maxItems+ {-# INLINE labelOptic #-}++-- #minItems++instance+ ( a ~ Maybe Integer,+ b ~ Maybe Integer+ ) =>+ LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #minItems+ {-# INLINE labelOptic #-}++-- #uniqueItems++instance+ ( a ~ Maybe Bool,+ b ~ Maybe Bool+ ) =>+ LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #uniqueItems+ {-# INLINE labelOptic #-}++-- #enum++instance+ ( a ~ Maybe [Value],+ b ~ Maybe [Value]+ ) =>+ LabelOptic "enum" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #enum+ {-# INLINE labelOptic #-}++-- #multipleOf++instance+ ( a ~ Maybe Scientific,+ b ~ Maybe Scientific+ ) =>+ LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b+ where+ labelOptic = #schema % #multipleOf+ {-# INLINE labelOptic #-}
+ src/Data/OpenApi/ParamSchema.hs view
@@ -0,0 +1,27 @@+-- |+-- Module: Data.OpenApi.ParamSchema+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Types and functions for working with OpenAPI parameter schema.+module Data.OpenApi.ParamSchema+ ( -- * Encoding+ ToParamSchema (..),++ -- * Generic schema encoding+ genericToParamSchema,+ toParamSchemaBoundedIntegral,++ -- * Schema templates+ passwordSchema,+ binarySchema,+ byteSchema,++ -- * Generic encoding configuration+ SchemaOptions (..),+ defaultSchemaOptions,+ )+where++import Data.OpenApi.Internal.ParamSchema+import Data.OpenApi.SchemaOptions
+ src/Data/OpenApi/Schema.hs view
@@ -0,0 +1,53 @@+-- |+-- Module: Data.OpenApi.Schema+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Types and functions for working with OpenAPI schema.+module Data.OpenApi.Schema+ ( -- * Encoding+ ToSchema (..),+ declareSchema,+ declareSchemaRef,+ toSchema,+ toSchemaRef,+ schemaName,+ toInlinedSchema,++ -- * Generic schema encoding+ genericDeclareNamedSchema,+ genericDeclareSchema,+ genericDeclareNamedSchemaNewtype,+ genericNameSchema,++ -- ** 'Bounded' 'Integral'+ genericToNamedSchemaBoundedIntegral,+ toSchemaBoundedIntegral,++ -- ** 'Bounded' 'Enum' key mappings+ declareSchemaBoundedEnumKeyMapping,+ toSchemaBoundedEnumKeyMapping,++ -- ** Reusing @ToParamSchema@+ paramSchemaToNamedSchema,+ paramSchemaToSchema,++ -- * Sketching @Schema@s using @ToJSON@+ sketchSchema,+ sketchStrictSchema,++ -- * Inlining @Schema@s+ inlineNonRecursiveSchemas,+ inlineAllSchemas,+ inlineSchemas,+ inlineSchemasWhen,++ -- * Generic encoding configuration+ SchemaOptions (..),+ defaultSchemaOptions,+ fromAesonOptions,+ )+where++import Data.OpenApi.Internal.Schema+import Data.OpenApi.SchemaOptions
+ src/Data/OpenApi/Schema/Generator.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedLists #-}++-- |+-- Module: Data.OpenApi.Schema.Generator+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- QuickCheck generators that produce JSON 'Value's conforming to an OpenAPI+-- 3.1 'Schema'. This is primarily useful for property testing: derive a schema+-- from a type with 'ToSchema', generate random values that satisfy it, and+-- check that they parse back via 'FromJSON' (see 'validateFromJSON').+module Data.OpenApi.Schema.Generator where++import Control.Lens.Operators+import Control.Monad (filterM)+import Data.Aeson+import Data.Aeson.Types+import Data.HashMap.Strict.InsOrd.Compat qualified as M+import Data.Maybe+import Data.OpenApi+import Data.OpenApi.Aeson.Compat (fromInsOrdHashMap)+import Data.OpenApi.Declare+import Data.OpenApi.Internal.Schema.Validation (inferSchemaTypes)+import Data.Proxy+import Data.Scientific+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Vector qualified as V+import Prelude.Compat+import Test.QuickCheck (arbitrary)+import Test.QuickCheck.Gen+import Test.QuickCheck.Property+import Prelude ()++-- | Note: 'schemaGen' may 'error', if schema type is not specified,+-- and cannot be inferred.+schemaGen :: Definitions Schema -> Schema -> Gen Value+schemaGen _ schema+ | Just cases <- schema ^. enum_ = elements cases+schemaGen defns schema+ | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants)+schemaGen defns schema =+ case singleType =<< schema ^. type_ of+ Nothing ->+ case inferSchemaTypes schema of+ [inferredType] -> schemaGen defns (schema & type_ ?~ OpenApiTypeSingle inferredType)+ -- Gen is not MonadFail+ _ -> error "unable to infer schema type"+ Just OpenApiBoolean -> Bool <$> elements [True, False]+ Just OpenApiNull -> pure Null+ Just OpenApiNumber+ | Just min <- schema ^. minimum_,+ Just max <- schema ^. maximum_ ->+ Number+ . fromFloatDigits+ <$> choose (toRealFloat min, toRealFloat max :: Double)+ | otherwise -> Number . fromFloatDigits <$> (arbitrary :: Gen Double)+ Just OpenApiInteger+ | Just min <- schema ^. minimum_,+ Just max <- schema ^. maximum_ ->+ Number+ . fromInteger+ <$> choose (truncate min, truncate max)+ | otherwise -> Number . fromInteger <$> arbitrary+ Just OpenApiArray+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty+ | Just prefixSchemas <- schema ^. prefixItems -> do+ -- 3.1 tuple: generate one element positionally per prefix schema, then+ -- any trailing elements permitted by `items` (for the generic tuple+ -- derivation `items` is false, so there are none).+ let prefixLen = length prefixSchemas+ prefixVals <- traverse (schemaGen defns . dereference defns) prefixSchemas+ trailing <- case schema ^. items of+ Just (OpenApiItemsObject ref) -> do+ size <- getSize+ let itemSchema = dereference defns ref+ minLength' = fromMaybe prefixLen $ fromInteger <$> schema ^. minItems+ maxLength' = fromMaybe (prefixLen + size) $ fromInteger <$> schema ^. maxItems+ minTrail = max 0 (minLength' - prefixLen)+ maxTrail = max minTrail (maxLength' - prefixLen)+ n <- choose (minTrail, maxTrail)+ vectorOf n $ schemaGen defns itemSchema+ -- items: false (or absent) -> no elements beyond the prefix.+ _ -> pure []+ return . Array . V.fromList $ prefixVals ++ trailing+ | Just items <- schema ^. items ->+ case items of+ OpenApiItemsObject ref -> do+ size <- getSize+ let itemSchema = dereference defns ref+ minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems+ maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems+ arrayLength <- choose (minLength', max minLength' maxLength')+ generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema+ return . Array $ V.fromList generatedArray+ -- items: true -> any element allowed; items: false -> no elements.+ OpenApiItemsBoolean _ -> pure $ Array V.empty+ | otherwise -> pure $ Array V.empty+ Just OpenApiString -> do+ size <- getSize+ let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength+ let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength+ length <- choose (minLength', max minLength' maxLength')+ str <- vectorOf length arbitrary+ return . String $ T.pack str+ Just OpenApiObject -> do+ size <- getSize+ let props = dereference defns <$> schema ^. properties+ reqKeys = S.fromList $ schema ^. required+ allKeys = S.fromList . M.keys $ schema ^. properties+ optionalKeys = allKeys S.\\ reqKeys+ minProps' =+ fromMaybe (length reqKeys)+ $ fromInteger+ <$> schema+ ^. minProperties+ maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties+ shuffledOptional <- shuffle $ S.toList optionalKeys+ numProps <- choose (minProps', max minProps' maxProps')+ let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props+ let gens = schemaGen defns <$> presentProps+ additionalGens <- case schema ^. additionalProperties of+ Just (AdditionalPropertiesSchema addlSchema) -> do+ additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary+ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)+ _ -> return []+ x <- sequence $ gens <> additionalGens+ return . Object $ fromInsOrdHashMap x++-- | Resolve a 'Referenced' value against a set of 'Definitions': return the+-- value inline if present, otherwise look the reference up by name.+--+-- /Partial:/ throws if a 'Ref' names a definition not in the map.+dereference :: Definitions a -> Referenced a -> a+dereference _ (Inline a) = a+dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs++-- | Generate a random JSON 'Value' conforming to the schema derived from @a@+-- via its 'ToSchema' instance. Inherits the partiality of 'schemaGen' (it may+-- 'error' when a schema's type is neither specified nor inferable).+genValue :: (ToSchema a) => Proxy a -> Gen Value+genValue p =+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty+ in schemaGen defs schema++-- | Property that asserts every value generated from @a@'s derived schema+-- parses back successfully through its 'FromJSON' instance — i.e. the schema+-- and the decoder agree.+validateFromJSON :: forall a. (ToSchema a, FromJSON a) => Proxy a -> Property+validateFromJSON p = forAll (genValue p)+ $ \val -> case parseEither parseJSON val of+ Right (_ :: a) -> succeeded+ Left err ->+ failed+ { reason = err+ }
+ src/Data/OpenApi/Schema/Validation.hs view
@@ -0,0 +1,90 @@+-- |+-- Module: Data.OpenApi.Schema.Validation+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Validate JSON values with OpenAPI Schema.+module Data.OpenApi.Schema.Validation+ ( -- * How to use validation+ -- $howto++ -- ** Examples+ -- $examples++ -- ** Validating @'Maybe'@+ -- $maybe++ -- * JSON validation+ ValidationError,++ -- ** Using @ToJSON@ and @ToSchema@+ validatePrettyToJSON,+ validateToJSON,+ validateToJSONWithPatternChecker,+ renderValidationErrors,++ -- ** Using @Value@ and @Schema@+ validateJSON,+ validateJSONWithPatternChecker,+ )+where++import Data.OpenApi.Internal.Schema.Validation++-- $setup+-- >>> import Control.Lens+-- >>> import Data.Aeson+-- >>> import Data.Proxy+-- >>> import Data.OpenApi+-- >>> import GHC.Generics+-- >>> :set -XDeriveGeneric++-- $howto+--+-- This module provides helpful functions for JSON validation.+-- These functions are meant to be used in test suites for your application+-- to ensure that JSON respresentation for your data corresponds to+-- schemas you're using for the OpenAPI specification.+--+-- It is recommended to use validation functions as QuickCheck properties+-- (see <http://hackage.haskell.org/package/QuickCheck>).++-- $examples+--+-- >>> validateToJSON "hello"+-- []+--+-- >>> validateToJSON False+-- []+--+-- >>> newtype Nat = Nat Integer deriving Generic+-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n+-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0+-- >>> validateToJSON (Nat 10)+-- []+-- >>> validateToJSON (Nat (-5))+-- ["value -5.0 falls below minimum (should be >=0.0)"]++-- $maybe+--+-- Because @'Maybe' a@ has the same schema as @a@, validation+-- generally fails for @null@ JSON:+--+-- >>> validateToJSON (Nothing :: Maybe String)+-- ["expected JSON value of type OpenApiString"]+-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])+-- ["expected JSON value of type OpenApiString"]+-- >>> validateToJSON (123, Nothing :: Maybe String)+-- ["expected JSON value of type OpenApiString"]+--+-- However, when @'Maybe' a@ is a type of a record field,+-- validation takes @required@ property of the @Schema@+-- into account:+--+-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic+-- >>> instance ToJSON Person+-- >>> instance ToSchema Person+-- >>> validateToJSON (Person "Nick" (Just 24))+-- []+-- >>> validateToJSON (Person "Nick" Nothing)+-- []
+ src/Data/OpenApi/SchemaOptions.hs view
@@ -0,0 +1,76 @@+-- |+-- Module: Data.OpenApi.SchemaOptions+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Generic deriving options for @ToParamSchema@ and @ToSchema@.+module Data.OpenApi.SchemaOptions where++import Data.Aeson.Types qualified as Aeson++-- | Options that specify how to encode your type to OpenAPI schema.+data SchemaOptions = SchemaOptions+ { -- | Function applied to field labels. Handy for removing common record prefixes for example.+ fieldLabelModifier :: String -> String,+ -- | Function applied to constructor tags which could be handy for lower-casing them for example.+ constructorTagModifier :: String -> String,+ -- | Function applied to datatype name.+ datatypeNameModifier :: String -> String,+ -- | If @'True'@ the constructors of a datatype, with all nullary constructors,+ -- will be encoded to a string enumeration schema with the constructor tags as possible values.+ allNullaryToStringTag :: Bool,+ -- | Hide the field name when a record constructor has only one field, like a newtype.+ unwrapUnaryRecords :: Bool,+ -- | Specifies how to encode constructors of a sum datatype.+ sumEncoding :: Aeson.SumEncoding+ }++-- | Default encoding @'SchemaOptions'@.+--+-- @+-- 'SchemaOptions'+-- { 'fieldLabelModifier' = id+-- , 'constructorTagModifier' = id+-- , 'datatypeNameModifier' = id+-- , 'allNullaryToStringTag' = True+-- , 'unwrapUnaryRecords' = False+-- , 'sumEncoding' = 'Aeson.defaultTaggedObject'+-- }+-- @+defaultSchemaOptions :: SchemaOptions+defaultSchemaOptions =+ SchemaOptions+ { fieldLabelModifier = id,+ constructorTagModifier = id,+ datatypeNameModifier = id,+ allNullaryToStringTag = True,+ unwrapUnaryRecords = False,+ sumEncoding = Aeson.defaultTaggedObject+ }++-- | Convert 'Aeson.Options' to 'SchemaOptions'.+--+-- Specifically the following fields get copied:+--+-- * 'fieldLabelModifier'+-- * 'constructorTagModifier'+-- * 'allNullaryToStringTag'+-- * 'unwrapUnaryRecords'+--+-- Note that these fields have no effect on `SchemaOptions`:+--+-- * 'Aeson.omitNothingFields'+-- * 'Aeson.tagSingleConstructors'+--+-- The rest is defined as in 'defaultSchemaOptions'.+--+-- @since 2.2.1+fromAesonOptions :: Aeson.Options -> SchemaOptions+fromAesonOptions opts =+ defaultSchemaOptions+ { fieldLabelModifier = Aeson.fieldLabelModifier opts,+ constructorTagModifier = Aeson.constructorTagModifier opts,+ allNullaryToStringTag = Aeson.allNullaryToStringTag opts,+ unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts,+ sumEncoding = Aeson.sumEncoding opts+ }
+ test/Data/OpenApi/CommonTestTypes.hs view
@@ -0,0 +1,1149 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.OpenApi.CommonTestTypes where++import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)+import Data.Aeson.QQ.Simple+import Data.Aeson.Types (toJSONKeyText)+import Data.Char+import Data.Map (Map)+import Data.OpenApi+import Data.Proxy+import Data.Set (Set)+import Data.Text qualified as Text+import Data.Word+import GHC.Generics+import Prelude.Compat+import Prelude ()++-- ========================================================================+-- Unit type+-- ========================================================================++data Unit = Unit deriving (Generic)++instance ToParamSchema Unit++instance ToSchema Unit++unitSchemaJSON :: Value+unitSchemaJSON =+ [aesonQQ|+{+ "type": "string",+ "enum": ["Unit"]+}+|]++-- ========================================================================+-- Color (enum)+-- ========================================================================+data Color+ = Red+ | Green+ | Blue+ deriving (Generic)++instance ToParamSchema Color++instance ToSchema Color++colorSchemaJSON :: Value+colorSchemaJSON =+ [aesonQQ|+{+ "type": "string",+ "enum": ["Red", "Green", "Blue"]+}+|]++-- ========================================================================+-- Shade (paramSchemaToNamedSchema)+-- ========================================================================++data Shade = Dim | Bright deriving (Generic)++instance ToParamSchema Shade++instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions++shadeSchemaJSON :: Value+shadeSchemaJSON =+ [aesonQQ|+{+ "type": "string",+ "enum": ["Dim", "Bright"]+}+|]++-- ========================================================================+-- Paint (record with bounded enum property)+-- ========================================================================++newtype Paint = Paint {color :: Color}+ deriving (Generic)++instance ToSchema Paint++paintSchemaJSON :: Value+paintSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "color":+ {+ "$ref": "#/components/schemas/Color"+ }+ },+ "required": ["color"]+}+|]++paintInlinedSchemaJSON :: Value+paintInlinedSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "color":+ {+ "type": "string",+ "enum": ["Red", "Green", "Blue"]+ }+ },+ "required": ["color"]+}+|]++-- ========================================================================+-- Status (constructorTagModifier)+-- ========================================================================++data Status+ = StatusOk+ | StatusError+ deriving (Generic)++instance ToParamSchema Status where+ toParamSchema =+ genericToParamSchema+ defaultSchemaOptions+ { constructorTagModifier = map toLower . drop (length "Status")+ }++instance ToSchema Status where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { constructorTagModifier = map toLower . drop (length "Status")+ }++statusSchemaJSON :: Value+statusSchemaJSON =+ [aesonQQ|+{+ "type": "string",+ "enum": ["ok", "error"]+}+|]++-- ========================================================================+-- Email (newtype with unwrapUnaryRecords set to True)+-- ========================================================================++newtype Email = Email {getEmail :: String}+ deriving (Generic)++instance ToParamSchema Email++instance ToSchema Email where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { unwrapUnaryRecords = True+ }++emailSchemaJSON :: Value+emailSchemaJSON =+ [aesonQQ|+{+ "type": "string"+}+|]++-- ========================================================================+-- UserId (non-record newtype)+-- ========================================================================++newtype UserId = UserId Integer+ deriving (Eq, Ord, Generic)++instance ToParamSchema UserId++instance ToSchema UserId++userIdSchemaJSON :: Value+userIdSchemaJSON =+ [aesonQQ|+{+ "type": "integer"+}+|]++-- ========================================================================+-- UserGroup (set newtype)+-- ========================================================================++newtype UserGroup = UserGroup (Set UserId)+ deriving (Generic)++instance ToSchema UserGroup++userGroupSchemaJSON :: Value+userGroupSchemaJSON =+ [aesonQQ|+{+ "type": "array",+ "items": { "$ref": "#/components/schemas/UserId" },+ "uniqueItems": true+}+|]++-- ========================================================================+-- Person (simple record with optional fields)+-- ========================================================================+data Person = Person+ { name :: String,+ phone :: Integer,+ email :: Maybe String+ }+ deriving (Generic)++instance ToSchema Person++personSchemaJSON :: Value+personSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "name": { "type": "string" },+ "phone": { "type": "integer" },+ "email": { "type": "string" }+ },+ "required": ["name", "phone"]+}+|]++-- ========================================================================+-- Player (record newtype)+-- ========================================================================++newtype Player = Player+ { position :: Point+ }+ deriving (Generic)++instance ToSchema Player++playerSchemaJSON :: Value+playerSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "position":+ {+ "$ref": "#/components/schemas/Point"+ }+ },+ "required": ["position"]+}+|]++newtype Players = Players [Inlined Player]+ deriving (Generic)++instance ToSchema Players++playersSchemaJSON :: Value+playersSchemaJSON =+ [aesonQQ|+{+ "type": "array",+ "items":+ {+ "type": "object",+ "properties":+ {+ "position":+ {+ "$ref": "#/components/schemas/Point"+ }+ },+ "required": ["position"]+ }+}+|]++-- ========================================================================+-- Character (sum type with ref and record in alternative)+-- ========================================================================++data Character+ = PC Player+ | NPC {npcName :: String, npcPosition :: Point}+ deriving (Generic)++instance ToSchema Character++characterSchemaJSON :: Value+characterSchemaJSON =+ [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag",+ "contents"+ ],+ "title": "PC",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "PC"+ ]+ },+ "contents": {+ "$ref": "#/components/schemas/Player"+ }+ }+ },+ {+ "required": [+ "npcName",+ "npcPosition",+ "tag"+ ],+ "title": "NPC",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NPC"+ ]+ },+ "npcPosition": {+ "$ref": "#/components/schemas/Point"+ },+ "npcName": {+ "type": "string"+ }+ }+ }+ ]+}++|]++characterInlinedSchemaJSON :: Value+characterInlinedSchemaJSON =+ [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag",+ "contents"+ ],+ "title": "PC",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "PC"+ ]+ },+ "contents": {+ "required": [+ "position"+ ],+ "type": "object",+ "properties": {+ "position": {+ "required": [+ "x",+ "y"+ ],+ "type": "object",+ "properties": {+ "x": {+ "format": "double",+ "type": "number"+ },+ "y": {+ "format": "double",+ "type": "number"+ }+ }+ }+ }+ }+ }+ },+ {+ "required": [+ "npcName",+ "npcPosition",+ "tag"+ ],+ "title": "NPC",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NPC"+ ]+ },+ "npcPosition": {+ "required": [+ "x",+ "y"+ ],+ "type": "object",+ "properties": {+ "x": {+ "format": "double",+ "type": "number"+ },+ "y": {+ "format": "double",+ "type": "number"+ }+ }+ },+ "npcName": {+ "type": "string"+ }+ }+ }+ ]+}+|]++characterInlinedPlayerSchemaJSON :: Value+characterInlinedPlayerSchemaJSON =+ [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag",+ "contents"+ ],+ "title": "PC",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "PC"+ ]+ },+ "contents": {+ "required": [+ "position"+ ],+ "type": "object",+ "properties": {+ "position": {+ "$ref": "#/components/schemas/Point"+ }+ }+ }+ }+ },+ {+ "required": [+ "npcName",+ "npcPosition",+ "tag"+ ],+ "title": "NPC",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NPC"+ ]+ },+ "npcPosition": {+ "$ref": "#/components/schemas/Point"+ },+ "npcName": {+ "type": "string"+ }+ }+ }+ ]+}+|]++-- ========================================================================+-- ISPair (non-record product data type)+-- ========================================================================+data ISPair = ISPair Integer String+ deriving (Generic)++instance ToSchema ISPair++-- Under OpenAPI 3.1, a positional tuple derives to @prefixItems@ (one schema per+-- member, positionally) plus @items: false@ to forbid trailing elements. This is+-- the JSON Schema 2020-12 tuple form, preserving each member's type for validation.+ispairSchemaJSON :: Value+ispairSchemaJSON =+ [aesonQQ|+{+ "type": "array",+ "prefixItems":+ [+ { "type": "integer" },+ { "type": "string" }+ ],+ "items": false,+ "minItems": 2,+ "maxItems": 2+}+|]++-- ========================================================================+-- Point (record data type with custom fieldLabelModifier)+-- ========================================================================++data Point = Point+ { pointX :: Double,+ pointY :: Double+ }+ deriving (Generic)++instance ToSchema Point where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "point")+ }++pointSchemaJSON :: Value+pointSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "x": { "type": "number", "format": "double" },+ "y": { "type": "number", "format": "double" }+ },+ "required": ["x", "y"]+}+|]++-- ========================================================================+-- Point (record data type with multiple fields)+-- ========================================================================++data Point5 = Point5+ { point5X :: Double,+ point5Y :: Double,+ point5Z :: Double,+ point5U :: Double,+ point5V :: Double -- 5 dimensional!+ }+ deriving (Generic)++instance ToSchema Point5 where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "point5")+ }++point5SchemaJSON :: Value+point5SchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "x": { "type": "number", "format": "double" },+ "y": { "type": "number", "format": "double" },+ "z": { "type": "number", "format": "double" },+ "u": { "type": "number", "format": "double" },+ "v": { "type": "number", "format": "double" }+ },+ "required": ["x", "y", "z", "u", "v"]+}+|]++point5Properties :: [String]+point5Properties = ["x", "y", "z", "u", "v"]++-- ========================================================================+-- MyRoseTree (custom datatypeNameModifier)+-- ========================================================================++data MyRoseTree = MyRoseTree+ { root :: String,+ trees :: [MyRoseTree]+ }+ deriving (Generic)++instance ToSchema MyRoseTree where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { datatypeNameModifier = drop (length "My")+ }++myRoseTreeSchemaJSON :: Value+myRoseTreeSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "root": { "type": "string" },+ "trees":+ {+ "type": "array",+ "items":+ {+ "$ref": "#/components/schemas/RoseTree"+ }+ }+ },+ "required": ["root", "trees"]+}+|]++data MyRoseTree' = MyRoseTree'+ { root' :: String,+ trees' :: [MyRoseTree']+ }+ deriving (Generic)++instance ToSchema MyRoseTree' where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { datatypeNameModifier = map toLower+ }++myRoseTreeSchemaJSON' :: Value+myRoseTreeSchemaJSON' =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "root'": { "type": "string" },+ "trees'":+ {+ "type": "array",+ "items":+ {+ "$ref": "#/components/schemas/myrosetree'"+ }+ }+ },+ "required": ["root'", "trees'"]+}+|]++-- ========================================================================+-- Inlined (newtype for inlining schemas)+-- ========================================================================++newtype Inlined a = Inlined {getInlined :: a}++instance (ToSchema a) => ToSchema (Inlined a) where+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)+ where+ unname (NamedSchema _ s) = NamedSchema Nothing s++-- ========================================================================+-- Light (sum type with unwrapUnaryRecords)+-- ========================================================================++data Light+ = NoLight+ | LightFreq Double+ | LightColor Color+ | LightWaveLength {waveLength :: Double}+ deriving (Generic)++instance ToSchema Light where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { unwrapUnaryRecords = True+ }++lightSchemaJSON :: Value+lightSchemaJSON =+ [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag"+ ],+ "title": "NoLight",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NoLight"+ ]+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "title": "LightFreq",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightFreq"+ ]+ },+ "contents": {+ "format": "double",+ "type": "number"+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "title": "LightColor",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightColor"+ ]+ },+ "contents": {+ "$ref": "#/components/schemas/Color"+ }+ }+ },+ {+ "required": [+ "waveLength",+ "tag"+ ],+ "title": "LightWaveLength",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightWaveLength"+ ]+ },+ "waveLength": {+ "format": "double",+ "type": "number"+ }+ }+ }+ ]+}+|]++lightInlinedSchemaJSON :: Value+lightInlinedSchemaJSON =+ [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag"+ ],+ "title": "NoLight",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NoLight"+ ]+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "title": "LightFreq",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightFreq"+ ]+ },+ "contents": {+ "format": "double",+ "type": "number"+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "title": "LightColor",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightColor"+ ]+ },+ "contents": {+ "type": "string",+ "enum": [+ "Red",+ "Green",+ "Blue"+ ]+ }+ }+ },+ {+ "required": [+ "waveLength",+ "tag"+ ],+ "title": "LightWaveLength",+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightWaveLength"+ ]+ },+ "waveLength": {+ "format": "double",+ "type": "number"+ }+ }+ }+ ]+}+|]++-- ========================================================================+-- ResourceId (series of newtypes)+-- ========================================================================++newtype Id = Id String deriving (Generic)++instance ToSchema Id++newtype ResourceId = ResourceId Id deriving (Generic)++instance ToSchema ResourceId++-- ========================================================================+-- ButtonImages (bounded enum key mapping)+-- ========================================================================++data ButtonState = Neutral | Focus | Active | Hover | Disabled+ deriving (Show, Bounded, Enum, Generic)++instance ToJSON ButtonState++instance ToSchema ButtonState++instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)++type ImageUrl = Text.Text++newtype ButtonImages = ButtonImages {getButtonImages :: Map ButtonState ImageUrl}+ deriving (Generic)++instance ToJSON ButtonImages where+ toJSON = toJSON . getButtonImages++instance ToSchema ButtonImages where+ declareNamedSchema =+ genericDeclareNamedSchemaNewtype+ defaultSchemaOptions+ declareSchemaBoundedEnumKeyMapping++buttonImagesSchemaJSON :: Value+buttonImagesSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "Neutral": { "type": "string" },+ "Focus": { "type": "string" },+ "Active": { "type": "string" },+ "Hover": { "type": "string" },+ "Disabled": { "type": "string" }+ }+}+|]++-- ========================================================================+-- SingleMaybeField (single field data with optional field)+-- ========================================================================++data SingleMaybeField = SingleMaybeField {singleMaybeField :: Maybe String}+ deriving (Show, Generic)++instance ToJSON SingleMaybeField++instance ToSchema SingleMaybeField++singleMaybeFieldSchemaJSON :: Value+singleMaybeFieldSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "singleMaybeField": { "type": "string" }+ }+}+|]++-- ========================================================================+-- Natural Language (single field data with recursive fields)+-- ========================================================================++data Predicate+ = PredicateNoun Noun+ | PredicateOmitted Omitted+ deriving (Eq, Ord, Read, Show, Generic)++instance ToJSON Predicate++instance ToSchema Predicate++data Noun+ = Noun+ { nounSurf :: LangWord,+ nounModify :: [Modifier]+ }+ deriving (Eq, Ord, Read, Show, Generic)++instance ToJSON Noun++instance ToSchema Noun++data LangWord+ = LangWord+ { langWordSurf :: String,+ langWordBase :: String+ }+ deriving (Eq, Ord, Read, Show, Generic)++instance ToJSON LangWord++instance ToSchema LangWord++data Modifier+ = ModifierNoun Noun+ | ModifierOmitted Omitted+ deriving (Eq, Ord, Read, Show, Generic)++instance ToJSON Modifier++instance ToSchema Modifier++newtype Omitted+ = Omitted+ { omittedModify :: [Modifier]+ }+ deriving (Eq, Ord, Read, Show, Generic)++instance ToJSON Omitted++instance ToSchema Omitted++predicateSchemaDeclareJSON :: Value+predicateSchemaDeclareJSON =+ [aesonQQ|+[+ {+ "Predicate": {+ "oneOf": [+ {+ "properties": {+ "contents": { "$ref": "#/components/schemas/Noun" },+ "tag": { "enum": ["PredicateNoun"], "type": "string" }+ },+ "required": ["tag", "contents"],+ "title": "PredicateNoun",+ "type": "object"+ },+ {+ "properties": {+ "contents": { "$ref": "#/components/schemas/Omitted" },+ "tag": { "enum": ["PredicateOmitted"], "type": "string" }+ },+ "required": ["tag", "contents"],+ "title": "PredicateOmitted",+ "type": "object"+ }+ ]+ },+ "Noun": {+ "properties": {+ "nounModify": {+ "items": { "$ref": "#/components/schemas/Modifier" },+ "type": "array"+ },+ "nounSurf": { "$ref": "#/components/schemas/LangWord" }+ },+ "required": ["nounSurf", "nounModify"],+ "type": "object"+ },+ "LangWord": {+ "properties": {+ "langWordBase": { "type": "string" },+ "langWordSurf": { "type": "string" }+ },+ "required": ["langWordSurf", "langWordBase"],+ "type": "object"+ },+ "Modifier": {+ "oneOf": [+ {+ "properties": {+ "contents": { "$ref": "#/components/schemas/Noun" },+ "tag": { "enum": ["ModifierNoun"], "type": "string" }+ },+ "required": ["tag", "contents"],+ "title": "ModifierNoun",+ "type": "object"+ },+ {+ "properties": {+ "contents": { "$ref": "#/components/schemas/Omitted" },+ "tag": { "enum": ["ModifierOmitted"], "type": "string" }+ },+ "required": ["tag", "contents"],+ "title": "ModifierOmitted",+ "type": "object"+ }+ ]+ },+ "Omitted": {+ "properties": {+ "omittedModify": {+ "items": { "$ref": "#/components/schemas/Modifier" },+ "type": "array"+ }+ },+ "required": ["omittedModify"],+ "type": "object"+ }+ },+ { "$ref": "#/components/schemas/Predicate" }+]+|]++-- ========================================================================+-- TimeOfDay+-- ========================================================================+data TimeOfDay+ = Int+ | Pico+ deriving (Generic)++instance ToSchema TimeOfDay++instance ToParamSchema TimeOfDay++timeOfDaySchemaJSON :: Value+timeOfDaySchemaJSON =+ [aesonQQ|+{+ "example": "12:33:15",+ "type": "string",+ "format": "hh:MM:ss"+}+|]++timeOfDayParamSchemaJSON :: Value+timeOfDayParamSchemaJSON =+ [aesonQQ|+{+ "type": "string",+ "format": "hh:MM:ss"+}+|]++-- ========================================================================+-- UnsignedInts+-- ========================================================================+data UnsignedInts = UnsignedInts+ { unsignedIntsUint32 :: Word32,+ unsignedIntsUint64 :: Word64+ }+ deriving (Generic)++instance ToSchema UnsignedInts where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "unsignedInts")+ }++unsignedIntsSchemaJSON :: Value+unsignedIntsSchemaJSON =+ [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "uint32": { "type": "integer", "format": "int32", "minimum": 0, "maximum": 4294967295 },+ "uint64": { "type": "integer", "format": "int64", "minimum": 0, "maximum": 18446744073709551615 }+ },+ "required": ["uint32", "uint64"]+}+|]
+ test/Data/OpenApi/MigrationSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+-- this spec intentionally exercises the deprecated migration helpers+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Tests for the 3.0 -> 3.1 'Data.Aeson.Value'-layer migration helpers (EP-7).+module Data.OpenApi.MigrationSpec where++import Data.Aeson (Value, decode, encode, object, (.=))+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.OpenApi+import Data.OpenApi.Internal+import Data.OpenApi.Migration+ ( migrate30ExclusiveBoundsValue,+ migrate30ItemsArrayValue,+ migrate30NullableValue,+ migrate30To31,+ )+import Data.Text (Text)+import Test.Hspec++spec :: Spec+spec = describe "3.0 to 3.1 migration" $ do+ it "converts nullable:true to a type array" $ do+ let v30 = object ["type" .= ("string" :: Text), "nullable" .= True]+ (decode (encode (migrate30NullableValue v30)) :: Maybe Schema)+ `shouldBe` Just (mempty {_schemaType = Just (OpenApiTypeArray [OpenApiString, OpenApiNull])})++ it "drops nullable:false without touching type" $ do+ let v30 = object ["type" .= ("string" :: Text), "nullable" .= False]+ (decode (encode (migrate30NullableValue v30)) :: Maybe Schema)+ `shouldBe` Just (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)})++ it "rewrites boolean exclusiveMaximum to a numeric bound (dropping maximum)" $ do+ let v30 = object ["maximum" .= (100 :: Int), "exclusiveMaximum" .= True]+ (decode (encode (migrate30ExclusiveBoundsValue v30)) :: Maybe Schema)+ `shouldBe` Just (mempty {_schemaExclusiveMaximum = Just 100})++ it "keeps maximum when exclusiveMaximum:false" $ do+ let v30 = object ["maximum" .= (100 :: Int), "exclusiveMaximum" .= False]+ (decode (encode (migrate30ExclusiveBoundsValue v30)) :: Maybe Schema)+ `shouldBe` Just (mempty {_schemaMaximum = Just 100})++ it "rewrites a tuple items array into prefixItems + items:false" $ do+ let v30 =+ object+ [ "items"+ .= ( [ object ["type" .= ("string" :: Text)],+ object ["type" .= ("number" :: Text)]+ ] ::+ [Value]+ )+ ]+ expected =+ mempty+ { _schemaPrefixItems =+ Just+ [ Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}),+ Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiNumber)})+ ],+ _schemaItems = Just (OpenApiItemsBoolean False)+ }+ (decode (encode (migrate30ItemsArrayValue v30)) :: Maybe Schema) `shouldBe` Just expected++ it "migrate30To31 recurses into nested properties" $ do+ let v30 =+ object+ [ "type" .= ("object" :: Text),+ "properties"+ .= object+ ["n" .= object ["type" .= ("string" :: Text), "nullable" .= True]]+ ]+ nestedType = do+ s <- decode (encode (migrate30To31 v30)) :: Maybe Schema+ pn <- InsOrdHashMap.lookup ("n" :: Text) (_schemaProperties s)+ case pn of+ Inline ns -> _schemaType ns+ _ -> Nothing+ -- the nested property schema's nullable became a 3.1 type array+ nestedType `shouldBe` Just (OpenApiTypeArray [OpenApiString, OpenApiNull])
+ test/Data/OpenApi/ParamSchemaSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.OpenApi.ParamSchemaSpec where++import Data.Aeson+import Data.Aeson.QQ.Simple+import Data.Char+import Data.HashMap.Strict qualified as HM+import Data.OpenApi+import Data.OpenApi.CommonTestTypes+import Data.Proxy+import Data.Time.LocalTime+import GHC.Generics+import SpecCommon+import Test.Hspec++checkToParamSchema :: (ToParamSchema a) => Proxy a -> Value -> Spec+checkToParamSchema proxy js = (toParamSchema proxy :: Schema) <=> js++spec :: Spec+spec = do+ describe "Generic ToParamSchema" $ do+ context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON+ context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON+ context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON+ context "Unary records" $ do+ context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON+ context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON++main :: IO ()+main = hspec spec
+ test/Data/OpenApi/Schema/CoreTypes31Spec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Round-trip coverage for the OpenAPI 3.1 core type changes introduced in EP-3:+-- type arrays, numeric exclusive bounds, removal of @nullable@, and boolean @items@.+module Data.OpenApi.Schema.CoreTypes31Spec where++import Data.Aeson (decode, encode)+import Data.OpenApi+import Data.OpenApi.Internal+import Data.Version (makeVersion)+import Test.Hspec++spec :: Spec+spec = do+ describe "OpenAPI 3.1 core type changes" $ do+ it "type array {\"type\":[\"string\",\"null\"]} round-trips" $ do+ let s = mempty {_schemaType = Just (OpenApiTypeArray [OpenApiString, OpenApiNull])}+ encode s `shouldBe` "{\"type\":[\"string\",\"null\"]}"+ (decode (encode s) :: Maybe Schema) `shouldBe` Just s++ it "single type still serializes as a bare string" $ do+ let s = mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}+ encode s `shouldBe` "{\"type\":\"string\"}"+ (decode (encode s) :: Maybe Schema) `shouldBe` Just s++ it "numeric exclusive bounds round-trip" $ do+ let s =+ mempty+ { _schemaExclusiveMinimum = Just 0,+ _schemaExclusiveMaximum = Just 100+ }+ (decode (encode s) :: Maybe Schema) `shouldBe` Just s+ (decode "{\"exclusiveMinimum\":0,\"exclusiveMaximum\":100}" :: Maybe Schema)+ `shouldBe` Just s++ it "items:false round-trips" $ do+ let s = mempty {_schemaItems = Just (OpenApiItemsBoolean False)}+ encode s `shouldBe` "{\"items\":false}"+ (decode (encode s) :: Maybe Schema) `shouldBe` Just s++ it "items:true round-trips" $ do+ let s = mempty {_schemaItems = Just (OpenApiItemsBoolean True)}+ (decode (encode s) :: Maybe Schema) `shouldBe` Just s++ it "homogeneous array schema round-trips" $ do+ let s =+ mempty+ { _schemaType = Just (OpenApiTypeSingle OpenApiArray),+ _schemaItems =+ Just+ ( OpenApiItemsObject+ (Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}))+ )+ }+ (decode (encode s) :: Maybe Schema) `shouldBe` Just s++ describe "OpenAPI version detection" $ do+ it "detectVersion classifies 3.1.x as OpenApi31" $+ detectVersion (OpenApiSpecVersion (makeVersion [3, 1, 0])) `shouldBe` OpenApi31+ it "detectVersion classifies 3.0.x as OpenApi30" $+ detectVersion (OpenApiSpecVersion (makeVersion [3, 0, 3])) `shouldBe` OpenApi30
+ test/Data/OpenApi/Schema/GeneratorSpec.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}++module Data.OpenApi.Schema.GeneratorSpec where++import Control.Lens.Operators+import Data.Aeson+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Hashable (Hashable)+import Data.Int+import Data.IntMap (IntMap)+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)+import Data.Map (Map, fromList)+import Data.Monoid (mempty)+import Data.OpenApi+import Data.OpenApi.Schema.Generator+import Data.Proxy+import Data.Set (Set)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time+import Data.Version (Version)+import Data.Word+import GHC.Generics+import Prelude.Compat+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import "unordered-containers" Data.HashSet (HashSet)+import "unordered-containers" Data.HashSet qualified as HashSet+import Prelude ()++shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property+shouldValidate = validateFromJSON++shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property+shouldNotValidate = expectFailure . shouldValidate++spec :: Spec+spec = do+ describe "FromJSON validation" $ do+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)+ prop "String" $ shouldValidate (Proxy :: Proxy String)+ prop "()" $ shouldValidate (Proxy :: Proxy ())+ -- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)+ -- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])+ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))+ -- Heterogeneous tuples (and @IntMap@, which derives via @[(Int, a)]@) derive to+ -- positional @prefixItems@ + @items: false@, so the generator reconstructs each+ -- member's type and these round-trips hold.+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))+ prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))+ prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)+ prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))+ prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))+ prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))+ describe "Invalid FromJSON validation" $ do+ prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)+ prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)+ prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)+ prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)++-- =============================+-- Data types and bunk instances+-- =============================++data WrongType = WrongType Bool++instance FromJSON WrongType where+ parseJSON = withBool "WrongType" $ return . WrongType++instance ToSchema WrongType where+ declareNamedSchema _ =+ return+ . NamedSchema (Just "WrongType")+ $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject++data MissingRequired = MissingRequired+ { propA :: String,+ propB :: Bool+ }++instance FromJSON MissingRequired where+ parseJSON = withObject "MissingRequired" $ \o ->+ MissingRequired+ <$> o+ .: "propA"+ <*> o+ .: "propB"++instance ToSchema MissingRequired where+ declareNamedSchema _ = do+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)+ return+ . NamedSchema (Just "MissingRequired")+ $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties+ .~ [ ("propA", stringSchema),+ ("propB", boolSchema)+ ]+ & required .~ ["propA"]++data MissingProperty = MissingProperty+ { propC :: String,+ propD :: Bool+ }++instance FromJSON MissingProperty where+ parseJSON = withObject "MissingProperty" $ \o ->+ MissingProperty+ <$> o+ .: "propC"+ <*> o+ .: "propD"++instance ToSchema MissingProperty where+ declareNamedSchema _ = do+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)+ return+ . NamedSchema (Just "MissingProperty")+ $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties .~ [("propC", stringSchema)]+ & required .~ ["propC"]++data WrongPropType = WrongPropType+ { propE :: String+ }++instance FromJSON WrongPropType where+ parseJSON = withObject "WrongPropType" $ \o ->+ WrongPropType+ <$> o+ .: "propE"++instance ToSchema WrongPropType where+ declareNamedSchema _ = do+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)+ return+ . NamedSchema (Just "WrongPropType")+ $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties .~ [("propE", boolSchema)]+ & required .~ ["propE"]
+ test/Data/OpenApi/Schema/RoundtripSpec.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Property-based round-trip coverage for 3.1 'Schema' values (EP-7).+--+-- There is no @Arbitrary Schema@ instance in the tree (EP-3/EP-4 did not add one;+-- see the EP-7 Surprises). Rather than author a full recursive instance for the+-- ~50-field record, this generator combines a random subset of independent+-- single-field "fragments" — each exercising a 3.1 keyword — and asserts the+-- result survives @decode . encode@.+module Data.OpenApi.Schema.RoundtripSpec where++import Data.Aeson (decode, encode)+import Data.OpenApi+import Data.OpenApi.Internal+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++strSchema :: Schema+strSchema = mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}++numSchema :: Schema+numSchema = mempty {_schemaType = Just (OpenApiTypeSingle OpenApiNumber)}++-- | Independent single-field fragments, each setting one 3.1 keyword.+fragments :: [Schema -> Schema]+fragments =+ [ \s -> s {_schemaType = Just (OpenApiTypeArray [OpenApiString, OpenApiNull])},+ \s -> s {_schemaExclusiveMinimum = Just 0, _schemaExclusiveMaximum = Just 100},+ \s -> s {_schemaMaximum = Just 10},+ \s -> s {_schemaConst = Just "fixed"},+ \s -> s {_schemaPrefixItems = Just [Inline strSchema, Inline numSchema]},+ \s -> s {_schemaItems = Just (OpenApiItemsBoolean False)},+ \s -> s {_schemaContains = Just (Inline numSchema), _schemaMinContains = Just 1},+ \s -> s {_schemaIf = Just (Inline strSchema), _schemaThen = Just (Inline numSchema)},+ \s -> s {_schemaExamples = Just ["a", "b"]},+ \s -> s {_schemaId = Just "https://example/s"},+ \s -> s {_schemaRef = Just "#/$defs/A"},+ \s -> s {_schemaTitle = Just "t", _schemaDescription = Just "d"},+ \s -> s {_schemaUnevaluatedItems = Just (Inline strSchema)}+ ]++genSchema :: Gen Schema+genSchema = do+ fs <- sublistOf fragments+ pure (foldr (\f acc -> f acc) mempty fs)++prop_schema31_roundtrip :: Property+prop_schema31_roundtrip = forAll genSchema $ \s ->+ (decode (encode s) :: Maybe Schema) === Just s++spec :: Spec+spec =+ describe "Schema 3.1 round-trip" $+ prop "decode . encode == Just for random 3.1 schemas" prop_schema31_roundtrip
+ test/Data/OpenApi/Schema/Validation31Spec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++-- | OpenAPI 3.1 / JSON Schema 2020-12 keyword validation (EP-6): type arrays,+-- numeric exclusive bounds, prefixItems, contains/minContains/maxContains,+-- if/then/else, const, and best-effort unevaluatedProperties/unevaluatedItems.+module Data.OpenApi.Schema.Validation31Spec where++import Data.Aeson (Value (..), object, (.=))+import Data.OpenApi+import Data.OpenApi.Internal+import Test.Hspec++spec :: Spec+spec = describe "OpenAPI 3.1 keyword validation" $ do+ -- M1: type arrays (matches-any; OpenApiNull matches JSON null)+ it "type [string,null] accepts a string and null, rejects a number" $ do+ let s = mempty {_schemaType = Just (OpenApiTypeArray [OpenApiString, OpenApiNull])}+ validateJSON mempty s (String "hi") `shouldBe` []+ validateJSON mempty s Null `shouldBe` []+ validateJSON mempty s (Number 3) `shouldNotBe` []++ -- M1: numeric exclusive bounds (independent of maximum/minimum)+ it "exclusiveMinimum 0 / exclusiveMaximum 100 accept 50, reject 0 and 100" $ do+ let s =+ mempty+ { _schemaType = Just (OpenApiTypeSingle OpenApiNumber),+ _schemaExclusiveMinimum = Just 0,+ _schemaExclusiveMaximum = Just 100+ }+ validateJSON mempty s (Number 50) `shouldBe` []+ validateJSON mempty s (Number 0) `shouldNotBe` []+ validateJSON mempty s (Number 100) `shouldNotBe` []++ -- M2: prefixItems + items:false (tuple)+ it "prefixItems [string,number] + items:false validates [a,1], rejects extras/wrong types" $ do+ let s =+ mempty+ { _schemaType = Just (OpenApiTypeSingle OpenApiArray),+ _schemaPrefixItems =+ Just+ [ Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}),+ Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiNumber)})+ ],+ _schemaItems = Just (OpenApiItemsBoolean False)+ }+ validateJSON mempty s (Array [String "a", Number 1]) `shouldBe` []+ validateJSON mempty s (Array [String "a", Number 1, Bool True]) `shouldNotBe` []+ validateJSON mempty s (Array [Number 1, String "a"]) `shouldNotBe` []++ -- M2: contains + minContains+ it "contains integer + minContains 2 accepts two integers, rejects fewer" $ do+ let s =+ mempty+ { _schemaType = Just (OpenApiTypeSingle OpenApiArray),+ _schemaContains =+ Just (Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiInteger)})),+ _schemaMinContains = Just 2+ }+ validateJSON mempty s (Array [Number 1, Number 2, String "x"]) `shouldBe` []+ validateJSON mempty s (Array [String "x"]) `shouldNotBe` []++ -- M2: maxContains+ it "contains integer + maxContains 1 rejects two integers" $ do+ let s =+ mempty+ { _schemaType = Just (OpenApiTypeSingle OpenApiArray),+ _schemaContains =+ Just (Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiInteger)})),+ _schemaMaxContains = Just 1+ }+ validateJSON mempty s (Array [Number 1, String "x"]) `shouldBe` []+ validateJSON mempty s (Array [Number 1, Number 2]) `shouldNotBe` []++ -- M3: if/then (kept scalar to avoid this engine's strict-object behavior and+ -- its no-op pattern checker: "if the value is a string, then it must be \"yes\"").+ it "if (string) then const yes; non-string skips the constraint" $ do+ let s =+ mempty+ { _schemaIf = Just (Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)})),+ _schemaThen = Just (Inline (mempty {_schemaConst = Just (String "yes")}))+ }+ validateJSON mempty s (String "yes") `shouldBe` [] -- matches if, then satisfied+ validateJSON mempty s (String "no") `shouldNotBe` [] -- matches if, then violated+ validateJSON mempty s (Number 42) `shouldBe` [] -- if not matched, no else -> ok++ -- M3: const+ it "const 42 accepts 42, rejects 43" $ do+ let s = mempty {_schemaConst = Just (Number 42)}+ validateJSON mempty s (Number 42) `shouldBe` []+ validateJSON mempty s (Number 43) `shouldNotBe` []++ -- M4: best-effort unevaluatedProperties (local-only)+ it "unevaluatedProperties:false rejects a property not in properties" $ do+ let s =+ mempty+ { _schemaType = Just (OpenApiTypeSingle OpenApiObject),+ _schemaProperties =+ [("a", Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}))],+ _schemaUnevaluatedProperties = Just (AdditionalPropertiesAllowed False)+ }+ validateJSON mempty s (object ["a" .= ("x" :: String)]) `shouldBe` []+ validateJSON mempty s (object ["a" .= ("x" :: String), "b" .= ("y" :: String)]) `shouldNotBe` []++ -- M4: best-effort unevaluatedItems (local-only). The unevaluated schema requires+ -- a string; the third element (a bool) is beyond prefixItems and so must satisfy it.+ -- (A `{not:{}}` "always-false" schema would not work: this engine does not validate `not`.)+ it "unevaluatedItems requires string; rejects a non-string beyond prefixItems" $ do+ let s =+ mempty+ { _schemaType = Just (OpenApiTypeSingle OpenApiArray),+ _schemaPrefixItems =+ Just+ [ Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}),+ Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiNumber)})+ ],+ _schemaUnevaluatedItems = Just (Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}))+ }+ validateJSON mempty s (Array [String "a", Number 1]) `shouldBe` []+ validateJSON mempty s (Array [String "a", Number 1, Bool True]) `shouldNotBe` []
+ test/Data/OpenApi/Schema/ValidationSpec.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.OpenApi.Schema.ValidationSpec where++import Control.Applicative+import Control.Lens ((&), (.~), (?~))+import Data.Aeson+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+#endif+import Data.Aeson.Types+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Hashable (Hashable)+import Data.Int+import Data.IntMap (IntMap)+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)+import Data.Map (Map, fromList)+import Data.Monoid (mempty)+import Data.OpenApi+import Data.OpenApi.Aeson.Compat (stringToKey)+import Data.OpenApi.Declare+import Data.Proxy+import Data.Set (Set)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time+import Data.Version (Version)+import Data.Word+import GHC.Generics+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import "unordered-containers" Data.HashSet (HashSet)+import "unordered-containers" Data.HashSet qualified as HashSet++shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool+shouldValidate _ x = validateToJSON x == []++shouldNotValidate :: forall a. (ToSchema a) => (a -> Value) -> a -> Bool+shouldNotValidate f = not . null . validateJSON defs sch . f+ where+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty++spec :: Spec+spec = do+ describe "Validation" $ do+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)+ prop "String" $ shouldValidate (Proxy :: Proxy String)+ prop "()" $ shouldValidate (Proxy :: Proxy ())+ prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)+ prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])+ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))+ prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))+ prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)+ prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))+ prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))+ prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))+ prop "Person" $ shouldValidate (Proxy :: Proxy Person)+ prop "Color" $ shouldValidate (Proxy :: Proxy Color)+ prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)+ prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)+ prop "Light" $ shouldValidate (Proxy :: Proxy Light)+ prop "Light TaggedObject" $ shouldValidate (Proxy :: Proxy LightTaggedObject)+ prop "Light UntaggedValue" $ shouldValidate (Proxy :: Proxy LightUntaggedValue)+ prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)+ prop "Version" $ shouldValidate (Proxy :: Proxy Version)+ prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)++ describe "invalid cases" $ do+ prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON+ prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON+ prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON+ prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON+ prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON++main :: IO ()+main = hspec spec++-- ========================================================================+-- Person (simple record with optional fields)+-- ========================================================================+data Person = Person+ { name :: String,+ phone :: Integer,+ email :: Maybe String+ }+ deriving (Show, Generic)++instance ToJSON Person++instance ToSchema Person++instance Arbitrary Person where+ arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary++invalidPersonToJSON :: Person -> Value+invalidPersonToJSON Person {..} =+ object+ [ stringToKey "personName" .= toJSON name,+ stringToKey "personPhone" .= toJSON phone,+ stringToKey "personEmail" .= toJSON email+ ]++-- ========================================================================+-- Color (enum)+-- ========================================================================+data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)++instance ToJSON Color++instance ToSchema Color++instance Arbitrary Color where+ arbitrary = arbitraryBoundedEnum++invalidColorToJSON :: Color -> Value+invalidColorToJSON Red = toJSON "red"+invalidColorToJSON Green = toJSON "green"+invalidColorToJSON Blue = toJSON "blue"++-- ========================================================================+-- Paint (record with bounded enum property)+-- ========================================================================++newtype Paint = Paint {color :: Color}+ deriving (Show, Generic)++instance ToJSON Paint++instance ToSchema Paint++instance Arbitrary Paint where+ arbitrary = Paint <$> arbitrary++invalidPaintToJSON :: Paint -> Value+invalidPaintToJSON = toJSON . color++-- ========================================================================+-- MyRoseTree (custom datatypeNameModifier)+-- ========================================================================++data MyRoseTree = MyRoseTree+ { root :: String,+ trees :: [MyRoseTree]+ }+ deriving (Show, Generic)++instance ToJSON MyRoseTree++instance ToSchema MyRoseTree where+ declareNamedSchema =+ genericDeclareNamedSchema+ defaultSchemaOptions+ { datatypeNameModifier = drop (length "My")+ }++instance Arbitrary MyRoseTree where+ arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary)+ where+ limit = 4+ cut 0 (MyRoseTree x _) = MyRoseTree x []+ cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs)++-- ========================================================================+-- Light (sum type)+-- ========================================================================++data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)++instance ToSchema Light where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions {Data.OpenApi.sumEncoding = ObjectWithSingleField}++instance ToJSON Light where+ toJSON = genericToJSON defaultOptions {Data.Aeson.Types.sumEncoding = ObjectWithSingleField}++instance Arbitrary Light where+ arbitrary =+ oneof+ [ return NoLight,+ LightFreq <$> arbitrary,+ LightColor <$> arbitrary+ ]++invalidLightToJSON :: Light -> Value+invalidLightToJSON = genericToJSON defaultOptions++-- Check all SumEncoding flavors.++newtype LightTaggedObject = LightTaggedObject Light+ deriving (Show)++instance ToJSON LightTaggedObject where+ toJSON (LightTaggedObject light) = genericToJSON defaultOptions {Data.Aeson.Types.sumEncoding = defaultTaggedObject} light++instance ToSchema LightTaggedObject where+ declareNamedSchema _ =+ genericDeclareNamedSchema defaultSchemaOptions {Data.OpenApi.sumEncoding = defaultTaggedObject} (Proxy :: Proxy Light)++instance Arbitrary LightTaggedObject where+ arbitrary = LightTaggedObject <$> arbitrary++newtype LightUntaggedValue = LightUntaggedValue Light+ deriving (Show)++instance ToJSON LightUntaggedValue where+ toJSON (LightUntaggedValue light) = genericToJSON defaultOptions {Data.Aeson.Types.sumEncoding = UntaggedValue} light++instance ToSchema LightUntaggedValue where+ declareNamedSchema _ =+ genericDeclareNamedSchema defaultSchemaOptions {Data.OpenApi.sumEncoding = UntaggedValue} (Proxy :: Proxy Light)++instance Arbitrary LightUntaggedValue where+ arbitrary = LightUntaggedValue <$> arbitrary++-- ========================================================================+-- ButtonImages (bounded enum key mapping)+-- ========================================================================++data ButtonState = Neutral | Focus | Active | Hover | Disabled+ deriving (Show, Eq, Ord, Bounded, Enum, Generic)++instance ToJSON ButtonState++instance ToSchema ButtonState++instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)++instance Arbitrary ButtonState where+ arbitrary = arbitraryBoundedEnum++type ImageUrl = T.Text++newtype ButtonImages = ButtonImages {getButtonImages :: Map ButtonState ImageUrl}+ deriving (Show, Generic)++instance ToJSON ButtonImages where+ toJSON = toJSON . getButtonImages++instance ToSchema ButtonImages where+ declareNamedSchema =+ genericDeclareNamedSchemaNewtype+ defaultSchemaOptions+ declareSchemaBoundedEnumKeyMapping++invalidButtonImagesToJSON :: ButtonImages -> Value+invalidButtonImagesToJSON = genericToJSON defaultOptions++instance Arbitrary ButtonImages where+ arbitrary = ButtonImages <$> arbitrary++-- ========================================================================+-- FreeForm (wraps a raw JSON Value)+-- ========================================================================++data FreeForm = FreeForm {jsonContent :: Map T.Text Value}+ deriving (Show, Generic)++instance ToJSON FreeForm where+ toJSON = toJSON . jsonContent++instance ToSchema FreeForm where+ declareNamedSchema _ =+ pure $+ NamedSchema (Just $ T.pack "FreeForm") $+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & additionalProperties ?~ AdditionalPropertiesAllowed True++instance Arbitrary FreeForm where+ arbitrary = (FreeForm . fromList) <$> genObj+ where+ genObj = listOf $ do+ k <- arbitrary+ v <- oneof [String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null]+ pure (k, v)++instance Eq ZonedTime where+ ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y++-- ========================================================================+-- Arbitrary instance for Data.Aeson.Value+-- ========================================================================++-- These instances were introduces in aeson upstream in 2.0.3+#if !MIN_VERSION_aeson(2,0,3)+instance Arbitrary Value where+ -- Weights are almost random+ -- Uniform oneof tends not to build complex objects cause of recursive call.+ arbitrary = resize 4 $ frequency+ [ (3, Object <$> arbitrary)+ , (3, Array <$> arbitrary)+ , (3, String <$> arbitrary)+ , (3, Number <$> arbitrary)+ , (3, Bool <$> arbitrary)+ , (1, return Null) ]++#if MIN_VERSION_aeson(2,0,0)+instance Arbitrary v => Arbitrary (KeyMap.KeyMap v) where+ arbitrary = KeyMap.fromList <$> arbitrary++instance Arbitrary Key.Key where+ arbitrary = Key.fromText <$> arbitrary+#endif+#endif
+ test/Data/OpenApi/Schema31Spec.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++-- | Round-trip coverage for the OpenAPI 3.1 / JSON Schema 2020-12 additive fields+-- and the @$@-prefixed identification/reference keywords introduced in EP-4.+module Data.OpenApi.Schema31Spec where++import Data.Aeson (Value, decode, encode, object, toJSON, (.=))+import Data.Aeson.QQ.Simple (aesonQQ)+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.OpenApi+import Data.OpenApi.Internal+import Data.Text (Text)+import SpecCommon+import Test.Hspec++-- Small helpers to keep the cases terse.+strSchema :: Schema+strSchema = mempty {_schemaType = Just (OpenApiTypeSingle OpenApiString)}++numSchema :: Schema+numSchema = mempty {_schemaType = Just (OpenApiTypeSingle OpenApiNumber)}++spec :: Spec+spec = do+ describe "JSON Schema 2020-12 additive fields" $ do+ context "prefixItems with items:false" $+ mempty+ { _schemaPrefixItems = Just [Inline strSchema, Inline numSchema],+ _schemaItems = Just (OpenApiItemsBoolean False)+ }+ <=> [aesonQQ|+ { "prefixItems": [ {"type":"string"}, {"type":"number"} ]+ , "items": false }+ |]++ context "if/then conditional" $+ mempty+ { _schemaIf = Just (Inline (mempty {_schemaConst = Just "USA"})),+ _schemaThen = Just (Inline strSchema)+ }+ <=> [aesonQQ|+ { "if": {"const":"USA"}, "then": {"type":"string"} }+ |]++ context "const" $+ mempty {_schemaConst = Just (toJSON (42 :: Int))} <=> [aesonQQ| {"const": 42} |]++ context "contains with minContains" $+ mempty+ { _schemaContains = Just (Inline (mempty {_schemaType = Just (OpenApiTypeSingle OpenApiInteger)})),+ _schemaMinContains = Just 1+ }+ <=> [aesonQQ| {"contains": {"type":"integer"}, "minContains": 1} |]++ context "examples (3.1 array form)" $+ mempty {_schemaExamples = Just [toJSON (1 :: Int), toJSON ("x" :: Text)]}+ <=> [aesonQQ| {"examples": [1, "x"]} |]++ describe "$-prefixed identification/reference keywords" $ do+ context "$defs" $+ mempty+ { _schemaDefs = Just (InsOrdHashMap.fromList [("A", Inline strSchema)])+ }+ <=> [aesonQQ| {"$defs": {"A": {"type":"string"}}} |]++ it "$defs emits the literal \"$defs\" key" $ do+ let s = mempty {_schemaDefs = Just (InsOrdHashMap.fromList [("A", Inline strSchema)])}+ toJSON s `shouldBe` object ["$defs" .= object ["A" .= object ["type" .= ("string" :: Text)]]]++ it "$id + sibling $ref stays Inline and round-trips" $ do+ let s = mempty {_schemaId = Just "https://example/s", _schemaRef = Just "#/$defs/A"}+ toJSON s+ `shouldBe` object+ [ "$id" .= ("https://example/s" :: Text),+ "$ref" .= ("#/$defs/A" :: Text)+ ]+ (decode (encode s) :: Maybe Schema) `shouldBe` Just s+ -- As a sub-schema, a $ref that is not a component reference parses to Inline (not Ref):+ (decode (encode s) :: Maybe (Referenced Schema)) `shouldBe` Just (Inline s)++ it "a pure component $ref still parses to Ref" $ do+ (decode "{\"$ref\":\"#/components/schemas/Foo\"}" :: Maybe (Referenced Schema))+ `shouldBe` Just (Ref (Reference "Foo"))++ describe "boolean sub-schemas (read direction)" $ do+ it "decodes contains:true / unevaluatedItems:false to canonical inline schemas" $ do+ let expected =+ mempty+ { _schemaContains = Just (Inline mempty),+ _schemaUnevaluatedItems = Just (Inline (mempty {_schemaNot = Just (Inline mempty)}))+ }+ (decode "{\"contains\":true,\"unevaluatedItems\":false}" :: Maybe Schema)+ `shouldBe` Just expected
+ test/Data/OpenApi/SchemaSpec.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.OpenApi.SchemaSpec where++import Control.Lens ((^.))+import Data.Aeson (Value)+import Data.HashMap.Strict qualified as HM+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.OpenApi+import Data.OpenApi.CommonTestTypes+import Data.OpenApi.Declare+import Data.Proxy+import Data.Set (Set)+import Data.Text qualified as Text+import Data.Time.LocalTime+import Prelude.Compat+import SpecCommon+import Test.Hspec+import Prelude ()++checkToSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec+checkToSchema proxy js = toSchema proxy <=> js++checkSchemaName :: (HasCallStack, ToSchema a) => Maybe String -> Proxy a -> Spec+checkSchemaName sname proxy =+ it ("schema name is " ++ show sname)+ $ schemaName proxy+ `shouldBe` fmap Text.pack sname++checkDefs :: (HasCallStack, ToSchema a) => Proxy a -> [String] -> Spec+checkDefs proxy names =+ it ("uses these definitions " ++ show names)+ $ InsOrdHashMap.keys defs+ `shouldBe` map Text.pack names+ where+ defs = execDeclare (declareNamedSchema proxy) mempty++checkProperties :: (HasCallStack, ToSchema a) => Proxy a -> [String] -> Spec+checkProperties proxy names =+ it ("has these fields in order " ++ show names)+ $ InsOrdHashMap.keys fields+ `shouldBe` map Text.pack names+ where+ fields = toSchema proxy ^. properties++checkInlinedSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec+checkInlinedSchema proxy js = toInlinedSchema proxy <=> js++checkInlinedSchemas :: (HasCallStack, ToSchema a) => [String] -> Proxy a -> Value -> Spec+checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js+ where+ (defs, s) = runDeclare (declareSchema proxy) mempty++checkInlinedRecSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec+checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js+ where+ (defs, s) = runDeclare (declareSchema proxy) mempty++checkToSchemaDeclare :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec+checkToSchemaDeclare proxy js = runDeclare (declareSchemaRef proxy) mempty <=> js++spec :: Spec+spec = do+ describe "Generic ToSchema" $ do+ context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON+ context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON+ context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON+ context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON+ context "Point5 (many field record)" $ do+ checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON+ checkProperties (Proxy :: Proxy Point5) point5Properties+ context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON+ context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON+ context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON+ context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON+ context "Unary records" $ do+ context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON+ context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON+ context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON+ context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON+ context "Natural Language (single field data with recursive fields)" $ checkToSchemaDeclare (Proxy :: Proxy Predicate) predicateSchemaDeclareJSON+ context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON+ context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'+ context "Sum types" $ do+ context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON+ context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON+ context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON+ context "UnsignedInts" $ checkToSchema (Proxy :: Proxy UnsignedInts) unsignedIntsSchemaJSON+ context "Schema name" $ do+ context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)+ context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))+ context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)+ context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)+ describe "Generic Definitions" $ do+ context "Unit" $ checkDefs (Proxy :: Proxy Unit) []+ context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]+ context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]+ context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]+ context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]+ context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]+ context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]+ context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []+ describe "Inlining Schemas" $ do+ context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON+ context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON+ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON+ context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON+ context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON+ context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'+ describe "Bounded Enum key mapping" $ do+ context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON+ context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON++main :: IO ()+main = hspec spec
+ test/Data/OpenApi/TopLevel31Spec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++-- | Round-trip coverage for the OpenAPI 3.1 top-level object features added in EP-5:+-- @Info.summary@, @License.identifier@, @OpenApi.webhooks@, and @PathItem.$ref@.+module Data.OpenApi.TopLevel31Spec where++import Control.Lens hiding ((.=))+import Data.Aeson (Value, decode, encode, object, toJSON, (.=))+import Data.Aeson.QQ.Simple (aesonQQ)+import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap+import Data.OpenApi+import Data.OpenApi.Internal+import Data.Text (Text)+import SpecCommon+import Test.Hspec++licenseIdentifierExample :: License+licenseIdentifierExample = "MIT" & identifier ?~ "MIT"++licenseIdentifierExampleJSON :: Value+licenseIdentifierExampleJSON =+ [aesonQQ|+{+ "name": "MIT",+ "identifier": "MIT"+}+|]++pathItemRefExample :: PathItem+pathItemRefExample =+ mempty+ & ref ?~ "#/components/pathItems/Foo"+ & summary ?~ "Shared path item"++pathItemRefExampleJSON :: Value+pathItemRefExampleJSON =+ [aesonQQ|+{+ "$ref": "#/components/pathItems/Foo",+ "summary": "Shared path item"+}+|]++webhooksExample :: OpenApi+webhooksExample =+ mempty+ & webhooks+ .~ InsOrdHashMap.fromList+ [("newPet", Inline (mempty & summary ?~ "A new pet was created"))]++spec :: Spec+spec = do+ describe "Info.summary (OpenAPI 3.1)" $+ it "round-trips a summary and emits the \"summary\" key" $ do+ let i = (mempty :: Info) & title .~ "Pets" & summary ?~ "A pet store API" & version .~ "1.0.0"+ i ^. summary `shouldBe` Just "A pet store API"+ (decode (encode i) :: Maybe Info) `shouldBe` Just i++ describe "License Object (SPDX identifier)" $+ licenseIdentifierExample <=> licenseIdentifierExampleJSON++ describe "License.identifier is url-free" $+ it "decodes {name, identifier} with no url" $+ (decode "{\"name\":\"MIT\",\"identifier\":\"MIT\"}" :: Maybe License)+ `shouldBe` Just (License "MIT" (Just "MIT") Nothing)++ describe "OpenApi.webhooks (OpenAPI 3.1)" $ do+ it "round-trips an inline webhook path item" $+ (decode (encode webhooksExample) :: Maybe OpenApi) `shouldBe` Just webhooksExample+ it "decodes a webhook value given by $ref into Ref" $+ (decode "{\"$ref\":\"#/components/pathItems/Foo\"}" :: Maybe (Referenced PathItem))+ `shouldBe` Just (Ref (Reference "Foo"))++ describe "PathItem Object ($ref, OpenAPI 3.1)" $ do+ pathItemRefExample <=> pathItemRefExampleJSON+ it "emits the literal \"$ref\" key, not \"ref\"" $+ toJSON pathItemRefExample+ `shouldBe` object+ [ "$ref" .= ("#/components/pathItems/Foo" :: Text),+ "summary" .= ("Shared path item" :: Text)+ ]
+ test/Data/OpenApiSpec.hs view
@@ -0,0 +1,1157 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.OpenApiSpec where++import Control.Lens+import Data.Aeson+import Data.Aeson.QQ.Simple+import Data.HashMap.Strict (HashMap)+import Data.HashSet.InsOrd qualified as InsOrdHS+import Data.OpenApi+import Data.Text (Text)+import Prelude.Compat+import SpecCommon+import Test.Hspec hiding (example)+import Prelude ()++spec :: Spec+spec = do+ describe "License Object" $ licenseExample <=> licenseExampleJSON+ describe "Contact Object" $ contactExample <=> contactExampleJSON+ describe "Info Object" $ infoExample <=> infoExampleJSON+ describe "Operation Object" $ operationExample <=> operationExampleJSON+ describe "Schema Object" $ do+ context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON+ context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON+ context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON+ context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON+ describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON+ describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON+ describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON+ describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON+ describe "OAuth2 Security Definitions with empty Scope" $ oAuth2SecurityDefinitionsEmptyExample <=> oAuth2SecurityDefinitionsEmptyExampleJSON+ describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON+ describe "Swagger Object" $ do+ context "Example with no paths" $ do+ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON+ it "fails to parse a spec with a wrong Openapi spec version" $ do+ (fromJSON wrongVersionExampleJSON :: Result OpenApi) `shouldBe` Error "The provided version 3.0.4 is out of the allowed range >=3.1.0 && <=3.1.1"+ context "Todo Example" $ swaggerExample <=> swaggerExampleJSON+ context "PetStore Example" $ do+ it "decodes successfully" $ do+ fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False)+ it "roundtrips: fmap toJSON . fromJSON" $ do+ (toJSON :: OpenApi -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON+ context "Security schemes" $ do+ it "merged correctly" $ do+ let merged = oAuth2SecurityDefinitionsReadOpenApi <> oAuth2SecurityDefinitionsWriteOpenApi <> oAuth2SecurityDefinitionsEmptyOpenApi+ merged `shouldBe` oAuth2SecurityDefinitionsOpenApi++main :: IO ()+main = hspec spec++-- =======================================================================+-- Info object+-- =======================================================================++infoExample :: Info+infoExample =+ mempty+ & title .~ "Swagger Sample App"+ & description ?~ "This is a sample server Petstore server."+ & termsOfService ?~ "http://swagger.io/terms/"+ & contact ?~ contactExample+ & license ?~ licenseExample+ & version .~ "1.0.1"++infoExampleJSON :: Value+infoExampleJSON =+ [aesonQQ|+{+ "title": "Swagger Sample App",+ "description": "This is a sample server Petstore server.",+ "termsOfService": "http://swagger.io/terms/",+ "contact": {+ "name": "API Support",+ "url": "http://www.swagger.io/support",+ "email": "support@swagger.io"+ },+ "license": {+ "name": "Apache 2.0",+ "url": "http://www.apache.org/licenses/LICENSE-2.0.html"+ },+ "version": "1.0.1"+}+|]++-- =======================================================================+-- Contact object+-- =======================================================================++contactExample :: Contact+contactExample =+ mempty+ & name ?~ "API Support"+ & url ?~ URL "http://www.swagger.io/support"+ & email ?~ "support@swagger.io"++contactExampleJSON :: Value+contactExampleJSON =+ [aesonQQ|+{+ "name": "API Support",+ "url": "http://www.swagger.io/support",+ "email": "support@swagger.io"+}+|]++-- =======================================================================+-- License object+-- =======================================================================++licenseExample :: License+licenseExample =+ "Apache 2.0"+ & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"++licenseExampleJSON :: Value+licenseExampleJSON =+ [aesonQQ|+{+ "name": "Apache 2.0",+ "url": "http://www.apache.org/licenses/LICENSE-2.0.html"+}+|]++-- =======================================================================+-- Operation object+-- =======================================================================++operationExample :: Operation+operationExample =+ mempty+ & tags .~ InsOrdHS.fromList ["pet"]+ & summary ?~ "Updates a pet in the store with form data"+ & description ?~ ""+ & operationId ?~ "updatePetWithForm"+ & parameters+ .~ [ Inline+ ( mempty+ & name .~ "petId"+ & description ?~ "ID of pet that needs to be updated"+ & required ?~ True+ & in_ .~ ParamPath+ & schema ?~ Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString)+ )+ ]+ & requestBody+ ?~ Inline+ ( mempty+ & content . at "application/x-www-form-urlencoded"+ ?~ ( mempty+ & schema+ ?~ ( Inline+ ( mempty+ & properties . at "petId"+ ?~ Inline+ ( mempty+ & description ?~ "Updated name of the pet"+ & type_ ?~ OpenApiTypeSingle OpenApiString+ )+ & properties . at "status"+ ?~ Inline+ ( mempty+ & description ?~ "Updated status of the pet"+ & type_ ?~ OpenApiTypeSingle OpenApiString+ )+ )+ )+ )+ )+ & at 200 ?~ "Pet updated."+ & at 405 ?~ "Invalid input"+ & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]++operationExampleJSON :: Value+operationExampleJSON =+ [aesonQQ|+{+ "tags": [+ "pet"+ ],+ "summary": "Updates a pet in the store with form data",+ "description": "",+ "operationId": "updatePetWithForm",+ "parameters": [+ {+ "required": true,+ "schema": {+ "type": "string"+ },+ "in": "path",+ "name": "petId",+ "description": "ID of pet that needs to be updated"+ }+ ],+ "requestBody": {+ "content": {+ "application/x-www-form-urlencoded": {+ "schema": {+ "properties": {+ "petId": {+ "type": "string",+ "description": "Updated name of the pet"+ },+ "status": {+ "type": "string",+ "description": "Updated status of the pet"+ }+ }+ }+ }+ }+ },+ "responses": {+ "200": {+ "description": "Pet updated."+ },+ "405": {+ "description": "Invalid input"+ }+ },+ "security": [+ {+ "petstore_auth": [+ "write:pets",+ "read:pets"+ ]+ }+ ]+}+|]++-- =======================================================================+-- Schema object+-- =======================================================================++schemaPrimitiveExample :: Schema+schemaPrimitiveExample =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ & format ?~ "email"++schemaPrimitiveExampleJSON :: Value+schemaPrimitiveExampleJSON =+ [aesonQQ|+{+ "type": "string",+ "format": "email"+}+|]++schemaSimpleModelExample :: Schema+schemaSimpleModelExample =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & required .~ ["name"]+ & properties+ .~ [ ("name", Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString)),+ ("address", Ref (Reference "Address")),+ ( "age",+ Inline $ mempty+ & minimum_ ?~ 0+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & format ?~ "int32"+ )+ ]++schemaSimpleModelExampleJSON :: Value+schemaSimpleModelExampleJSON =+ [aesonQQ|+{ "required": [ "name" ],+ "properties": {+ "name": {+ "type": "string"+ },+ "address": {+ "$ref": "#/components/schemas/Address"+ },+ "age": {+ "format": "int32",+ "minimum": 0,+ "type": "integer"+ }+ },+ "type": "object"+}+|]++schemaModelDictExample :: Schema+schemaModelDictExample =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString))++schemaModelDictExampleJSON :: Value+schemaModelDictExampleJSON =+ [aesonQQ|+{+ "type": "object",+ "additionalProperties": {+ "type": "string"+ }+}+|]++schemaAdditionalExample :: Schema+schemaAdditionalExample =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & additionalProperties ?~ AdditionalPropertiesAllowed True++schemaAdditionalExampleJSON :: Value+schemaAdditionalExampleJSON =+ [aesonQQ|+{+ "type": "object",+ "additionalProperties": true+}+|]++schemaWithExampleExample :: Schema+schemaWithExampleExample =+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties+ .~ [ ( "id",+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & format ?~ "int64"+ ),+ ( "name",+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ )+ ]+ & required .~ ["name"]+ & example+ ?~ [aesonQQ|+ {+ "name": "Puma",+ "id": 1+ }+ |]++schemaWithExampleExampleJSON :: Value+schemaWithExampleExampleJSON =+ [aesonQQ|+{+ "type": "object",+ "properties": {+ "id": {+ "type": "integer",+ "format": "int64"+ },+ "name": {+ "type": "string"+ }+ },+ "required": [+ "name"+ ],+ "example": {+ "name": "Puma",+ "id": 1+ }+}+|]++-- =======================================================================+-- Definitions object+-- =======================================================================++definitionsExample :: HashMap Text Schema+definitionsExample =+ [ ( "Category",+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties+ .~ [ ( "id",+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & format ?~ "int64"+ ),+ ("name", Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString))+ ]+ ),+ ( "Tag",+ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties+ .~ [ ( "id",+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & format ?~ "int64"+ ),+ ("name", Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString))+ ]+ )+ ]++definitionsExampleJSON :: Value+definitionsExampleJSON =+ [aesonQQ|+{+ "Category": {+ "type": "object",+ "properties": {+ "id": {+ "type": "integer",+ "format": "int64"+ },+ "name": {+ "type": "string"+ }+ }+ },+ "Tag": {+ "type": "object",+ "properties": {+ "id": {+ "type": "integer",+ "format": "int64"+ },+ "name": {+ "type": "string"+ }+ }+ }+}+|]++-- =======================================================================+-- Parameters Definition object+-- =======================================================================++paramsDefinitionExample :: HashMap Text Param+paramsDefinitionExample =+ [ ( "skipParam",+ mempty+ & name .~ "skip"+ & description ?~ "number of items to skip"+ & required ?~ True+ & in_ .~ ParamQuery+ & schema+ ?~ Inline+ ( mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & format ?~ "int32"+ )+ ),+ ( "limitParam",+ mempty+ & name .~ "limit"+ & description ?~ "max records to return"+ & required ?~ True+ & in_ .~ ParamQuery+ & schema+ ?~ Inline+ ( mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & format ?~ "int32"+ )+ )+ ]++paramsDefinitionExampleJSON :: Value+paramsDefinitionExampleJSON =+ [aesonQQ|+{+ "skipParam": {+ "name": "skip",+ "in": "query",+ "description": "number of items to skip",+ "required": true,+ "schema": {+ "type": "integer",+ "format": "int32"+ }+ },+ "limitParam": {+ "name": "limit",+ "in": "query",+ "description": "max records to return",+ "required": true,+ "schema": {+ "type": "integer",+ "format": "int32"+ }+ }+}+|]++-- =======================================================================+-- Responses Definition object+-- =======================================================================++responsesDefinitionExample :: HashMap Text Response+responsesDefinitionExample =+ [ ("NotFound", mempty & description .~ "Entity not found."),+ ("IllegalInput", mempty & description .~ "Illegal input for operation.")+ ]++responsesDefinitionExampleJSON :: Value+responsesDefinitionExampleJSON =+ [aesonQQ|+{+ "NotFound": {+ "description": "Entity not found."+ },+ "IllegalInput": {+ "description": "Illegal input for operation."+ }+}+|]++-- =======================================================================+-- Security Definition object+-- =======================================================================++securityDefinitionsExample :: SecurityDefinitions+securityDefinitionsExample =+ SecurityDefinitions+ [ ( "api_key",+ SecurityScheme+ { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader),+ _securitySchemeDescription = Nothing+ }+ ),+ ( "petstore_auth",+ SecurityScheme+ { _securitySchemeType =+ SecuritySchemeOAuth2+ ( mempty+ & implicit+ ?~ OAuth2Flow+ { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog",+ _oAath2RefreshUrl = Nothing,+ _oAuth2Scopes =+ [ ("write:pets", "modify pets in your account"),+ ("read:pets", "read your pets")+ ]+ }+ ),+ _securitySchemeDescription = Nothing+ }+ )+ ]++securityDefinitionsExampleJSON :: Value+securityDefinitionsExampleJSON =+ [aesonQQ|+{+ "api_key": {+ "in": "header",+ "name": "api_key",+ "type": "apiKey"+ },+ "petstore_auth": {+ "type": "oauth2",+ "flows": {+ "implicit": {+ "scopes": {+ "write:pets": "modify pets in your account",+ "read:pets": "read your pets"+ },+ "authorizationUrl": "http://swagger.io/api/oauth/dialog"+ }+ }+ }+}++|]++oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions+oAuth2SecurityDefinitionsReadExample =+ SecurityDefinitions+ [ ( "petstore_auth",+ SecurityScheme+ { _securitySchemeType =+ SecuritySchemeOAuth2+ ( mempty+ & implicit+ ?~ OAuth2Flow+ { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog",+ _oAath2RefreshUrl = Nothing,+ _oAuth2Scopes =+ [("read:pets", "read your pets")]+ }+ ),+ _securitySchemeDescription = Nothing+ }+ )+ ]++oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions+oAuth2SecurityDefinitionsWriteExample =+ SecurityDefinitions+ [ ( "petstore_auth",+ SecurityScheme+ { _securitySchemeType =+ SecuritySchemeOAuth2+ ( mempty+ & implicit+ ?~ OAuth2Flow+ { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog",+ _oAath2RefreshUrl = Nothing,+ _oAuth2Scopes =+ [("write:pets", "modify pets in your account")]+ }+ ),+ _securitySchemeDescription = Nothing+ }+ )+ ]++oAuth2SecurityDefinitionsEmptyExample :: SecurityDefinitions+oAuth2SecurityDefinitionsEmptyExample =+ SecurityDefinitions+ [ ( "petstore_auth",+ SecurityScheme+ { _securitySchemeType =+ SecuritySchemeOAuth2+ ( mempty+ & implicit+ ?~ OAuth2Flow+ { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog",+ _oAath2RefreshUrl = Nothing,+ _oAuth2Scopes = []+ }+ ),+ _securitySchemeDescription = Nothing+ }+ )+ ]++oAuth2SecurityDefinitionsExample :: SecurityDefinitions+oAuth2SecurityDefinitionsExample =+ oAuth2SecurityDefinitionsWriteExample+ <> oAuth2SecurityDefinitionsReadExample+ <> oAuth2SecurityDefinitionsEmptyExample++oAuth2SecurityDefinitionsExampleJSON :: Value+oAuth2SecurityDefinitionsExampleJSON =+ [aesonQQ|+{+ "petstore_auth": {+ "type": "oauth2",+ "flows": {+ "implicit": {+ "scopes": {+ "write:pets": "modify pets in your account",+ "read:pets": "read your pets"+ },+ "authorizationUrl": "http://swagger.io/api/oauth/dialog"+ }+ }+ }+}+|]++oAuth2SecurityDefinitionsEmptyExampleJSON :: Value+oAuth2SecurityDefinitionsEmptyExampleJSON =+ [aesonQQ|+{+ "petstore_auth": {+ "type": "oauth2",+ "flows": {+ "implicit": {+ "scopes": {},+ "authorizationUrl": "http://swagger.io/api/oauth/dialog"+ }+ }+ }+}+|]++oAuth2SecurityDefinitionsReadOpenApi :: OpenApi+oAuth2SecurityDefinitionsReadOpenApi =+ mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsReadExample++oAuth2SecurityDefinitionsWriteOpenApi :: OpenApi+oAuth2SecurityDefinitionsWriteOpenApi =+ mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsWriteExample++oAuth2SecurityDefinitionsEmptyOpenApi :: OpenApi+oAuth2SecurityDefinitionsEmptyOpenApi =+ mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsEmptyExample++oAuth2SecurityDefinitionsOpenApi :: OpenApi+oAuth2SecurityDefinitionsOpenApi =+ mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsExample++-- =======================================================================+-- Swagger object+-- =======================================================================++emptyPathsFieldExample :: OpenApi+emptyPathsFieldExample = mempty++wrongVersionExampleJSON :: Value+wrongVersionExampleJSON =+ [aesonQQ|+{+ "openapi": "3.0.4",+ "info": {"version": "", "title": ""},+ "paths": {},+ "components": {}+}+|]++emptyPathsFieldExampleJSON :: Value+emptyPathsFieldExampleJSON =+ [aesonQQ|+{+ "openapi": "3.1.0",+ "info": {"version": "", "title": ""},+ "paths": {},+ "components": {}+}+|]++swaggerExample :: OpenApi+swaggerExample =+ mempty+ -- & basePath ?~ "/"+ -- & schemes ?~ [Http]+ & info+ .~ ( mempty+ & version .~ "1.0"+ & title .~ "Todo API"+ & license ?~ "MIT"+ & license . _Just . url ?~ URL "http://mit.com"+ & description ?~ "This is an API that tests servant-swagger support for a Todo API"+ )+ & paths . at "/todo/{id}"+ ?~ ( mempty+ & get+ ?~ ( (mempty :: Operation)+ & responses . at 200+ ?~ Inline+ ( mempty+ & description .~ "OK"+ & content . at "application/json"+ ?~ ( mempty+ & schema+ ?~ Inline+ ( mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & example+ ?~ [aesonQQ|+ {+ "created": 100,+ "description": "get milk"+ } |]+ & description ?~ "This is some real Todo right here"+ & properties+ .~ [ ( "created",+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiInteger+ & format ?~ "int32"+ ),+ ("description", Inline (mempty & type_ ?~ OpenApiTypeSingle OpenApiString))+ ]+ )+ )+ )+ & parameters+ .~ [ Inline $ mempty+ & required ?~ True+ & name .~ "id"+ & description ?~ "TodoId param"+ & in_ .~ ParamPath+ & schema+ ?~ Inline+ ( mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ )+ ]+ & tags .~ InsOrdHS.fromList ["todo"]+ )+ )++swaggerExampleJSON :: Value+swaggerExampleJSON =+ [aesonQQ|+{+ "openapi": "3.1.0",+ "info": {+ "version": "1.0",+ "title": "Todo API",+ "license": {+ "url": "http://mit.com",+ "name": "MIT"+ },+ "description": "This is an API that tests servant-swagger support for a Todo API"+ },+ "paths": {+ "/todo/{id}": {+ "get": {+ "tags": [+ "todo"+ ],+ "parameters": [+ {+ "required": true,+ "schema": {+ "type": "string"+ },+ "in": "path",+ "name": "id",+ "description": "TodoId param"+ }+ ],+ "responses": {+ "200": {+ "content": {+ "application/json": {+ "schema": {+ "example": {+ "created": 100,+ "description": "get milk"+ },+ "type": "object",+ "description": "This is some real Todo right here",+ "properties": {+ "created": {+ "format": "int32",+ "type": "integer"+ },+ "description": {+ "type": "string"+ }+ }+ }+ }+ },+ "description": "OK"+ }+ }+ }+ }+ },+ "components": {}+}+|]++petstoreExampleJSON :: Value+petstoreExampleJSON =+ [aesonQQ|+{+ "openapi": "3.1.0",+ "info": {+ "version": "1.0.0",+ "title": "Swagger Petstore",+ "license": {+ "name": "MIT"+ }+ },+ "servers": [+ {+ "url": "http://petstore.swagger.io/v1"+ }+ ],+ "paths": {+ "/pets": {+ "get": {+ "summary": "List all pets",+ "operationId": "listPets",+ "tags": [+ "pets"+ ],+ "parameters": [+ {+ "name": "limit",+ "in": "query",+ "description": "How many items to return at one time (max 100)",+ "required": false,+ "schema": {+ "type": "integer",+ "format": "int32"+ }+ }+ ],+ "responses": {+ "200": {+ "description": "A paged array of pets",+ "headers": {+ "x-next": {+ "description": "A link to the next page of responses",+ "schema": {+ "type": "string"+ }+ }+ },+ "content": {+ "application/json": {+ "schema": {+ "type": "array",+ "items": {+ "type": "object",+ "required": [+ "id",+ "name"+ ],+ "properties": {+ "id": {+ "type": "integer",+ "format": "int64"+ },+ "name": {+ "type": "string"+ },+ "tag": {+ "type": "string"+ }+ }+ }+ }+ }+ }+ },+ "default": {+ "description": "unexpected error",+ "content": {+ "application/json": {+ "schema": {+ "type": "object",+ "required": [+ "code",+ "message"+ ],+ "properties": {+ "code": {+ "type": "integer",+ "format": "int32"+ },+ "message": {+ "type": "string"+ }+ }+ }+ }+ }+ }+ }+ },+ "post": {+ "summary": "Create a pet",+ "operationId": "createPets",+ "tags": [+ "pets"+ ],+ "responses": {+ "201": {+ "description": "Null response"+ },+ "default": {+ "description": "unexpected error",+ "content": {+ "application/json": {+ "schema": {+ "type": "object",+ "required": [+ "code",+ "message"+ ],+ "properties": {+ "code": {+ "type": "integer",+ "format": "int32"+ },+ "message": {+ "type": "string"+ }+ }+ }+ }+ }+ }+ }+ }+ },+ "/pets/{petId}": {+ "get": {+ "summary": "Info for a specific pet",+ "operationId": "showPetById",+ "tags": [+ "pets"+ ],+ "parameters": [+ {+ "name": "petId",+ "in": "path",+ "required": true,+ "description": "The id of the pet to retrieve",+ "schema": {+ "type": "string"+ }+ }+ ],+ "responses": {+ "200": {+ "description": "Expected response to a valid request",+ "content": {+ "application/json": {+ "schema": {+ "type": "object",+ "required": [+ "id",+ "name"+ ],+ "properties": {+ "id": {+ "type": "integer",+ "format": "int64"+ },+ "name": {+ "type": "string"+ },+ "tag": {+ "type": "string"+ }+ }+ }+ }+ }+ },+ "default": {+ "description": "unexpected error",+ "content": {+ "application/json": {+ "schema": {+ "type": "object",+ "required": [+ "code",+ "message"+ ],+ "properties": {+ "code": {+ "type": "integer",+ "format": "int32"+ },+ "message": {+ "type": "string"+ }+ }+ }+ }+ }+ }+ }+ }+ }+ },+ "components": {+ "schemas": {+ "Pet": {+ "type": "object",+ "required": [+ "id",+ "name"+ ],+ "properties": {+ "id": {+ "type": "integer",+ "format": "int64"+ },+ "name": {+ "type": "string"+ },+ "tag": {+ "type": "string"+ }+ }+ },+ "Pets": {+ "type": "array",+ "items": {+ "type": "object",+ "required": [+ "id",+ "name"+ ],+ "properties": {+ "id": {+ "type": "integer",+ "format": "int64"+ },+ "name": {+ "type": "string"+ },+ "tag": {+ "type": "string"+ }+ }+ }+ },+ "Error": {+ "type": "object",+ "required": [+ "code",+ "message"+ ],+ "properties": {+ "code": {+ "type": "integer",+ "format": "int32"+ },+ "message": {+ "type": "string"+ }+ }+ }+ }+ }+}+|]++compositionSchemaExample :: Schema+compositionSchemaExample =+ mempty+ & Data.OpenApi.allOf+ ?~ [ Ref (Reference "Other"),+ Inline+ ( mempty+ & type_ ?~ OpenApiTypeSingle OpenApiObject+ & properties+ .~ [ ( "greet",+ Inline $ mempty+ & type_ ?~ OpenApiTypeSingle OpenApiString+ )+ ]+ )+ ]++compositionSchemaExampleJSON :: Value+compositionSchemaExampleJSON =+ [aesonQQ|+{+ "allOf": [+ {+ "$ref": "#/components/schemas/Other"+ },+ {+ "type": "object",+ "properties": {+ "greet": { "type": "string" }+ }+ }+ ]+}+|]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/SpecCommon.hs view
@@ -0,0 +1,21 @@+module SpecCommon where++import Data.Aeson+import Data.ByteString.Builder (toLazyByteString)+import Data.Foldable qualified as F+import Data.HashMap.Strict qualified as HashMap+import Data.Vector qualified as Vector+import Test.Hspec++(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec+x <=> js = do+ it "encodes correctly" $ do+ toJSON x `shouldBe` js+ it "decodes correctly" $ do+ fromJSON js `shouldBe` Success x+ it "roundtrips: eitherDecode . encode" $ do+ eitherDecode (encode x) `shouldBe` Right x+ it "roundtrips with toJSON" $ do+ eitherDecode (encode $ toJSON x) `shouldBe` Right x+ it "roundtrips with toEncoding" $ do+ eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x