diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/MIGRATION_3.0_TO_3.1.md b/MIGRATION_3.0_TO_3.1.md new file mode 100644 --- /dev/null +++ b/MIGRATION_3.0_TO_3.1.md @@ -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). diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,224 @@ +# openapi-hs + +[![Hackage](https://img.shields.io/hackage/v/openapi-hs.svg)](https://hackage.haskell.org/package/openapi-hs) +[![License BSD-3-Clause](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](/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.* diff --git a/examples/hackage.hs b/examples/hackage.hs new file mode 100644 --- /dev/null +++ b/examples/hackage.hs @@ -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) diff --git a/openapi-hs.cabal b/openapi-hs.cabal new file mode 100644 --- /dev/null +++ b/openapi-hs.cabal @@ -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 diff --git a/src/Data/HashMap/Strict/InsOrd/Compat.hs b/src/Data/HashMap/Strict/InsOrd/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Strict/InsOrd/Compat.hs @@ -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 +-- Stability: experimental +-- +-- Compatibility wrapper around @insert-ordered-containers@ to mitigate the +-- breaking changes introduced in @insert-ordered-containers-0.3.0@: +-- . +-- +-- 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 diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi.hs @@ -0,0 +1,440 @@ +-- | +-- Module: Data.OpenApi +-- Maintainer: Nadeem Bitar +-- 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 +-- . +-- +-- 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 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, 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. diff --git a/src/Data/OpenApi/Aeson/Compat.hs b/src/Data/OpenApi/Aeson/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Aeson/Compat.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module: Data.OpenApi.Aeson.Compat +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Declare.hs b/src/Data/OpenApi/Declare.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Declare.hs @@ -0,0 +1,188 @@ +-- | +-- Module: Data.OpenApi.Declare +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Internal.hs @@ -0,0 +1,1855 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module: Data.OpenApi.Internal +-- Maintainer: Nadeem Bitar +-- 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, @\\\\@) + -- or unwrapped (@\\@). + -- 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 diff --git a/src/Data/OpenApi/Internal/AesonUtils.hs b/src/Data/OpenApi/Internal/AesonUtils.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -0,0 +1,355 @@ +-- | +-- Module: Data.OpenApi.Internal.AesonUtils +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Internal/ParamSchema.hs b/src/Data/OpenApi/Internal/ParamSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Internal/ParamSchema.hs @@ -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 +-- 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 diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -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 +-- 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 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 diff --git a/src/Data/OpenApi/Internal/Schema/Validation.hs b/src/Data/OpenApi/Internal/Schema/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Internal/Schema/Validation.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} + +-- | +-- Module: Data.OpenApi.Internal.Schema.Validation +-- Copyright: (c) 2015 GetShopTV +-- License: BSD3 +-- Maintainer: Nadeem Bitar +-- 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\"}" +-- +-- JSON value: +-- { +-- "name": "John" +-- } +-- +-- OpenAPI Schema: +-- { +-- "properties": { +-- "name": { +-- "type": "string" +-- }, +-- "phone": { +-- "$ref": "#/components/schemas/Phone" +-- } +-- }, +-- "required": [ +-- "name", +-- "phone" +-- ], +-- "type": "object" +-- } +-- +-- OpenAPI Description Context: +-- { +-- "Phone": { +-- "properties": { +-- "value": { +-- "type": "string" +-- } +-- }, +-- "required": [ +-- "value" +-- ], +-- "type": "object" +-- } +-- } +-- +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" diff --git a/src/Data/OpenApi/Internal/TypeShape.hs b/src/Data/OpenApi/Internal/TypeShape.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Internal/TypeShape.hs @@ -0,0 +1,66 @@ +-- | +-- Module: Data.OpenApi.Internal.TypeShape +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Internal/Utils.hs b/src/Data/OpenApi/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Internal/Utils.hs @@ -0,0 +1,149 @@ +-- | +-- Module: Data.OpenApi.Internal.Utils +-- Maintainer: Nadeem Bitar +-- 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} diff --git a/src/Data/OpenApi/Lens.hs b/src/Data/OpenApi/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Lens.hs @@ -0,0 +1,191 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module: Data.OpenApi.Lens +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Migration.hs b/src/Data/OpenApi/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Migration.hs @@ -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." + #-} diff --git a/src/Data/OpenApi/Operation.hs b/src/Data/OpenApi/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Operation.hs @@ -0,0 +1,307 @@ +-- | +-- Module: Data.OpenApi.Operation +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Optics.hs b/src/Data/OpenApi/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Optics.hs @@ -0,0 +1,379 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module: Data.OpenApi.Optics +-- Maintainer: Andrzej Rybczak +-- Stability: experimental +-- +-- Lenses and prisms for the +-- 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 #-} diff --git a/src/Data/OpenApi/ParamSchema.hs b/src/Data/OpenApi/ParamSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/ParamSchema.hs @@ -0,0 +1,27 @@ +-- | +-- Module: Data.OpenApi.ParamSchema +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Schema.hs b/src/Data/OpenApi/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Schema.hs @@ -0,0 +1,53 @@ +-- | +-- Module: Data.OpenApi.Schema +-- Maintainer: Nadeem Bitar +-- 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 diff --git a/src/Data/OpenApi/Schema/Generator.hs b/src/Data/OpenApi/Schema/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Schema/Generator.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedLists #-} + +-- | +-- Module: Data.OpenApi.Schema.Generator +-- Maintainer: Nadeem Bitar +-- 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 + } diff --git a/src/Data/OpenApi/Schema/Validation.hs b/src/Data/OpenApi/Schema/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/Schema/Validation.hs @@ -0,0 +1,90 @@ +-- | +-- Module: Data.OpenApi.Schema.Validation +-- Maintainer: Nadeem Bitar +-- 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 ). + +-- $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) +-- [] diff --git a/src/Data/OpenApi/SchemaOptions.hs b/src/Data/OpenApi/SchemaOptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/OpenApi/SchemaOptions.hs @@ -0,0 +1,76 @@ +-- | +-- Module: Data.OpenApi.SchemaOptions +-- Maintainer: Nadeem Bitar +-- 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 + } diff --git a/test/Data/OpenApi/CommonTestTypes.hs b/test/Data/OpenApi/CommonTestTypes.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/CommonTestTypes.hs @@ -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"] +} +|] diff --git a/test/Data/OpenApi/MigrationSpec.hs b/test/Data/OpenApi/MigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/MigrationSpec.hs @@ -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]) diff --git a/test/Data/OpenApi/ParamSchemaSpec.hs b/test/Data/OpenApi/ParamSchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/ParamSchemaSpec.hs @@ -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 diff --git a/test/Data/OpenApi/Schema/CoreTypes31Spec.hs b/test/Data/OpenApi/Schema/CoreTypes31Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/Schema/CoreTypes31Spec.hs @@ -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 diff --git a/test/Data/OpenApi/Schema/GeneratorSpec.hs b/test/Data/OpenApi/Schema/GeneratorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/Schema/GeneratorSpec.hs @@ -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"] diff --git a/test/Data/OpenApi/Schema/RoundtripSpec.hs b/test/Data/OpenApi/Schema/RoundtripSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/Schema/RoundtripSpec.hs @@ -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 diff --git a/test/Data/OpenApi/Schema/Validation31Spec.hs b/test/Data/OpenApi/Schema/Validation31Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/Schema/Validation31Spec.hs @@ -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` [] diff --git a/test/Data/OpenApi/Schema/ValidationSpec.hs b/test/Data/OpenApi/Schema/ValidationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/Schema/ValidationSpec.hs @@ -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 diff --git a/test/Data/OpenApi/Schema31Spec.hs b/test/Data/OpenApi/Schema31Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/Schema31Spec.hs @@ -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 diff --git a/test/Data/OpenApi/SchemaSpec.hs b/test/Data/OpenApi/SchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/SchemaSpec.hs @@ -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 diff --git a/test/Data/OpenApi/TopLevel31Spec.hs b/test/Data/OpenApi/TopLevel31Spec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApi/TopLevel31Spec.hs @@ -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) + ] diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OpenApiSpec.hs @@ -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" } + } + } + ] +} +|] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs new file mode 100644 --- /dev/null +++ b/test/SpecCommon.hs @@ -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