openapi3 (empty) → 3.0.0
raw patch · 32 files changed
+8483/−0 lines, 32 filesdep +Globdep +HUnitdep +QuickCheckbuild-type:Customsetup-changed
Dependencies added: Glob, HUnit, QuickCheck, aeson, aeson-pretty, base, base-compat-batteries, bytestring, containers, cookie, doctest, generics-sop, hashable, hspec, http-media, insert-ordered-containers, lens, mtl, network, openapi3, optics-core, optics-th, quickcheck-instances, scientific, template-haskell, text, time, transformers, unordered-containers, utf8-string, uuid-types, vector
Files
- CHANGELOG.md +320/−0
- LICENSE +28/−0
- README.md +41/−0
- Setup.hs +33/−0
- examples/hackage.hs +82/−0
- openapi3.cabal +156/−0
- src/Data/OpenApi.hs +307/−0
- src/Data/OpenApi/Declare.hs +195/−0
- src/Data/OpenApi/Internal.hs +1552/−0
- src/Data/OpenApi/Internal/AesonUtils.hs +312/−0
- src/Data/OpenApi/Internal/ParamSchema.hs +336/−0
- src/Data/OpenApi/Internal/Schema.hs +864/−0
- src/Data/OpenApi/Internal/Schema/Validation.hs +524/−0
- src/Data/OpenApi/Internal/TypeShape.hs +56/−0
- src/Data/OpenApi/Internal/Utils.hs +134/−0
- src/Data/OpenApi/Lens.hs +166/−0
- src/Data/OpenApi/Operation.hs +198/−0
- src/Data/OpenApi/Optics.hs +283/−0
- src/Data/OpenApi/ParamSchema.hs +26/−0
- src/Data/OpenApi/Schema.hs +52/−0
- src/Data/OpenApi/Schema/Generator.hs +115/−0
- src/Data/OpenApi/Schema/Validation.hs +90/−0
- src/Data/OpenApi/SchemaOptions.hs +76/−0
- test/Data/OpenApi/CommonTestTypes.hs +919/−0
- test/Data/OpenApi/ParamSchemaSpec.hs +39/−0
- test/Data/OpenApi/Schema/GeneratorSpec.hs +168/−0
- test/Data/OpenApi/Schema/ValidationSpec.hs +307/−0
- test/Data/OpenApi/SchemaSpec.hs +115/−0
- test/Data/OpenApiSpec.hs +946/−0
- test/Spec.hs +1/−0
- test/SpecCommon.hs +30/−0
- test/doctests.hs +12/−0
+ CHANGELOG.md view
@@ -0,0 +1,320 @@+2.6.1+-----++- More GHC-8.10 related cleanup, tighten lower bound on some dependencies.+ (see [#216]( https://github.com/GetShopTV/swagger2/pull/216 ));+- Add "format" field for uint32 and uint64+ (see [#215]( https://github.com/GetShopTV/swagger2/pull/215 ));++2.6+---++- GHC 8.10 support (see [#210]( https://github.com/GetShopTV/swagger2/pull/210 ));+- Move `aeson-pretty` to other dependencies (see [#206]( https://github.com/GetShopTV/swagger2/pull/206 ));+- Merge OAuth2 scopes (see [#151]( https://github.com/GetShopTV/swagger2/pull/151 ));++2.5+---++Highlights:+- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));+- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));+- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));++Fixes and minor changes:+- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));+- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));+- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));++2.4+---++- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5+- Tags aren't sorted+ (see [#165](https://github.com/GetShopTV/swagger2/issues/165))+- Schema type is optional+ (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))+- Take concrete 'Proxy' as argument+ (see [#180](https://github.com/GetShopTV/swagger2/pull/180))+- GHC-8.8 preparations++2.3.1.1+-------++- Allow `network-3.0`++2.3.1+-----++- Add a quickcheck generator for aeson Values that match a swagger schema+ (see [#162](https://github.com/GetShopTV/swagger2/pull/162))+- Add `ToParamSchema` instance for `SetCookie`+ (see [#173](https://github.com/GetShopTV/swagger2/pull/173))+- Make nullary schemas valid+ (see [#168](https://github.com/GetShopTV/swagger2/pull/168))++2.3.0.1+-------++- Support GHC-8.6++2.3+---++Major changes:++- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));+- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));++Dependencies and CI:++- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));+- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));+- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));+- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));++2.2.2+-----++* Add `ToSchema Version` instance+* Use base-compat-batteries (0.10)+* PVP bounds++2.2.1+-----++* Add `Semigroup` instances+* GHC-8.4 compatibility+* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))+* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))+* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))+* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))++2.2+---++* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));+* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));+* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):+ * `genericNameSchema` — to give a custom schema `Generic`-based name;+ * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;+ * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;+* Add a few tests with invalid `Schema`.++2.1.6+-----++* Add `ToParamSchema` and `ToSchema` instances for `Fixed` (see [#121](https://github.com/GetShopTV/swagger2/pull/121)) and `Natural` (see [#123](https://github.com/GetShopTV/swagger2/pull/123));+* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));+* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).++2.1.5+-----++* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));+* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));+* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));+* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).++2.1.4.1+-------++* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108));+* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));+* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));+* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).++2.1.4+-----++* Add `liftDeclare` (see [#100](https://github.com/GetShopTV/swagger2/pull/100));+* Add `MonadDeclare` instances for all monad transformers (see [#100](https://github.com/GetShopTV/swagger2/pull/100)).++2.1.3+-----++* Add [`UUID`](http://hackage.haskell.org/package/uuid-types/docs/Data-UUID-Types.html#t:UUID) instances (see [#81](https://github.com/GetShopTV/swagger2/pull/81)).+* Add [`TypeError`](https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-TypeLits.html#g:4) `ToSchema` and `ToParamSchema ByteString` instances (see [#78](https://github.com/GetShopTV/swagger2/pull/78))+* Improve documentation for generic sum type instance derivation (see [#75](https://github.com/GetShopTV/swagger2/pull/75))+* Compile warning free (see [#82](https://github.com/GetShopTV/swagger2/pull/82))++2.1.2.1+-------++* Bug fix previous release++2.1.2+---++* Minor changes:+ * Support `aeson-1.0.0.0` (see [#70](https://github.com/GetShopTV/swagger2/pull/70)).++2.1.1+---++* Minor changes:+ * Proper `Schema` examples for `Char`, `Day`, `LocalTime`, `ZonedTime` and `UTCTime`.++2.1+---++* Major changes:+ * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));+ * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).++2.0.2+---++* Fixes:+ * Fix `additionalProperties` to allow references;+ * Fix `ToSchema` instances for `Map` and `HashMap` (prevent infinite recursion for recursive values).++2.0.1+---++* Fixes:+ * Re-export `Pattern` synonym from `Data.Swagger`;+ * Documentation fixes.++2.0+---++* Major changes:+ * GHC 7.8 support (see [#49](https://github.com/GetShopTV/swagger2/pull/49));+ * Switch to classy field lenses (see [#41](https://github.com/GetShopTV/swagger2/pull/41));+ * Add `Data.Swagger.Schema.Validation` (see [#18](https://github.com/GetShopTV/swagger2/pull/18));+ * Add `Data.Swagger.Operation` with helpers (see [#50](https://github.com/GetShopTV/swagger2/pull/50));+ * Add `IsString` instances for some types (see [#47](https://github.com/GetShopTV/swagger2/pull/47));+ * Add helpers to sketch `Schema` from JSON (see [#48](https://github.com/GetShopTV/swagger2/pull/48)).++* Minor changes:+ * Make `NamedSchema` a `data` rather than `type` (see [#42](https://github.com/GetShopTV/swagger2/pull/42));+ * Change `Definitions` to `Definitions Schema`;+ * Add schema templates for `"binary"`, `"byte"` and `"password"` formats (see [63ed597](https://github.com/GetShopTV/swagger2/commit/63ed59736dc4f942f0e2a7d668d7cee513fa9eaf));+ * Add `Monoid` instance for `Contact`;+ * Change `tags` to be `Set` rather than list.++* Fixes:+ * Fix schema for `()` and nullary constructors (see [ab65c4a](https://github.com/GetShopTV/swagger2/commit/ab65c4a48253c34f8a88221a53dc97bf5e6e8d29));+ * Fix `Operation` `FromJSON` instance to allow missing `tags` and `parameters` properties.++1.2.1+---++* Minor changes:+ * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.++* Fixes:+ * Fix build for GHC 8.0-rc1.++1.2+---+* Minor changes (see [#36](https://github.com/GetShopTV/swagger2/pull/36)):+ * Change default `ToSchema` instance for unit data types (i.e. types with one nullable constructor like `data Unit = Unit`):+ now these types are treated like sum types with only one alternative;+ * Add generic `ToParamSchema` instance for unit data types;+ * Add `items: []` to schema for `()` (making it a valid schema).++* Fixes:+ * Do not omit `items: []` from `Schema` JSON;+ * Do not generate unused definitions for nested `newtype`s (see [#38](https://github.com/GetShopTV/swagger2/pull/38)).++1.1.1+---+* Fixes:+ * `CollectionFormat Param` -> `CollectionFormat ParamOtherSchema`;+ this change was necessary after putting `CollectionFormat` to `SwaggerItems`.++1.1+---+* Major changes:+ * Put `CollectionFormat` in one place (see [`3cc860d`](https://github.com/GetShopTV/swagger2/commit/3cc860dd3f002ab984f4d0e4ce1d1799f985832e)).++* Minor changes:+ * Use Swagger formats for `Int32`, `Int64`, `Float`, `Double`, `Day` and `ZonedTime` (see [#32](https://github.com/GetShopTV/swagger2/pull/32));+ * Export `HeaderName`, `TagName`, `HttpStatusCode` type synonyms;+ * Add `ToParamSchema` instances for `[a]`, `Set a` and `HashSet a`;+ * Add `Monoid` instances for `Header` and `Example`.++* Fixes:+ * Use overwrite strategy for `HashMap` `SwaggerMonoid` instances by default.++1.0+---+* Major changes:+ * Add `Data` and `Typeable` instances for `Data.Swagger` types;+ * Merge `ParamType`/`ItemsType`/`SchemaType` into `SwaggerType` GADT;+ * Merge collection format types into `CollectionFormat` GADT;+ * Introduce `SwaggerItems` GADT, replacing `Items` and `SchemaItems` in `ParamSchema` (see [#24](https://github.com/GetShopTV/swagger2/pull/24));+ * Move type, format and items fields to `ParamSchema` (former `SchemaComon`);+ * Prepend reference path automatically (see [commit 49d1fad](https://github.com/GetShopTV/swagger2/commit/49d1fadd2100644e70c442667180d0d73e107a5f))+ and thus remove `"#/definitions/"` from user code, leaving much clearer `Reference "Name"`;+ * Change `Data.Swagger.Schema` (see [#19](https://github.com/GetShopTV/swagger2/pull/19)):+ * Change the only method of `ToSchema` to `declareNamedSchema` which should produce a `NamedSchema`+ along with a list of schema definitions used to produce it;+ * Add `declareSchema`, `declareSchemaRef`;+ * Replace `genericTo*` helpers with `genericDeclare*` helpers;+ * Add `paramSchemaTo[Named]Schema` helpers to facilitate code reuse for primitive schemas;+ * Add helpers for inlining `Schema` references dynamically (see [#23](https://github.com/GetShopTV/swagger2/pull/23));+ * Add `ToParamSchema` class (see [#17](https://github.com/GetShopTV/swagger2/pull/17)) with+ * generic default implementation and+ * instances for some base types compliant with `http-api-data` instances;+ * Add `Data.Swagger.Declare` module with+ * `DeclareT` monad transformer;+ * `MonadDeclare` type class;+ * various helpers;+ * Rename parameter-related types:+ * `Parameter` -> `Param`;+ * `ParameterSchema` -> `ParamAnySchema`;+ * `ParameterOtherSchema` -> `ParamOtherSchema`;+ * `ParameterLocation` -> `ParamLocation`;+ * `SchemaCommon` -> `ParamSchema`;+ * `parameter*` fields renamed to `param*` fields;+ * `schemaCommon*` fields renamed to `paramSchema*` fields;+ * `HasSchemaCommon` -> `HasParamSchema`.++* Minor changes:+ * Replace TH-generated JSON instances with `Generic`-based (see [#25](https://github.com/GetShopTV/swagger2/pull/25));+ * Drop `template-haskell` dependency;+ * Omit empty array/object properties from `toJSON` output ([#22](https://github.com/GetShopTV/swagger2/pull/22));+ * Remove `minLength` property from schemas for `time` types;+ * Move `SchemaOptions` to `Data.Swagger.SchemaOptions`;+ * Remove `useReferences` from `SchemaOptions` (see [#23](https://github.com/GetShopTV/swagger2/pull/23));+ * Place all internal submodules under `Data.Swagger.Internal`;+ * Better documentation (see [#26](https://github.com/GetShopTV/swagger2/pull/26)).++0.4.1+---+* Fixes:+ * Use `PackageImports` for `Data.HashSet` to avoid test failure on stackage (see [#15](https://github.com/GetShopTV/swagger2/issues/15));+ * Add an upper version bound for `aeson` due to `aeson-0.10.0.0` bug (see [bos/aeson#293](https://github.com/bos/aeson/issues/293));+ * Switch to Cabal-based multi GHC Travis config.++0.4+---+* Remove `Swagger`/`swagger` prefixes;+* Add `ToSchema` type class with default generic implementation;+* Add configurable generic `ToSchema` helpers;+* Add `doctest` test suite;+* Fixes:+ * Fix `HasSchemaCommon` instance for `Schema`;+ * Change `minimum`, `maximum` and `multipleOf` properties to be any number,+ not necessarily an integer;+ * Fix all warnings.++0.3+---+* Fixes:+ * Fix `SwaggerMonoid Text` instance;+ * Wrap `Bool` in `Maybe` everywhere;+ * These changes make all `Data.Swagger` `Monoid` instances obey monoid laws+ (previously right identity law was broken by some instances).++0.2+---+* Add `Data.Swagger.Lens`;+* Support references;+* Fixes:+ * Fix `FromJSON SwaggerHost` instance;+ * Add missing `Maybe`s for field types;+ * Decode petstore `swagger.json` successfully.
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015-2017, GetShopTV+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 swagger2 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.+
+ README.md view
@@ -0,0 +1,41 @@+# OpenApi 3++[](http://hackage.haskell.org/package/openapi3)+[](https://travis-ci.org/biocad/openapi3)+[](http://stackage.org/lts/package/opeopenapi3)+[](http://stackage.org/nightly/package/openapi3)++OpenAPI 3.0 data model.++The original OpenAPI 3.0 specification is available at http://swagger.io/specification/.++This package is heavily based on excellent work on Swagger 2.0 at+https://github.com/GetShopTV/swagger2.++## Usage++This library is intended to be used for decoding and encoding OpenApi 3.0.3 specifications as well as manipulating them.++Please refer to [haddock documentation](http://hackage.haskell.org/package/openapi3).++Some examples can be found in [`examples/` directory](/examples).++## Trying out++All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).++Ready-to-use specification can be served as JSON and interactive API documentation+can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).++Many Swagger tools, including server and client code generation for many languages, can be found on+[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).++## Contributing++We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.++Please report bugs via the [github issue tracker](https://github.com/biocad/openapi3/issues).++*GetShopTV Team*++*Biocad Team*
+ Setup.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+ The doctests test-suite will not work as a result. \+ To fix this, install cabal-doctest before configuring.+#endif++import Distribution.Simple++main :: IO ()+main = defaultMain++#endif
+ examples/hackage.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Lens+import Data.Aeson+import Data.Proxy+import Data.Text (Text)+import GHC.Generics++import Data.OpenApi+import Data.OpenApi.Declare+import Data.OpenApi.Lens+import Data.OpenApi.Operation++type Username = Text++data UserSummary = UserSummary+ { summaryUsername :: Username+ , summaryUserid :: Int+ } deriving (Generic)++instance ToSchema UserSummary where+ declareNamedSchema _ = do+ usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)+ useridSchema <- declareSchemaRef (Proxy :: Proxy Int)+ return $ NamedSchema (Just "UserSummary") $ mempty+ & type_ ?~ OpenApiObject+ & properties .~+ [ ("summaryUsername", usernameSchema )+ , ("summaryUserid" , useridSchema )+ ]+ & required .~ [ "summaryUsername"+ , "summaryUserid" ]+++type Group = Text++data UserDetailed = UserDetailed+ { username :: Username+ , userid :: Int+ , groups :: [Group]+ } deriving (Generic, ToSchema)++newtype Package = Package { packageName :: Text }+ deriving (Generic, 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+ & paths .~+ [ ("/users", mempty & get ?~ (mempty+ & at 200 ?~ Inline userSummaryResponse))+ , ("/user/{username}", mempty & get ?~ (mempty+ & parameters .~ [ Inline $ mempty+ & name .~ "username"+ & required ?~ True+ & in_ .~ ParamPath+ & schema ?~ Inline usernameParamSchema ]+ & at 200 ?~ Inline userDetailedResponse))+ , ("/packages", mempty & get ?~ (mempty+ & at 200 ?~ Inline packagesResponse))+ ]++main :: IO ()+main = putStrLn . read . show . encode $ hackageOpenApi+
+ openapi3.cabal view
@@ -0,0 +1,156 @@+cabal-version: >=1.10+name: openapi3+version: 3.0.0++synopsis: OpenAPI 3.0 data model+category: Web, Swagger, OpenApi+description:+ This library is intended to be used for decoding and encoding OpenAPI 3.0 API+ specifications as well as manipulating them.+ .+ The original OpenAPI 3.0 specification is available at http://swagger.io/specification/.++homepage: https://github.com/biocad/openapi3+bug-reports: https://github.com/biocad/openapi3/issues+license: BSD3+license-file: LICENSE+author: Nickolay Kudasov, Maxim Koltsov+maintainer: nickolay@getshoptv.com, kolmax94@gmail.com+copyright: (c) 2015-2016, GetShopTV, (c) 2020, Biocad+build-type: Custom+extra-source-files:+ README.md+ , CHANGELOG.md+ , examples/*.hs+tested-with:+ GHC ==8.4.4+ || ==8.6.5+ || ==8.8.3+ || ==8.10.1++custom-setup+ setup-depends:+ base, Cabal, cabal-doctest >=1.0.6 && <1.1++library+ hs-source-dirs: src+ exposed-modules:+ Data.OpenApi+ Data.OpenApi.Declare+ Data.OpenApi.Lens+ 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+ Data.OpenApi.Internal+ Data.OpenApi.Internal.Schema+ Data.OpenApi.Internal.Schema.Validation+ Data.OpenApi.Internal.ParamSchema+ Data.OpenApi.Internal.Utils+ Data.OpenApi.Internal.AesonUtils+ Data.OpenApi.Internal.TypeShape++ -- GHC boot libraries+ build-depends:+ base >=4.11.1.0 && <4.15+ , bytestring >=0.10.8.2 && <0.11+ , containers >=0.5.11.0 && <0.7+ , template-haskell >=2.13.0.0 && <2.17+ , time >=1.8.0.2 && <1.10+ , transformers >=0.5.5.0 && <0.6++ build-depends:+ mtl >=2.2.2 && <2.3+ , text >=1.2.3.1 && <1.3++ -- other dependencies+ build-depends:+ base-compat-batteries >=0.11.1 && <0.12+ , aeson >=1.4.2.0 && <1.6+ , aeson-pretty >=0.8.7 && <0.9+ -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint+ , cookie >=0.4.3 && <0.5+ , generics-sop >=0.5.1.0 && <0.6+ , hashable >=1.2.7.0 && <1.4+ , http-media >=0.8.0.0 && <0.9+ , insert-ordered-containers >=0.2.3 && <0.3+ , lens >=4.16.1 && <4.20+ , network >=2.6.3.5 && <3.2+ , optics-core >=0.2 && <0.4+ , optics-th >=0.2 && <0.4+ , 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.13+ , QuickCheck >=2.10.1 && <2.15++ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs++ -- From library parat+ -- We need aeson's toEncoding for doctests too+ build-depends:+ base+ , QuickCheck+ , aeson+ , base-compat-batteries+ , bytestring+ , containers+ , hashable+ , insert-ordered-containers+ , lens+ , mtl+ , openapi3+ , template-haskell+ , text+ , time+ , unordered-containers+ , vector++ -- test-suite only dependencies+ build-depends:+ hspec >=2.5.5 && <2.8+ , 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.8++ other-modules:+ SpecCommon+ Data.OpenApiSpec+ Data.OpenApi.CommonTestTypes+ Data.OpenApi.ParamSchemaSpec+ Data.OpenApi.SchemaSpec+ Data.OpenApi.Schema.ValidationSpec+ Data.OpenApi.Schema.GeneratorSpec+ default-language: Haskell2010++test-suite doctests+ -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes+ build-depends: base, doctest, Glob, QuickCheck+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: doctests.hs+ type: exitcode-stdio-1.0++executable example+ hs-source-dirs: examples+ main-is: hackage.hs+ default-language: Haskell2010+ build-depends: base, aeson, lens, openapi3, text++source-repository head+ type: git+ location: https://github.com/biocad/openapi3.git
+ src/Data/OpenApi.hs view
@@ -0,0 +1,307 @@+-- |+-- Module: Data.OpenApi+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Swagger™ is a project used to describe and document RESTful APIs.+--+-- The Swagger specification defines a set of files required to describe such an API.+-- These files can then be used by the Swagger-UI project to display the API+-- and Swagger-Codegen to generate clients in various languages.+-- Additional utilities can also take advantage of the resulting files, such as testing tools.+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,++ -- * Swagger specification+ OpenApi(..),+ Server(..),+ ServerVariable(..),+ Components(..),++ -- ** Info types+ Info(..),+ Contact(..),+ License(..),++ -- ** PathItem+ PathItem(..),++ -- ** Operations+ Operation(..),+ Tag(..),+ TagName,++ -- ** Types and formats+ OpenApiType(..),+ 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(..),+ 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.Lens+import Data.OpenApi.Optics ()+import Data.OpenApi.Operation+import Data.OpenApi.ParamSchema+import Data.OpenApi.Schema+import Data.OpenApi.Schema.Validation++import Data.OpenApi.Internal++-- $setup+-- >>> import Control.Lens+-- >>> import Data.Aeson+-- >>> import Data.Monoid+-- >>> import Data.Proxy+-- >>> import GHC.Generics+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL+-- >>> :set -XDeriveGeneric+-- >>> :set -XOverloadedStrings+-- >>> :set -XOverloadedLists+-- >>> :set -fno-warn-missing-methods++-- $howto+--+-- This section explains how to use this library to work with Swagger specification.++-- $monoids+--+-- Virtually all types representing Swagger 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 $ encode (mempty :: OpenApi)+-- {"openapi":"3.0.0","info":{"version":"","title":""},"components":{}}+--+-- 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 $ encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }+-- {"version":"1.0","title":"Todo API"}+--+-- You can merge two values using @'mappend'@ or its infix version @('<>')@:+--+-- >>> BSL.putStrLn $ encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }+-- {"version":"1.0","title":"Todo API"}+--+-- This can be useful for combining specifications of endpoints into a whole API specification:+--+-- @+-- \-\- /account subAPI specification+-- accountAPI :: OpenApi+--+-- \-\- /task subAPI specification+-- taskAPI :: OpenApi+--+-- \-\- while API specification is just a combination+-- \-\- of subAPIs' specifications+-- api :: OpenApi+-- api = accountAPI <> taskAPI+-- @++-- $lens+--+-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.OpenApi.Optics".+--+-- Since @'Swagger'@ 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 $ encode $ (mempty :: OpenApi)+-- & components . schemas .~ [ ("User", mempty & type_ ?~ OpenApiString) ]+-- & paths .~+-- [ ("/user", mempty & get ?~ (mempty+-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User")))+-- & at 404 ?~ "User info not found")) ]+-- :}+-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}}+--+-- 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 @'definitions'@ property of swagger specification.+-- Alternatively it may respond with code @404@ meaning that user info is not found.+--+-- For convenience, @swagger2@ 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 a Swagger specification+-- can have descriptions, and you can use the same name for them:+--+-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & description .~ "No content"+-- {"description":"No content"}+-- >>> :{+-- BSL.putStrLn $ encode $ (mempty :: Schema)+-- & type_ ?~ OpenApiBoolean+-- & description ?~ "To be or not to be"+-- :}+-- {"type":"boolean","description":"To be or not to be"}+--+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@+-- have direct access to it via @'at' code@. Example:+--+-- >>> :{+-- BSL.putStrLn $ encode $ (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+--+-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification.+--+-- @'ParamSchema' t@ specifies all the common properties, available for every data schema.+-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'OpenApiType'@ and @'OpenApiItems'@).+--+-- @'Schema'@ is used for request and response bodies and allows specifying objects+-- with properties in addition to what @'ParamSchema'@ provides.+--+-- 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+-- @swagger2@ provides two classes for schema encoding.+-- Both these classes provide means to encode /types/ as Swagger /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 Swagger.+--+-- 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 $ encode (Person "David" 28)+-- {"age":28,"name":"David"}+-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person)+-- {"required":["name","age"],"type":"object","properties":{"age":{"type":"integer"},"name":{"type":"string"}}}+--+-- This package implements OpenAPI 3.0 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 $ encode $ toSchema (Proxy :: Proxy Error)+-- {"oneOf":[{"required":["userId","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorNoUser"]},"userId":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}},{"required":["requiredPermission","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorAccessDenied"]},"requiredPermission":{"type":"string"}}}],"type":"object"}++-- $manipulation+-- Sometimes you have to work with an imported or generated @'Swagger'@.+-- For instance, <servant-swagger http://hackage.haskell.org/package/servant-swagger> generates basic @'Swagger'@+-- for a type-level servant API.+--+-- Lenses and prisms can be used to manipulate such specification to add additional information, tags, extra responses, etc.+-- To facilitate common needs, @"Data.OpenApi.Operation"@ module provides useful helpers.++-- $validation+-- While @'ToParamSchema'@ and @'ToSchema'@ provide means to easily obtain schemas for Haskell types,+-- there is no static mechanism to ensure those instances correspond to the @'ToHttpApiData'@ or @'ToJSON'@ instances.+--+-- @"Data.OpenApi.Schema.Validation"@ addresses @'ToJSON'@/@'ToSchema'@ validation.
+ src/Data/OpenApi/Declare.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module: Data.OpenApi.Declare+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Declare monad transformer and associated functions.+module Data.OpenApi.Declare where++import Prelude ()+import Prelude.Compat++import Control.Monad+import Control.Monad.Cont (ContT)+import Control.Monad.List (ListT)+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.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.RWS.Lazy as Lazy+import Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Writer.Lazy as Lazy+import Control.Monad.Trans.Writer.Strict as Strict+import Data.Functor.Identity++-- | 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 (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+ return x = DeclareT (\_ -> pure (mempty, x))+ 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 @'DeclateT' 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 @'Declate' d a@ computation, ignoring result and only+-- producing output @d@.+execDeclare :: Declare d a -> d -> d+execDeclare m = runIdentity . execDeclareT m++-- | Evaluate @'DeclareT' d m a@ computation,+-- starting with empty output history.+undeclare :: Monoid d => Declare d a -> a+undeclare = runIdentity . undeclareT++-- ---------------------------------------------------------------------------+-- Instances for other mtl transformers+--+-- All of these instances need UndecidableInstances,+-- because they do not satisfy the coverage condition.++instance MonadDeclare d m => MonadDeclare d (ContT r m) where+ declare = lift . declare+ look = lift look++instance MonadDeclare d m => MonadDeclare d (ExceptT e m) where+ declare = lift . declare+ look = lift look++instance MonadDeclare d m => MonadDeclare d (IdentityT m) where+ declare = lift . declare+ look = lift look++instance MonadDeclare d m => MonadDeclare d (MaybeT m) where+ declare = lift . declare+ look = lift look++instance MonadDeclare d m => MonadDeclare d (ReaderT r m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.RWST r w s m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.RWST r w s m) where+ declare = lift . declare+ look = lift look++instance MonadDeclare d m => MonadDeclare d (Lazy.StateT s m) where+ declare = lift . declare+ look = lift look++instance MonadDeclare d m => MonadDeclare d (Strict.StateT s m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.WriterT w m) where+ declare = lift . declare+ look = lift look++instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.WriterT w m) where+ declare = lift . declare+ look = lift look
+ src/Data/OpenApi/Internal.hs view
@@ -0,0 +1,1552 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.OpenApi.Internal where++import Prelude ()+import Prelude.Compat++import Control.Applicative+import Control.Lens ((&), (.~), (?~))+import Data.Aeson hiding (Encoding)+import qualified Data.Aeson.Types as JSON+import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable,+ constrIndex, mkConstr, mkDataType)+import Data.Hashable (Hashable (..))+import qualified Data.HashMap.Strict as HashMap+import Data.HashSet.InsOrd (InsOrdHashSet)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid (Monoid (..))+import Data.Scientific (Scientific)+import Data.Semigroup.Compat (Semigroup (..))+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics (Generic)+import Network.HTTP.Media (MediaType, mainType, parameters, parseAccept, subType, (//),+ (/:))+import Network.Socket (HostName, PortNumber)+import Text.Read (readMaybe)++import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap++import Generics.SOP.TH (deriveGeneric)+import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToJSON+ ,sopSwaggerGenericToJSONWithOpts+ ,sopSwaggerGenericParseJSON+ ,HasSwaggerAesonOptions(..)+ ,AesonDefaultValue(..)+ ,mkSwaggerAesonOptions+ ,saoAdditionalPairs+ ,saoSubObject)+import Data.OpenApi.Internal.Utils+import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding)++-- $setup+-- >>> :seti -XDataKinds+-- >>> import Data.Aeson++-- | 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++ -- | 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+ } deriving (Eq, Show, Generic, Data, Typeable)++-- | 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 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 (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 (Eq, Show, Generic, Data, Typeable)++-- | License information for the exposed API.+data License = License+ { -- | The license name used for the API.+ _licenseName :: Text++ -- | A URL to the license used for the API.+ , _licenseUrl :: Maybe URL+ } deriving (Eq, Show, Generic, Data, Typeable)++instance IsString License where+ fromString s = License (fromString s) 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 (Eq, Show, Generic, Data, Typeable)++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 (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 :: Definitions SecurityScheme+ , _componentsLinks :: Definitions Link+ , _componentsCallbacks :: Definitions Callback+ } deriving (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+ { -- | 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 (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 the swagger-ui, 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 (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 = mkConstr mediaTypeData "MediaType" [] Prefix+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 (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 (Eq, Show, Generic, Data, Typeable)++-- | In order to support common ways of serializing simple parameters, a set of style values are defined.+data Style+ = StyleMatrix+ -- ^ Path-style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).+ | StyleLabel+ -- ^ Label style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).+ | StyleForm+ -- ^ 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.+ | StyleSimple+ -- ^ 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.+ | StyleSpaceDelimited+ -- ^ Space separated array values.+ -- This option replaces @collectionFormat@ equal to @ssv@ from OpenAPI 2.0.+ | StylePipeDelimited+ -- ^ Pipe separated array values.+ -- This option replaces @collectionFormat@ equal to @pipes@ from OpenAPI 2.0.+ | StyleDeepObject+ -- ^ Provides a simple way of rendering nested objects using form parameters.+ deriving (Eq, Show, Generic, Data, Typeable)++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 (Eq, Show, Generic, Data, Typeable)++newtype MimeList = MimeList { getMimeList :: [MediaType] }+ deriving (Eq, Show, Semigroup, Monoid, Typeable)++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 (Eq, Show, Generic, Data, Typeable)++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 (Eq, Show, Generic, Typeable, Data)++data ExpressionOrValue+ = Expression Text+ | Value Value+ deriving (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 (Eq, Show, Generic, Typeable, Data)++-- | Items for @'OpenApiArray'@ schemas.+--+-- __Warning__: OpenAPI 3.0 does not support tuple arrays. However, OpenAPI 3.1 will, as+-- it will incorporate Json Schema mostly verbatim.+--+-- @'OpenApiItemsObject'@ should be used to specify homogenous array @'Schema'@s.+--+-- @'OpenApiItemsArray'@ should be used to specify tuple @'Schema'@s.+data OpenApiItems where+ OpenApiItemsObject :: Referenced Schema -> OpenApiItems+ OpenApiItemsArray :: [Referenced Schema] -> OpenApiItems+ deriving (Eq, Show, Typeable, Data)++data OpenApiType where+ OpenApiString :: OpenApiType+ OpenApiNumber :: OpenApiType+ OpenApiInteger :: OpenApiType+ OpenApiBoolean :: OpenApiType+ OpenApiArray :: OpenApiType+ OpenApiNull :: OpenApiType+ OpenApiObject :: OpenApiType+ deriving (Eq, Show, Typeable, Generic, Data)++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 (Eq, Show, Generic, Data, Typeable)++type Format = Text++type ParamName = Text++data Schema = Schema+ { _schemaTitle :: Maybe Text+ , _schemaDescription :: Maybe Text+ , _schemaRequired :: [ParamName]++ , _schemaNullable :: Maybe Bool+ , _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 OpenApiType+ , _schemaFormat :: Maybe Format+ , _schemaItems :: Maybe OpenApiItems+ , _schemaMaximum :: Maybe Scientific+ , _schemaExclusiveMaximum :: Maybe Bool+ , _schemaMinimum :: Maybe Scientific+ , _schemaExclusiveMinimum :: Maybe Bool+ , _schemaMaxLength :: Maybe Integer+ , _schemaMinLength :: Maybe Integer+ , _schemaPattern :: Maybe Pattern+ , _schemaMaxItems :: Maybe Integer+ , _schemaMinItems :: Maybe Integer+ , _schemaUniqueItems :: Maybe Bool+ , _schemaEnum :: Maybe [Value]+ , _schemaMultipleOf :: Maybe Scientific+ } deriving (Eq, Show, Generic, Data, Typeable)++-- | Regex pattern for @string@ type.+type Pattern = Text++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 (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 (Eq, Show, Generic, Data, Typeable)++data Xml = Xml+ { -- | Replaces the name of the element/attribute used for the described schema property.+ -- When defined within the @'OpenApiItems'@ (items), it will affect the name of the individual XML elements within the list.+ -- When defined alongside type being array (outside the items),+ -- it will affect the wrapping element and only if wrapped is true.+ -- If wrapped is false, it will be ignored.+ _xmlName :: Maybe Text++ -- | The URL of the namespace definition.+ -- Value SHOULD be in the form of a URL.+ , _xmlNamespace :: Maybe Text++ -- | The prefix to be used for the name.+ , _xmlPrefix :: Maybe Text++ -- | Declares whether the property definition translates to an attribute instead of an element.+ -- Default value is @False@.+ , _xmlAttribute :: Maybe Bool++ -- | MAY be used only for an array definition.+ -- Signifies whether the array is wrapped+ -- (for example, @\<books\>\<book/\>\<book/\>\</books\>@)+ -- or unwrapped (@\<book/\>\<book/\>@).+ -- Default value is @False@.+ -- The definition takes effect only when defined alongside type being array (outside the items).+ , _xmlWrapped :: Maybe Bool+ } deriving (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 (Eq, Show, Generic, Data, Typeable)++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 'Component' Objects.+ , _responseLinks :: InsOrdHashMap Text (Referenced Link)+ } deriving (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 (Eq, Show, Generic, Data, Typeable)++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 (Eq, Show, Generic, Data, Typeable)++-- | The location of the API key.+data ApiKeyLocation+ = ApiKeyQuery+ | ApiKeyHeader+ | ApiKeyCookie+ deriving (Eq, Show, Generic, Data, Typeable)++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 (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++newtype OAuth2ImplicitFlow+ = OAuth2ImplicitFlow {_oAuth2ImplicitFlowAuthorizationUrl :: AuthorizationURL}+ deriving (Eq, Show, Generic, Data, Typeable)++newtype OAuth2PasswordFlow+ = OAuth2PasswordFlow {_oAuth2PasswordFlowTokenUrl :: TokenURL}+ deriving (Eq, Show, Generic, Data, Typeable)++newtype OAuth2ClientCredentialsFlow+ = OAuth2ClientCredentialsFlow {_oAuth2ClientCredentialsFlowTokenUrl :: TokenURL}+ deriving (Eq, Show, Generic, Data, Typeable)++data OAuth2AuthorizationCodeFlow = OAuth2AuthorizationCodeFlow+ { _oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL+ , _oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL+ } deriving (Eq, Show, Generic, Data, Typeable)++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 (Eq, Show, Generic, Data, Typeable)++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 (Eq, Show, Generic, Data, Typeable)++data SecuritySchemeType+ = SecuritySchemeHttp+ | SecuritySchemeApiKey ApiKeyParams+ | SecuritySchemeOAuth2 OAuth2Flows+ | SecuritySchemeOpenIdConnect URL+ deriving (Eq, Show, Generic, Data, Typeable)++data SecurityScheme = SecurityScheme+ { -- | The type of the security scheme.+ _securitySchemeType :: SecuritySchemeType++ -- | A short description for security scheme.+ , _securitySchemeDescription :: Maybe Text+ } deriving (Eq, Show, Generic, Data, Typeable)++newtype SecurityDefinitions+ = SecurityDefinitions (Definitions SecurityScheme)+ deriving (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 (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)++-- | 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 (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 (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 (Eq, Show, Data, Typeable)++data Referenced a+ = Ref Reference+ | Inline a+ deriving (Eq, Show, Functor, Data, Typeable)++instance IsString a => IsString (Referenced a) where+ fromString = Inline . fromString++newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)++data AdditionalProperties+ = AdditionalPropertiesAllowed Bool+ | AdditionalPropertiesSchema (Referenced Schema)+ deriving (Eq, Show, 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++-- =======================================================================+-- Monoid instances+-- =======================================================================++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 = swaggerMappend lUrl rUrl, _oAuth2Scopes = lScopes <> rScopes }++-- swaggerMappend 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) (swaggerMappend 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 = (<>)++-- =======================================================================+-- SwaggerMonoid helper instances+-- =======================================================================++instance SwaggerMonoid Info+instance SwaggerMonoid Components+instance SwaggerMonoid PathItem+instance SwaggerMonoid Schema+instance SwaggerMonoid Param+instance SwaggerMonoid Responses+instance SwaggerMonoid Response+instance SwaggerMonoid ExternalDocs+instance SwaggerMonoid Operation+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)++instance SwaggerMonoid MimeList+deriving instance SwaggerMonoid URL++instance SwaggerMonoid OpenApiType where+ swaggerMempty = OpenApiString+ swaggerMappend _ y = y++instance SwaggerMonoid ParamLocation where+ swaggerMempty = ParamQuery+ swaggerMappend _ y = y++instance {-# OVERLAPPING #-} SwaggerMonoid (InsOrdHashMap FilePath PathItem) where+ swaggerMempty = InsOrdHashMap.empty+ swaggerMappend = InsOrdHashMap.unionWith mappend++instance Monoid a => SwaggerMonoid (Referenced a) where+ swaggerMempty = Inline mempty+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)+ swaggerMappend _ y = y++-- =======================================================================+-- Simple Generic-based ToJSON instances+-- =======================================================================++instance ToJSON Style where+ toJSON = genericToJSON (jsonPrefix "Style")++instance ToJSON OpenApiType where+ toJSON = genericToJSON (jsonPrefix "Swagger")++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 "Swagger")++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 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 = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON OAuth2Flows where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON SecuritySchemeType where+ toJSON SecuritySchemeHttp+ = object [ "type" .= ("http" :: Text) ]+ 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 = sopSwaggerGenericToJSON a &+ if InsOrdHashMap.null (_openApiPaths a)+ then (<+> object ["paths" .= object []])+ else id+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Server where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON SecurityScheme where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Schema where+ toJSON = sopSwaggerGenericToJSONWithOpts $+ mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items"++instance ToJSON Header where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++-- | As for nullary schema for 0-arity type constructors, see+-- <https://github.com/GetShopTV/swagger2/issues/167>.+--+-- >>> encode (OpenApiItemsArray [])+-- "{\"example\":[],\"items\":{},\"maxItems\":0}"+--+instance ToJSON OpenApiItems where+ toJSON (OpenApiItemsObject x) = object [ "items" .= x ]+ toJSON (OpenApiItemsArray []) = object+ [ "items" .= object []+ , "maxItems" .= (0 :: Int)+ , "example" .= Array mempty+ ]+ toJSON (OpenApiItemsArray x) = object [ "items" .= x ]++instance ToJSON Components where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON MimeList where+ toJSON (MimeList xs) = toJSON (map show xs)++instance ToJSON Param where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Responses where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Response where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Operation where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON PathItem where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON RequestBody where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON MediaTypeObject where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Example where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Encoding where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++instance ToJSON Link where+ toJSON = sopSwaggerGenericToJSON+ toEncoding = sopSwaggerGenericToEncoding++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 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 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 = sopSwaggerGenericParseJSON++instance FromJSON OAuth2Flows where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON SecuritySchemeType where+ parseJSON js@(Object o) = do+ (t :: Text) <- o .: "type"+ case t of+ "http" -> pure SecuritySchemeHttp+ "apiKey" -> SecuritySchemeApiKey <$> parseJSON js+ "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows")+ "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl")+ _ -> empty+ parseJSON _ = empty++instance FromJSON OpenApi where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON Server where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON SecurityScheme where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON Schema where+ parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON+ where nullaryCleanup :: Schema -> Schema+ nullaryCleanup s =+ if _schemaItems s == Just (OpenApiItemsArray [])+ then s { _schemaExample = Nothing+ , _schemaMaxItems = Nothing+ }+ else s++instance FromJSON Header where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON OpenApiItems where+ parseJSON js@(Object obj)+ | null obj = pure $ OpenApiItemsArray [] -- Nullary schema.+ | otherwise = OpenApiItemsObject <$> parseJSON js+ parseJSON js@(Array _) = OpenApiItemsArray <$> parseJSON js+ parseJSON _ = empty++instance FromJSON Components where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON MimeList where+ parseJSON js = MimeList . map fromString <$> parseJSON js++instance FromJSON Param where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON Responses where+ parseJSON (Object o) = Responses+ <$> o .:? "default"+ <*> parseJSON (Object (HashMap.delete "default" o))+ parseJSON _ = empty++instance FromJSON Example where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON Response where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON Operation where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON PathItem where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON SecurityDefinitions where+ parseJSON js = SecurityDefinitions <$> parseJSON js++instance FromJSON RequestBody where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON MediaTypeObject where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON Encoding where+ parseJSON = sopSwaggerGenericParseJSON++instance FromJSON Link where+ parseJSON = sopSwaggerGenericParseJSON++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 -> Ref <$> parseRef s+ where+ parseRef s = do+ case Text.stripPrefix prefix s of+ Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s+ Just suffix -> pure (Reference suffix)+referencedParseJSON _ _ = fail "referenceParseJSON: not an object"++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 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 HasSwaggerAesonOptions Server where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "server"+instance HasSwaggerAesonOptions Components where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "components"+instance HasSwaggerAesonOptions Header where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "header"+instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "params"+instance HasSwaggerAesonOptions OAuth2Flows where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows"+instance HasSwaggerAesonOptions Operation where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"+instance HasSwaggerAesonOptions Param where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "param"+instance HasSwaggerAesonOptions PathItem where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"+instance HasSwaggerAesonOptions Response where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "response"+instance HasSwaggerAesonOptions RequestBody where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody"+instance HasSwaggerAesonOptions MediaTypeObject where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject"+instance HasSwaggerAesonOptions Responses where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"+instance HasSwaggerAesonOptions SecurityScheme where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"+instance HasSwaggerAesonOptions Schema where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"+instance HasSwaggerAesonOptions OpenApi where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")]+instance HasSwaggerAesonOptions Example where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "example"+instance HasSwaggerAesonOptions Encoding where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding"++instance HasSwaggerAesonOptions Link where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "link"++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
+ src/Data/OpenApi/Internal/AesonUtils.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableSuperClasses #-}+module Data.OpenApi.Internal.AesonUtils (+ -- * Generic functions+ AesonDefaultValue(..),+ sopSwaggerGenericToJSON,+ sopSwaggerGenericToEncoding,+ sopSwaggerGenericToJSONWithOpts,+ sopSwaggerGenericParseJSON,+ -- * Options+ HasSwaggerAesonOptions(..),+ SwaggerAesonOptions,+ mkSwaggerAesonOptions,+ saoPrefix,+ saoAdditionalPairs,+ saoSubObject,+ ) where++import Prelude ()+import Prelude.Compat++import Control.Applicative ((<|>))+import Control.Lens (makeLenses, (^.))+import Control.Monad (unless)+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject, Encoding, pairs, (.=), Series)+import Data.Aeson.Types (Parser, Pair)+import Data.Char (toLower, isUpper)+import Data.Foldable (traverse_)+import Data.Text (Text)++import Generics.SOP++import qualified Data.Text as T+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set+import qualified Data.HashMap.Strict.InsOrd as InsOrd+import qualified Data.HashSet.InsOrd as InsOrdHS++-------------------------------------------------------------------------------+-- SwaggerAesonOptions+-------------------------------------------------------------------------------++data SwaggerAesonOptions = SwaggerAesonOptions+ { _saoPrefix :: String+ , _saoAdditionalPairs :: [(Text, Value)]+ , _saoSubObject :: Maybe String+ }++mkSwaggerAesonOptions+ :: String -- ^ prefix+ -> SwaggerAesonOptions+mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing++makeLenses ''SwaggerAesonOptions++class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where+ swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions++ -- 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 swagger records.+--+-- Features+--+-- * omits nulls, empty objects and empty arrays (configurable)+-- * possible to add fields+-- * possible to merge sub-object+sopSwaggerGenericToJSON+ :: forall a xs.+ ( HasDatatypeInfo a+ , HasSwaggerAesonOptions a+ , All2 ToJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => a+ -> Value+sopSwaggerGenericToJSON x =+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)+ in object (opts ^. saoAdditionalPairs ++ ps)+ where+ proxy = Proxy :: Proxy a+ opts = swaggerAesonOptions proxy++-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)+--+-- Also uses default `aesonDefaults`+sopSwaggerGenericToJSONWithOpts+ :: forall a xs.+ ( Generic a+ , All2 AesonDefaultValue (Code a)+ , HasDatatypeInfo a+ , All2 ToJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => SwaggerAesonOptions+ -> a+ -> Value+sopSwaggerGenericToJSONWithOpts opts x =+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs+ in object (opts ^. saoAdditionalPairs ++ ps)+ where+ proxy = Proxy :: Proxy a+ defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue++sopSwaggerGenericToJSON'+ :: (All2 ToJSON '[xs], All2 Eq '[xs])+ => SwaggerAesonOptions+ -> SOP I '[xs]+ -> DatatypeInfo '[xs]+ -> POP Maybe '[xs]+ -> [Pair]+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =+ sopSwaggerGenericToJSON'' opts fields fieldsInfo defs+sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"++sopSwaggerGenericToJSON''+ :: (All ToJSON xs, All Eq xs)+ => SwaggerAesonOptions+ -> NP I xs+ -> NP FieldInfo xs+ -> NP Maybe xs+ -> [Pair]+sopSwaggerGenericToJSON'' (SwaggerAesonOptions 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 -> HM.toList m ++ rest+ Null -> rest+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json+ -- If default value: omit it.+ | Just x == def =+ rest+ | otherwise =+ (T.pack 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+-------------------------------------------------------------------------------++sopSwaggerGenericParseJSON+ :: forall a xs.+ ( HasDatatypeInfo a+ , HasSwaggerAesonOptions a+ , All2 FromJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => Value+ -> Parser a+sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->+ let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)+ in do+ traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)+ to <$> ps+ where+ proxy = Proxy :: Proxy a+ opts = swaggerAesonOptions proxy++ parseAdditionalField :: Object -> (Text, Value) -> Parser ()+ parseAdditionalField obj (k, v) = do+ v' <- obj .: k+ unless (v == v') $ fail $+ "Additonal field don't match for key " ++ T.unpack k+ ++ ": " ++ show v+ ++ " /= " ++ show v'++sopSwaggerGenericParseJSON'+ :: (All2 FromJSON '[xs], All2 Eq '[xs])+ => SwaggerAesonOptions+ -> Object+ -> DatatypeInfo '[xs]+ -> POP Maybe '[xs]+ -> Parser (SOP I '[xs])+sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =+ SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs+sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"++sopSwaggerGenericParseJSON''+ :: (All FromJSON xs, All Eq xs)+ => SwaggerAesonOptions+ -> Object+ -> NP FieldInfo xs+ -> NP Maybe xs+ -> Parser (NP I xs)+sopSwaggerGenericParseJSON'' (SwaggerAesonOptions 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 .:? T.pack name' .!= def' <*> rest+ Nothing -> cons <$> obj .: T.pack 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+-------------------------------------------------------------------------------++sopSwaggerGenericToEncoding+ :: forall a xs.+ ( HasDatatypeInfo a+ , HasSwaggerAesonOptions a+ , All2 ToJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => a+ -> Encoding+sopSwaggerGenericToEncoding x =+ let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)+ in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)+ where+ proxy = Proxy :: Proxy a+ opts = swaggerAesonOptions proxy++pairsToSeries :: [Pair] -> Series+pairsToSeries = foldMap (\(k, v) -> (k .= v))++sopSwaggerGenericToEncoding'+ :: (All2 ToJSON '[xs], All2 Eq '[xs])+ => SwaggerAesonOptions+ -> SOP I '[xs]+ -> DatatypeInfo '[xs]+ -> POP Maybe '[xs]+ -> Series+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =+ sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs+sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"++sopSwaggerGenericToEncoding''+ :: (All ToJSON xs, All Eq xs)+ => SwaggerAesonOptions+ -> NP I xs+ -> NP FieldInfo xs+ -> NP Maybe xs+ -> Series+sopSwaggerGenericToEncoding'' (SwaggerAesonOptions 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 (HM.toList m) <> rest+ Null -> rest+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)+ -- If default value: omit it.+ | Just x == def =+ rest+ | otherwise =+ (T.pack name' .= x) <> rest+ where+ name' = fieldNameModifier name+ rest = go xs names defs++ fieldNameModifier = modifier . drop 1+ modifier = lowerFirstUppers . drop (length prefix)+ lowerFirstUppers s = map toLower x ++ y+ where (x, y) = span isUpper s
+ src/Data/OpenApi/Internal/ParamSchema.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+-- 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 where++import Control.Lens+import Data.Aeson (ToJSON (..))+import Data.Proxy+import GHC.Generics++import Data.Int+import "unordered-containers" Data.HashSet (HashSet)+import Data.Monoid+import Data.Set (Set)+import Data.Scientific+import Data.Fixed (HasResolution(..), Fixed, Pico)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Time+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import Data.Version (Version)+import Numeric.Natural.Compat (Natural)+import Data.Word+import Data.UUID.Types (UUID)+import Web.Cookie (SetCookie)++import Data.OpenApi.Internal+import Data.OpenApi.Lens+import Data.OpenApi.SchemaOptions++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import GHC.TypeLits (TypeError, ErrorMessage(..))++-- | Default schema for binary data (any sequence of octets).+binarySchema :: Schema+binarySchema = mempty+ & type_ ?~ OpenApiString+ & format ?~ "binary"++-- | Default schema for binary data (base64 encoded).+byteSchema :: Schema+byteSchema = mempty+ & type_ ?~ 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_ ?~ 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_ ?~ 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.+ --+ -- >>> encode $ 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_ ?~ OpenApiString++instance ToParamSchema Bool where+ toParamSchema _ = mempty & type_ ?~ OpenApiBoolean++instance ToParamSchema Integer where+ toParamSchema _ = mempty & type_ ?~ OpenApiInteger++instance ToParamSchema Natural where+ toParamSchema _ = mempty+ & type_ ?~ OpenApiInteger+ & minimum_ ?~ 0+ & exclusiveMinimum ?~ False++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.+--+-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)+-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"+toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema+toParamSchemaBoundedIntegral _ = mempty+ & type_ ?~ OpenApiInteger+ & minimum_ ?~ fromInteger (toInteger (minBound :: a))+ & maximum_ ?~ fromInteger (toInteger (maxBound :: a))++instance ToParamSchema Char where+ toParamSchema _ = mempty+ & type_ ?~ OpenApiString+ & maxLength ?~ 1+ & minLength ?~ 1++instance ToParamSchema Scientific where+ toParamSchema _ = mempty & type_ ?~ OpenApiNumber++instance HasResolution a => ToParamSchema (Fixed a) where+ toParamSchema _ = mempty+ & type_ ?~ OpenApiNumber+ & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))++instance ToParamSchema Double where+ toParamSchema _ = mempty+ & type_ ?~ OpenApiNumber+ & format ?~ "double"++instance ToParamSchema Float where+ toParamSchema _ = mempty+ & type_ ?~ OpenApiNumber+ & format ?~ "float"++timeParamSchema :: String -> Schema+timeParamSchema fmt = mempty+ & type_ ?~ 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 "yyyy-mm-ddThh:MM:ss+hhMM"+instance ToParamSchema ZonedTime where+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"++-- |+-- >>> 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_ ?~ OpenApiString+ & pattern ?~ "^\\d+(\\.\\d+)*$"++instance ToParamSchema SetCookie where+ toParamSchema _ = mempty+ & type_ ?~ 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_ ?~ 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))++-- |+-- >>> encode $ toParamSchema (Proxy :: Proxy ())+-- "{\"type\":\"string\",\"enum\":[\"_\"]}"+instance ToParamSchema () where+ toParamSchema _ = mempty+ & type_ ?~ OpenApiString+ & enum_ ?~ ["_"]++instance ToParamSchema UUID where+ toParamSchema _ = mempty+ & type_ ?~ OpenApiString+ & format ?~ "uuid"++-- | A configurable generic @'Schema'@ creator.+--+-- >>> :set -XDeriveGeneric+-- >>> data Color = Red | Blue deriving Generic+-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)+-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"+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 :: * -> *) 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 :: * -> *) 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_ ?~ 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)
+ src/Data/OpenApi/Internal/Schema.hs view
@@ -0,0 +1,864 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+-- For TypeErrors+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}+module Data.OpenApi.Internal.Schema where++import Prelude ()+import Prelude.Compat++import Control.Lens hiding (allOf)+import Data.Data.Lens (template)++import Control.Monad+import Control.Monad.Writer+import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..),+ ToJSONKeyFunction (..), Value (..))+import Data.Char+import Data.Data (Data)+import Data.Foldable (traverse_)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import "unordered-containers" Data.HashSet (HashSet)+import qualified "unordered-containers" Data.HashSet as HashSet+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import Data.Int+import Data.IntSet (IntSet)+import Data.IntMap (IntMap)+import Data.List.NonEmpty.Compat (NonEmpty)+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Proxy+import Data.Scientific (Scientific)+import Data.Fixed (Fixed, HasResolution, Pico)+import Data.Set (Set)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Time+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import Data.Version (Version)+import Numeric.Natural.Compat (Natural)+import Data.Word+import GHC.Generics+import qualified Data.UUID.Types as UUID++import Data.OpenApi.Declare+import Data.OpenApi.Internal+import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))+import Data.OpenApi.Lens hiding (name, schema)+import qualified Data.OpenApi.Lens as Swagger+import Data.OpenApi.SchemaOptions+import Data.OpenApi.Internal.TypeShape++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BSL+import GHC.TypeLits (TypeError, ErrorMessage(..))++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++-- | 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_ ?~ 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 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 $ encode (toNamedSchema (Proxy :: Proxy String) ^. schema)+-- {"type":"string"}+--+-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name+-- Just "Day"+-- >>> BSL.putStrLn $ encode (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 $ encode $ toSchema (Proxy :: Proxy Int8)+-- {"maximum":127,"minimum":-128,"type":"integer"}+--+-- >>> BSL.putStrLn $ encode $ 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 $ encode $ toSchemaRef (Proxy :: Proxy Integer)+-- {"type":"integer"}+--+-- >>> BSL.putStrLn $ encode $ 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 $ encode $ 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 $ encode $ sketchSchema "hello"+-- {"example":"hello","type":"string"}+--+-- >>> BSL.putStrLn $ encode $ sketchSchema (1, 2, 3)+-- {"example":[1,2,3],"items":{"type":"number"},"type":"array"}+--+-- >>> BSL.putStrLn $ encode $ sketchSchema ("Jack", 25)+-- {"example":["Jack",25],"items":[{"type":"string"},{"type":"number"}],"type":"array"}+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)+-- >>> instance ToJSON Person+-- >>> BSL.putStrLn $ encode $ sketchSchema (Person "Jack" 25)+-- {"example":{"age":25,"name":"Jack"},"required":["age","name"],"type":"object","properties":{"age":{"type":"number"},"name":{"type":"string"}}}+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_ ?~ OpenApiNull+ go (Bool _) = mempty & type_ ?~ OpenApiBoolean+ go (String _) = mempty & type_ ?~ OpenApiString+ go (Number _) = mempty & type_ ?~ OpenApiNumber+ go (Array xs) = mempty+ & type_ ?~ OpenApiArray+ & items ?~ case ischema of+ Just s -> OpenApiItemsObject (Inline s)+ _ -> OpenApiItemsArray (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_ ?~ OpenApiObject+ & required .~ HashMap.keys o+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)++-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.+-- Produced schema uses as much constraints as possible.+--+-- >>> BSL.putStrLn $ encode $ sketchStrictSchema "hello"+-- {"maxLength":5,"pattern":"hello","minLength":5,"type":"string","enum":["hello"]}+--+-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (1, 2, 3)+-- {"minItems":3,"uniqueItems":true,"items":[{"maximum":1,"minimum":1,"multipleOf":1,"type":"number","enum":[1]},{"maximum":2,"minimum":2,"multipleOf":2,"type":"number","enum":[2]},{"maximum":3,"minimum":3,"multipleOf":3,"type":"number","enum":[3]}],"maxItems":3,"type":"array","enum":[[1,2,3]]}+--+-- >>> BSL.putStrLn $ encode $ sketchStrictSchema ("Jack", 25)+-- {"minItems":2,"uniqueItems":true,"items":[{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]},{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]}],"maxItems":2,"type":"array","enum":[["Jack",25]]}+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)+-- >>> instance ToJSON Person+-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (Person "Jack" 25)+-- {"minProperties":2,"required":["age","name"],"maxProperties":2,"type":"object","enum":[{"age":25,"name":"Jack"}],"properties":{"age":{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]},"name":{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]}}}+sketchStrictSchema :: ToJSON a => a -> Schema+sketchStrictSchema = go . toJSON+ where+ go Null = mempty & type_ ?~ OpenApiNull+ go js@(Bool _) = mempty+ & type_ ?~ OpenApiBoolean+ & enum_ ?~ [js]+ go js@(String s) = mempty+ & type_ ?~ OpenApiString+ & maxLength ?~ fromIntegral (T.length s)+ & minLength ?~ fromIntegral (T.length s)+ & pattern ?~ s+ & enum_ ?~ [js]+ go js@(Number n) = mempty+ & type_ ?~ OpenApiNumber+ & maximum_ ?~ n+ & minimum_ ?~ n+ & multipleOf ?~ n+ & enum_ ?~ [js]+ go js@(Array xs) = mempty+ & type_ ?~ OpenApiArray+ & maxItems ?~ fromIntegral sz+ & minItems ?~ fromIntegral sz+ & items ?~ OpenApiItemsArray (map (Inline . go) (V.toList xs))+ & uniqueItems ?~ allUnique+ & enum_ ?~ [js]+ where+ sz = length xs+ allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))+ go js@(Object o) = mempty+ & type_ ?~ OpenApiObject+ & required .~ names+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)+ & maxProperties ?~ fromIntegral (length names)+ & minProperties ?~ fromIntegral (length names)+ & enum_ ?~ [js]+ where+ names = HashMap.keys o++class GToSchema (f :: * -> *) 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_ ?~ 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.Swagger.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 HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema++instance ToSchema a => ToSchema (Maybe a) where+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)++instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where+ -- To match Aeson instance+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField }++instance ToSchema () where+ declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)++-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.+instance ToSchema UUID.UUID where+ declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p+ & example ?~ toJSON (UUID.toText UUID.nil)++instance (ToSchema a, ToSchema b) => ToSchema (a, b)+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)++timeSchema :: T.Text -> Schema+timeSchema fmt = mempty+ & type_ ?~ 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"@ 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_ ?~ 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_ ?~ 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 $ encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)+-- {"maximum":32767,"minimum":-32768,"type":"integer"}+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema+toSchemaBoundedIntegral _ = mempty+ & type_ ?~ 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))))+ => SchemaOptions -- ^ How to derive the name.+ -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.+ -> 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 $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))+-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}+--+-- 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 keyToText _ -> objectSchema keyToText+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])+ where+ objectSchema keyToText = do+ valueRef <- declareSchemaRef (Proxy :: Proxy value)+ let allKeys = [minBound..maxBound :: key]+ mkPair k = (keyToText k, valueRef)+ return $ mempty+ & type_ ?~ 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 $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))+-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}+--+-- 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)) =>+ 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'@.+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty++-- | 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' usinng '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' usinng 'ToParamSchema'.+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema+paramSchemaToSchema = toParamSchema++nullarySchema :: Schema+nullarySchema = mempty+ & type_ ?~ OpenApiArray+ & items ?~ OpenApiItemsArray []++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 ^. items of+ Just (OpenApiItemsArray [_]) -> fieldSchema+ _ -> do+ declare defs+ return (unnamed schema)+ where+ (defs, 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++appendItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems+appendItem x Nothing = Just (OpenApiItemsArray [x])+appendItem x (Just (OpenApiItemsArray xs)) = Just (OpenApiItemsArray (xs ++ [x]))+appendItem _ _ = error "GToSchema.appendItem: cannot append to OpenApiItemsObject"++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 schema+ & type_ ?~ OpenApiArray+ & items %~ appendItem ref+ & maxItems %~ Just . maybe 1 (+1) -- increment maxItems+ & minItems %~ Just . maybe 1 (+1) -- increment minItems+ else schema+ & type_ ?~ 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 p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s++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+ & type_ ?~ OpenApiObject+ & oneOf ?~ (snd <$> schemas)+ where+ declareSumSchema = gsumToSchema opts proxy+ (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)++ toStringTag schemas = mempty+ & type_ ?~ OpenApiString+ & enum_ ?~ map (String . fst) sumSchemas++type AllNullary = All++class GSumToSchema (f :: * -> *) 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, schema)+ where+ 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) | sub ^. type_ == Just OpenApiObject && isRecord -> Inline $ sub+ & required <>~ [T.pack tagField]+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])++ -- If it is not a record, we need to put subschema into "contents" field.+ _ | not isRecord -> Inline $ mempty+ & type_ ?~ OpenApiObject+ & required .~ [T.pack tagField]+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ 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+ & type_ ?~ OpenApiObject+ & allOf ?~ [Inline $ mempty+ & type_ ?~ OpenApiObject+ & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])]+ & if isRecord+ then allOf . _Just <>~ [refOrNullary]+ else allOf . _Just <>~ [Inline $ mempty & type_ ?~ OpenApiObject & properties . at (T.pack contentsField) ?~ refOrNullary]+ UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.+ ObjectWithSingleField -> Inline $ mempty+ & type_ ?~ OpenApiObject+ & required .~ [tag]+ & properties . at tag ?~ refOrNullary+ TwoElemArray -> error "unrepresentable in OpenAPI 3"++ tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))+ isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)+ refOrNullary = fromMaybe (Inline nullarySchema) ref+ refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ 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)
+ src/Data/OpenApi/Internal/Schema/Validation.hs view
@@ -0,0 +1,524 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module: Data.OpenApi.Internal.Schema.Validation+-- Copyright: (c) 2015 GetShopTV+-- License: BSD3+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Validate JSON values with Swagger Schema.+module Data.OpenApi.Internal.Schema.Validation where++import Prelude ()+import Prelude.Compat++import Control.Applicative+import Control.Lens hiding (allOf)+import Control.Monad (forM, forM_, when)++import Data.Aeson hiding (Result)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.Foldable (for_, sequenceA_,+ traverse_)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import qualified "unordered-containers" Data.HashSet as HashSet+import Data.Maybe (fromMaybe)+import Data.Proxy+import Data.Scientific (Scientific, isInteger)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Vector (Vector)+import qualified Data.Vector as Vector++import Data.OpenApi.Declare+import Data.OpenApi.Internal+import Data.OpenApi.Internal.Schema+import Data.OpenApi.Lens++-- | 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 Swagger Schema+-- (using 'encodePretty').+--+-- >>> import Data.Aeson as Aeson+-- >>> import Data.Foldable (traverse_)+-- >>> import GHC.Generics+-- >>> data Phone = Phone { value :: String } deriving (Generic)+-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)+-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]+-- >>> instance ToSchema Phone+-- >>> instance ToSchema Person+-- >>> let person = Person { name = "John", phone = Phone "123456" }+-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person+-- Validation against the schema fails:+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"+-- <BLANKLINE>+-- JSON value:+-- {+-- "name": "John"+-- }+-- <BLANKLINE>+-- Swagger Schema:+-- {+-- "required": [+-- "name",+-- "phone"+-- ],+-- "type": "object",+-- "properties": {+-- "phone": {+-- "$ref": "#/components/schemas/Phone"+-- },+-- "name": {+-- "type": "string"+-- }+-- }+-- }+-- <BLANKLINE>+-- Swagger Description Context:+-- {+-- "Phone": {+-- "required": [+-- "value"+-- ],+-- "type": "object",+-- "properties": {+-- "value": {+-- "type": "string"+-- }+-- }+-- }+-- }+-- <BLANKLINE>+renderValidationErrors+ :: forall a. (ToJSON a, ToSchema a)+ => (a -> [ValidationError]) -> a -> Maybe String+renderValidationErrors f x =+ case f x of+ [] -> Nothing+ errors -> Just $ unlines+ [ "Validation against the schema fails:"+ , unlines (map (" * " ++) errors)+ , "JSON value:"+ , ppJSONString (toJSON x)+ , ""+ , "Swagger Schema:"+ , ppJSONString (toJSON schema_)+ , ""+ , "Swagger Description Context:"+ , ppJSONString (toJSON refs_)+ ]+ where+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty+ (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty++-- | Validate JSON @'Value'@ against Swagger @'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'@ agains Swagger @'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+ = Failed [ValidationError] -- ^ Validation failed with a list of error messages.+ | Passed a -- ^ Validation passed.+ deriving (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 (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 Swagger @'Schema'@.+validateWithSchema :: Value -> Validation Schema ()+validateWithSchema val = do+ validateSchemaType val+ validateEnum val++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+ let exMax = Just True == sch ^. exclusiveMaximum+ exMin = Just True == sch ^. exclusiveMinimum++ check maximum_ $ \m ->+ when (if exMax then (n >= m) else (n > m)) $+ invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")++ check minimum_ $ \m ->+ when (if exMin then (n <= m) else (n < m)) $+ invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ 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 ++ ")")++ check items $ \case+ OpenApiItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs+ OpenApiItemsArray itemSchemas -> do+ when (len /= length itemSchemas) $+ invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")+ sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))++ 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))++validateObject :: HashMap Text Value -> Validation Schema ()+validateObject o = withSchema $ \sch ->+ case sch ^. discriminator of+ Just (Discriminator pname types) -> case fromJSON <$> HashMap.lookup pname o of+ Just (Success pvalue) ->+ let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types+ -- TODO ref may be name or reference+ in 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 (HashMap.size o)++ validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)+ validateReq n =+ when (not (HashMap.member n o)) $+ invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))++ validateProps = withSchema $ \sch -> do+ for_ (HashMap.toList o) $ \(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 Swagger 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) ] ]+ ]++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 (sch ^. type_, val) of+ (Just OpenApiNull, Null) -> valid+ (Just OpenApiBoolean, Bool _) -> valid+ (Just OpenApiInteger, Number n) -> validateInteger n+ (Just OpenApiNumber, Number n) -> validateNumber n+ (Just OpenApiString, String s) -> validateString s+ (Just OpenApiArray, Array xs) -> validateArray xs+ (Just OpenApiObject, Object o) -> validateObject o+ (Nothing, Null) -> valid+ (Nothing, Bool _) -> valid+ -- Number by default+ (Nothing, Number n) -> validateNumber n+ (Nothing, String s) -> validateString s+ (Nothing, Array xs) -> validateArray xs+ (Nothing, Object o) -> validateObject o+ bad -> invalid $ "expected JSON value of type " ++ showType bad++validateParamSchemaType :: Value -> Validation Schema ()+validateParamSchemaType val = withSchema $ \sch ->+ case (sch ^. type_, val) of+ (Just OpenApiBoolean, Bool _) -> valid+ (Just OpenApiInteger, Number n) -> validateInteger n+ (Just OpenApiNumber, Number n) -> validateNumber n+ (Just OpenApiString, String s) -> validateString s+ (Just OpenApiArray, Array xs) -> validateArray xs+ (Nothing, Bool _) -> valid+ -- Number by default+ (Nothing, Number n) -> validateNumber n+ (Nothing, String s) -> validateString s+ (Nothing, Array xs) -> validateArray xs+ bad -> invalid $ "expected JSON value of type " ++ showType bad++showType :: (Maybe OpenApiType, Value) -> String+showType (Just ty, _) = show ty+showType (Nothing, Null) = "OpenApiNull"+showType (Nothing, Bool _) = "OpenApiBoolean"+showType (Nothing, Number _) = "OpenApiNumber"+showType (Nothing, String _) = "OpenApiString"+showType (Nothing, Array _) = "OpenApiArray"+showType (Nothing, Object _) = "OpenApiObject"
+ src/Data/OpenApi/Internal/TypeShape.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.OpenApi.Internal.TypeShape where++import Data.Proxy+import GHC.Generics+import GHC.TypeLits+import GHC.Exts (Constraint)++-- | Shape of a datatype.+data TypeShape+ = Enumeration -- ^ A simple enumeration.+ | SumOfProducts -- ^ A product or a sum of non-unit products.+ | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.++-- | 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 Swagger Schema for " :<>: ShowType t+ :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."+ :$$: Text "Swagger 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 Swagger tools."+ )++-- | Infer a 'TypeShape' for a generic representation of a type.+type family GenericShape (g :: * -> *) :: TypeShape++type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)+type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)+type instance GenericShape (D1 d f) = GenericShape f+type instance GenericShape (C1 c U1) = Enumeration+type instance GenericShape (C1 c (S1 s f)) = SumOfProducts+type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
+ src/Data/OpenApi/Internal/Utils.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+module Data.OpenApi.Internal.Utils where++import Prelude ()+import Prelude.Compat++import Control.Lens ((&), (%~))+import Control.Lens.TH+import Data.Aeson+import Data.Aeson.Types+import Data.Char+import Data.Data+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import Data.Map (Map)+import Data.Set (Set)+import Data.Text (Text)+import GHC.Generics+import Language.Haskell.TH (mkName)++swaggerFieldRules :: LensRules+swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer+ where+ swaggerFieldNamer 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' "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' 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 SwaggerMonoid a => GMonoid (K1 i a) where+ gmempty = K1 swaggerMempty+ gmappend (K1 x) (K1 y) = K1 (swaggerMappend x y)++instance GMonoid f => GMonoid (M1 i t f) where+ gmempty = M1 gmempty+ gmappend (M1 x) (M1 y) = M1 (gmappend x y)++class SwaggerMonoid m where+ swaggerMempty :: m+ swaggerMappend :: m -> m -> m+ default swaggerMempty :: Monoid m => m+ swaggerMempty = mempty+ default swaggerMappend :: Monoid m => m -> m -> m+ swaggerMappend = mappend++instance SwaggerMonoid [a]+instance Ord a => SwaggerMonoid (Set a)+instance Ord k => SwaggerMonoid (Map k v)++instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where+ swaggerMempty = mempty+ swaggerMappend = HashMap.unionWith (\_old new -> new)++instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where+ swaggerMempty = mempty+ swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)++instance SwaggerMonoid Text where+ swaggerMempty = mempty+ swaggerMappend x "" = x+ swaggerMappend _ y = y++instance SwaggerMonoid (Maybe a) where+ swaggerMempty = Nothing+ swaggerMappend x Nothing = x+ swaggerMappend _ y = y
+ src/Data/OpenApi/Lens.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module: Data.OpenApi.Lens+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Lenses and prisms for Swagger.+module Data.OpenApi.Lens where++import Control.Lens+import Data.Aeson (Value)+import Data.Scientific (Scientific)+import Data.OpenApi.Internal+import Data.OpenApi.Internal.Utils+import Data.Text (Text)++-- * Classy lenses++makeFields ''OpenApi+makeFields ''Components+makeFields ''Server+makeFields ''RequestBody+makeFields ''MediaTypeObject+makeFields ''Info+makeFields ''Contact+makeFields ''License+makeLensesWith swaggerFieldRules ''PathItem+makeFields ''Tag+makeFields ''Operation+makeLensesWith swaggerFieldRules ''Param+makeFields ''Header+makeLensesWith swaggerFieldRules ''Schema+makeFields ''NamedSchema+makeFields ''Xml+makeLensesWith swaggerFieldRules ''Responses+makeFields ''Response+makeLensesWith swaggerFieldRules ''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++_OpenApiItemsArray :: Review OpenApiItems [Referenced Schema]+_OpenApiItemsArray+ = unto (\x -> OpenApiItemsArray x)+{- \x -> case x of+ OpenApiItemsPrimitive c p -> Left (OpenApiItemsPrimitive c p)+ OpenApiItemsObject o -> Left (OpenApiItemsObject o)+ OpenApiItemsArray a -> Right a+-}++_OpenApiItemsObject :: Review OpenApiItems (Referenced Schema)+_OpenApiItemsObject+ = unto (\x -> OpenApiItemsObject x)+{- \x -> case x of+ OpenApiItemsPrimitive c p -> Left (OpenApiItemsPrimitive c p)+ OpenApiItemsObject o -> Right o+ OpenApiItemsArray a -> Left (OpenApiItemsArray a)+-}++-- =============================================================+-- 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 OpenApiType) 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 Bool) 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 Bool) where+ exclusiveMinimum = schema.exclusiveMinimum++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasMaxLength s (Maybe Integer) where+ maxLength = schema.maxLength++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasMinLength s (Maybe Integer) where+ minLength = schema.minLength++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasPattern s (Maybe Text) where+ pattern = schema.pattern++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasMaxItems s (Maybe Integer) where+ maxItems = schema.maxItems++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasMinItems s (Maybe Integer) where+ minItems = schema.minItems++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasUniqueItems s (Maybe Bool) where+ uniqueItems = schema.uniqueItems++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasEnum s (Maybe [Value]) where+ enum_ = schema.enum_++instance {-# OVERLAPPABLE #-} HasSchema s Schema+ => HasMultipleOf s (Maybe Scientific) where+ multipleOf = schema.multipleOf
+ src/Data/OpenApi/Operation.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module: Data.OpenApi.Operation+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Helper traversals and functions for Swagger operations manipulations.+-- These might be useful when you already have Swagger 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 Prelude ()+import Prelude.Compat++import Control.Lens+import Data.Data.Lens+import Data.List.Compat+import Data.Maybe (mapMaybe)+import Data.Proxy+import qualified Data.Set as Set+import Data.Text (Text)+import Network.HTTP.Media (MediaType)++import Data.OpenApi.Declare+import Data.OpenApi.Internal+import Data.OpenApi.Lens+import Data.OpenApi.Schema++import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import qualified Data.HashSet.InsOrd as InsOrdHS++-- $setup+-- >>> import Data.Aeson+-- >>> import Data.Proxy+-- >>> import Data.Time+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL++-- | Prepend path piece to all operations of the spec.+-- Leading and trailing slashes are trimmed/added automatically.+--+-- >>> let api = (mempty :: OpenApi) & paths .~ [("/info", mempty)]+-- >>> BSL.putStrLn $ encode $ 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 a Swagger 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 .~ [("/user", mempty & get ?~ ok & post ?~ ok)]+-- >>> let sub = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)]+-- >>> BSL.putStrLn $ encode api+-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}}+-- >>> BSL.putStrLn $ encode $ api & operationsOf sub . at 404 ?~ "Not found"+-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"Not found"},"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}}+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 Swagger 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 with @'Schema'@ while declaring all+-- necessary schema definitions.+--+-- FIXME doc+--+-- >>> BSL.putStrLn $ encode $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty+-- [{"Day":{"example":"2016-07-22","format":"date","type":"string"}},{"description":"","content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}}}]+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 .~ [("/user", mempty & get ?~ mempty)]+-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day)+-- >>> BSL.putStrLn $ encode $ api & setResponse 200 res+-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}},"description":""}}}}},"components":{"schemas":{"Day":{"example":"2016-07-22","format":"date","type":"string"}}}}+--+-- See also @'setResponseWith'@.+setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponse = setResponseFor allOperations++-- | Set or update response for all operations.+-- This will also update global schema definitions.+--+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),+-- then just the new response is used.+--+-- @+-- 'setResponseWith' = 'setResponseForWith' 'allOperations'+-- @+--+-- See also @'setResponse'@.+setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponseWith = setResponseForWith allOperations++-- | Set response for specified operations.+-- This will also update global schema definitions.+--+-- If the response already exists it will be overwritten.+--+-- See also @'setResponseForWith'@.+setResponseFor :: Traversal' OpenApi Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponseFor ops code dres swag = swag+ & components.schemas %~ (<> defs)+ & ops . at code ?~ Inline res+ where+ (defs, res) = runDeclare dres mempty++-- | Set or update response for specified operations.+-- This will also update global schema definitions.+--+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),+-- then just the new response is used.+--+-- See also @'setResponseFor'@.+setResponseForWith :: Traversal' OpenApi Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi+setResponseForWith ops f code dres swag = swag+ & components.schemas %~ (<> defs)+ & ops . at code %~ Just . Inline . combine+ where+ (defs, new) = runDeclare dres mempty++ combine (Just (Ref (Reference n))) = case swag ^. components.responses.at n of+ Just old -> f old new+ Nothing -> new -- response name can't be dereferenced, replacing with new response+ combine (Just (Inline old)) = f old new+ combine Nothing = new
+ src/Data/OpenApi/Optics.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module: Data.OpenApi.Optics+-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>+-- Stability: experimental+--+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>+-- library.+--+-- >>> import Data.Aeson+-- >>> import Optics.Core+-- >>> :set -XOverloadedLabels+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL+--+-- Example from the "Data.OpenApi" module using @optics@:+--+-- >>> :{+-- BSL.putStrLn $ encode $ (mempty :: OpenApi)+-- & #components % #schemas .~ [ ("User", mempty & #type ?~ OpenApiString) ]+-- & #paths .~+-- [ ("/user", mempty & #get ?~ (mempty+-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User")))+-- & at 404 ?~ "User info not found")) ]+-- :}+-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}}+--+-- 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 a Swagger specification can have+-- descriptions, and you can use the same name for them:+--+-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & #description .~ "No content"+-- {"description":"No content"}+-- >>> :{+-- BSL.putStrLn $ encode $ (mempty :: Schema)+-- & #type ?~ OpenApiBoolean+-- & #description ?~ "To be or not to be"+-- :}+-- {"type":"boolean","description":"To be or not to be"}+--+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:+--+-- >>> :{+-- BSL.putStrLn $ encode $ (mempty :: Operation)+-- & at 404 ?~ "Not found"+-- :}+-- {"responses":{"404":{"description":"Not found"}}}+--+module Data.OpenApi.Optics () where++import Data.Aeson (Value)+import Data.Scientific (Scientific)+import Data.OpenApi.Internal+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 ~ [Referenced Schema]+ , b ~ [Referenced Schema]+ ) => LabelOptic "_OpenApiItemsArray"+ A_Review+ OpenApiItems+ OpenApiItems+ a+ b where+ labelOptic = unto (\x -> OpenApiItemsArray 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 OpenApiType+ , b ~ Maybe OpenApiType+ ) => 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 Bool, b ~ Maybe Bool+ ) => 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 Bool, b ~ Maybe Bool+ ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #exclusiveMinimum+ {-# INLINE labelOptic #-}++-- #maxLength++instance+ ( a ~ Maybe Integer, b ~ Maybe Integer+ ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #maxLength+ {-# INLINE labelOptic #-}++-- #minLength++instance+ ( a ~ Maybe Integer, b ~ Maybe Integer+ ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #minLength+ {-# INLINE labelOptic #-}++-- #pattern++instance+ ( a ~ Maybe Text, b ~ Maybe Text+ ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #pattern+ {-# INLINE labelOptic #-}++-- #maxItems++instance+ ( a ~ Maybe Integer, b ~ Maybe Integer+ ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #maxItems+ {-# INLINE labelOptic #-}++-- #minItems++instance+ ( a ~ Maybe Integer, b ~ Maybe Integer+ ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #minItems+ {-# INLINE labelOptic #-}++-- #uniqueItems++instance+ ( a ~ Maybe Bool, b ~ Maybe Bool+ ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #uniqueItems+ {-# INLINE labelOptic #-}++-- #enum++instance+ ( a ~ Maybe [Value], b ~ Maybe [Value]+ ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #enum+ {-# INLINE labelOptic #-}++-- #multipleOf++instance+ ( a ~ Maybe Scientific, b ~ Maybe Scientific+ ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where+ labelOptic = #schema % #multipleOf+ {-# INLINE labelOptic #-}
+ src/Data/OpenApi/ParamSchema.hs view
@@ -0,0 +1,26 @@+-- |+-- Module: Data.OpenApi.ParamSchema+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Types and functions for working with Swagger parameter schema.+module Data.OpenApi.ParamSchema (+ -- * Encoding+ ToParamSchema(..),++ -- * Generic schema encoding+ genericToParamSchema,+ toParamSchemaBoundedIntegral,++ -- * Schema templates+ passwordSchema,+ binarySchema,+ byteSchema,++ -- * Generic encoding configuration+ SchemaOptions(..),+ defaultSchemaOptions,+) where++import Data.OpenApi.Internal.ParamSchema+import Data.OpenApi.SchemaOptions
+ src/Data/OpenApi/Schema.hs view
@@ -0,0 +1,52 @@+-- |+-- Module: Data.OpenApi.Schema+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Types and functions for working with Swagger schema.+module Data.OpenApi.Schema (+ -- * Encoding+ ToSchema(..),+ declareSchema,+ declareSchemaRef,+ toSchema,+ toSchemaRef,+ schemaName,+ toInlinedSchema,++ -- * Generic schema encoding+ genericDeclareNamedSchema,+ genericDeclareSchema,+ genericDeclareNamedSchemaNewtype,+ genericNameSchema,++ -- ** 'Bounded' 'Integral'+ genericToNamedSchemaBoundedIntegral,+ toSchemaBoundedIntegral,++ -- ** 'Bounded' 'Enum' key mappings+ declareSchemaBoundedEnumKeyMapping,+ toSchemaBoundedEnumKeyMapping,++ -- ** Reusing 'ToParamSchema'+ paramSchemaToNamedSchema,+ paramSchemaToSchema,++ -- * Sketching @'Schema'@s using @'ToJSON'@+ sketchSchema,+ sketchStrictSchema,++ -- * Inlining @'Schema'@s+ inlineNonRecursiveSchemas,+ inlineAllSchemas,+ inlineSchemas,+ inlineSchemasWhen,++ -- * Generic encoding configuration+ SchemaOptions(..),+ defaultSchemaOptions,+ fromAesonOptions,+) where++import Data.OpenApi.Internal.Schema+import Data.OpenApi.SchemaOptions
+ src/Data/OpenApi/Schema/Generator.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.OpenApi.Schema.Generator where++import Prelude ()+import Prelude.Compat++import Control.Lens.Operators+import Control.Monad (filterM)+import Data.Aeson+import Data.Aeson.Types+import qualified Data.HashMap.Strict.InsOrd as M+import Data.Maybe+import Data.Proxy+import Data.Scientific+import qualified Data.Set as S+import Data.OpenApi+import Data.OpenApi.Declare+import Data.OpenApi.Internal.Schema.Validation (inferSchemaTypes)+import qualified Data.Text as T+import qualified Data.Vector as V+import Test.QuickCheck (arbitrary)+import Test.QuickCheck.Gen+import Test.QuickCheck.Property++-- | 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 schema ^. type_ of+ Nothing ->+ case inferSchemaTypes schema of+ [ inferredType ] -> schemaGen defns (schema & type_ ?~ 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 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+ OpenApiItemsArray refs ->+ let itemGens = schemaGen defns . dereference defns <$> refs+ in fmap (Array . V.fromList) $ sequence itemGens+ 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 $ M.toHashMap x++dereference :: Definitions a -> Referenced a -> a+dereference _ (Inline a) = a+dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs++genValue :: (ToSchema a) => Proxy a -> Gen Value+genValue p =+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty+ in schemaGen defs schema++validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property+validateFromJSON p = forAll (genValue p) $+ \val -> case parseEither parseJSON val of+ Right (_ :: a) -> succeeded+ Left err -> failed+ { reason = err+ }
+ src/Data/OpenApi/Schema/Validation.hs view
@@ -0,0 +1,90 @@+-- |+-- Module: Data.OpenApi.Schema.Validation+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Validate JSON values with Swagger 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 Swagger specification.+--+-- It is recommended to use validation functions as QuickCheck properties+-- (see <http://hackage.haskell.org/package/QuickCheck>).++-- $examples+--+-- >>> validateToJSON "hello"+-- []+--+-- >>> validateToJSON False+-- []+--+-- >>> newtype Nat = Nat Integer deriving Generic+-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n+-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0+-- >>> validateToJSON (Nat 10)+-- []+-- >>> validateToJSON (Nat (-5))+-- ["value -5.0 falls below minimum (should be >=0.0)"]++-- $maybe+--+-- Because @'Maybe' a@ has the same schema as @a@, validation+-- generally fails for @null@ JSON:+--+-- >>> validateToJSON (Nothing :: Maybe String)+-- ["expected JSON value of type OpenApiString"]+-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])+-- ["expected JSON value of type OpenApiString"]+-- >>> validateToJSON (123, Nothing :: Maybe String)+-- ["expected JSON value of type OpenApiString"]+--+-- However, when @'Maybe' a@ is a type of a record field,+-- validation takes @'required'@ property of the @'Schema'@+-- into account:+--+-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic+-- >>> instance ToJSON Person+-- >>> instance ToSchema Person+-- >>> validateToJSON (Person "Nick" (Just 24))+-- []+-- >>> validateToJSON (Person "Nick" Nothing)+-- []
+ src/Data/OpenApi/SchemaOptions.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module: Data.OpenApi.SchemaOptions+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability: experimental+--+-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.+module Data.OpenApi.SchemaOptions where++import qualified Data.Aeson.Types as Aeson++-- | Options that specify how to encode your type to Swagger schema.+data SchemaOptions = SchemaOptions+ { -- | Function applied to field labels. Handy for removing common record prefixes for example.+ fieldLabelModifier :: String -> String+ -- | Function applied to constructor tags which could be handy for lower-casing them for example.+ , constructorTagModifier :: String -> String+ -- | Function applied to datatype name.+ , datatypeNameModifier :: String -> String+ -- | If @'True'@ the constructors of a datatype, with all nullary constructors,+ -- will be encoded to a string enumeration schema with the constructor tags as possible values.+ , allNullaryToStringTag :: Bool+ -- | Hide the field name when a record constructor has only one field, like a newtype.+ , unwrapUnaryRecords :: Bool+ -- | Specifies how to encode constructors of a sum datatype.+ , sumEncoding :: Aeson.SumEncoding+ }++-- | Default encoding @'SchemaOptions'@.+--+-- @+-- 'SchemaOptions'+-- { 'fieldLabelModifier' = id+-- , 'constructorTagModifier' = id+-- , 'datatypeNameModifier' = id+-- , 'allNullaryToStringTag' = True+-- , 'unwrapUnaryRecords' = False+-- , 'sumEncoding' = 'Aeson.defaultTaggedObject'+-- }+-- @+defaultSchemaOptions :: SchemaOptions+defaultSchemaOptions = SchemaOptions+ { fieldLabelModifier = id+ , constructorTagModifier = id+ , datatypeNameModifier = id+ , allNullaryToStringTag = True+ , unwrapUnaryRecords = False+ , sumEncoding = Aeson.defaultTaggedObject+ }++-- | Convert 'Aeson.Options' to 'SchemaOptions'.+--+-- Specifically the following fields get copied:+--+-- * 'fieldLabelModifier'+-- * 'constructorTagModifier'+-- * 'allNullaryToStringTag'+-- * 'unwrapUnaryRecords'+--+-- Note that these fields have no effect on `SchemaOptions`:+--+-- * 'Aeson.omitNothingFields'+-- * 'Aeson.tagSingleConstructors'+--+-- The rest is defined as in 'defaultSchemaOptions'.+--+-- @since 2.2.1+--+fromAesonOptions :: Aeson.Options -> SchemaOptions+fromAesonOptions opts = defaultSchemaOptions+ { fieldLabelModifier = Aeson.fieldLabelModifier opts+ , constructorTagModifier = Aeson.constructorTagModifier opts+ , allNullaryToStringTag = Aeson.allNullaryToStringTag opts+ , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts+ , sumEncoding = Aeson.sumEncoding opts+ }
+ test/Data/OpenApi/CommonTestTypes.hs view
@@ -0,0 +1,919 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.OpenApi.CommonTestTypes where++import Prelude ()+import Prelude.Compat++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.Proxy+import Data.Set (Set)+import qualified Data.Text as Text+import Data.Word+import GHC.Generics++import Data.OpenApi++-- ========================================================================+-- 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"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "PC"+ ]+ },+ "contents": {+ "$ref": "#/components/schemas/Player"+ }+ }+ },+ {+ "required": [+ "npcName",+ "npcPosition",+ "tag"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NPC"+ ]+ },+ "npcPosition": {+ "$ref": "#/components/schemas/Point"+ },+ "npcName": {+ "type": "string"+ }+ }+ }+ ],+ "type": "object"+}++|]++characterInlinedSchemaJSON :: Value+characterInlinedSchemaJSON = [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag",+ "contents"+ ],+ "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"+ ],+ "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"+ }+ }+ }+ ],+ "type": "object"+}+|]++characterInlinedPlayerSchemaJSON :: Value+characterInlinedPlayerSchemaJSON = [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag",+ "contents"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "PC"+ ]+ },+ "contents": {+ "required": [+ "position"+ ],+ "type": "object",+ "properties": {+ "position": {+ "$ref": "#/components/schemas/Point"+ }+ }+ }+ }+ },+ {+ "required": [+ "npcName",+ "npcPosition",+ "tag"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NPC"+ ]+ },+ "npcPosition": {+ "$ref": "#/components/schemas/Point"+ },+ "npcName": {+ "type": "string"+ }+ }+ }+ ],+ "type": "object"+}+|]++-- ========================================================================+-- ISPair (non-record product data type)+-- ========================================================================+data ISPair = ISPair Integer String+ deriving (Generic)++instance ToSchema ISPair++ispairSchemaJSON :: Value+ispairSchemaJSON = [aesonQQ|+{+ "type": "array",+ "items":+ [+ { "type": "integer" },+ { "type": "string" }+ ],+ "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"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NoLight"+ ]+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightFreq"+ ]+ },+ "contents": {+ "format": "double",+ "type": "number"+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightColor"+ ]+ },+ "contents": {+ "$ref": "#/components/schemas/Color"+ }+ }+ },+ {+ "required": [+ "waveLength",+ "tag"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightWaveLength"+ ]+ },+ "waveLength": {+ "format": "double",+ "type": "number"+ }+ }+ }+ ],+ "type": "object"+}+|]++lightInlinedSchemaJSON :: Value+lightInlinedSchemaJSON = [aesonQQ|+{+ "oneOf": [+ {+ "required": [+ "tag"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "NoLight"+ ]+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightFreq"+ ]+ },+ "contents": {+ "format": "double",+ "type": "number"+ }+ }+ },+ {+ "required": [+ "tag",+ "contents"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightColor"+ ]+ },+ "contents": {+ "type": "string",+ "enum": [+ "Red",+ "Green",+ "Blue"+ ]+ }+ }+ },+ {+ "required": [+ "waveLength",+ "tag"+ ],+ "type": "object",+ "properties": {+ "tag": {+ "type": "string",+ "enum": [+ "LightWaveLength"+ ]+ },+ "waveLength": {+ "format": "double",+ "type": "number"+ }+ }+ }+ ],+ "type": "object"+}+|]++-- ========================================================================+-- 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" }+ }+}+|]+++-- ========================================================================+-- TimeOfDay+-- ========================================================================+data TimeOfDay+ = Int+ | Pico+ deriving (Generic)+instance ToSchema TimeOfDay+instance ToParamSchema TimeOfDay+++timeOfDaySchemaJSON :: Value+timeOfDaySchemaJSON = [aesonQQ|+{+ "example": "12:33:15",+ "type": "string",+ "format": "hh:MM:ss"+}+|]++timeOfDayParamSchemaJSON :: Value+timeOfDayParamSchemaJSON = [aesonQQ|+{+ "type": "string",+ "format": "hh:MM:ss"+}+|]+++-- ========================================================================+-- UnsignedInts+-- ========================================================================+data UnsignedInts = UnsignedInts+ { unsignedIntsUint32 :: Word32+ , unsignedIntsUint64 :: Word64+ } deriving (Generic)++instance ToSchema UnsignedInts where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "unsignedInts") }++unsignedIntsSchemaJSON :: Value+unsignedIntsSchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "uint32": { "type": "integer", "format": "int32", "minimum": 0, "maximum": 4294967295 },+ "uint64": { "type": "integer", "format": "int64", "minimum": 0, "maximum": 18446744073709551615 }+ },+ "required": ["uint32", "uint64"]+}+|]
+ test/Data/OpenApi/ParamSchemaSpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.OpenApi.ParamSchemaSpec where++import Data.Aeson+import Data.Aeson.QQ.Simple+import Data.Char+import Data.Proxy+import GHC.Generics++import Data.OpenApi++import Data.OpenApi.CommonTestTypes+import SpecCommon+import Test.Hspec+import Data.Time.LocalTime++import qualified Data.HashMap.Strict as HM++checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec+checkToParamSchema proxy js = (toParamSchema proxy :: Schema) <=> js++spec :: Spec+spec = do+ describe "Generic ToParamSchema" $ do+ context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON+ context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON+ context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON+ context "Unary records" $ do+ context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON+ context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON++main :: IO ()+main = hspec spec
+ test/Data/OpenApi/Schema/GeneratorSpec.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+module Data.OpenApi.Schema.GeneratorSpec where++import Prelude ()+import Prelude.Compat++import Data.OpenApi+import Data.OpenApi.Schema.Generator++import Control.Lens.Operators+import Data.Aeson+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import "unordered-containers" Data.HashSet (HashSet)+import qualified "unordered-containers" Data.HashSet as HashSet+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.Proxy+import Data.Proxy+import Data.Set (Set)+import qualified Data.Text as T+import qualified Data.Text.Lazy 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++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]))+ 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_ ?~ 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_ ?~ 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_ ?~ 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_ ?~ OpenApiObject+ & properties .~ [("propE", boolSchema)]+ & required .~ ["propE"]
+ test/Data/OpenApi/Schema/ValidationSpec.hs view
@@ -0,0 +1,307 @@+{-# 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+import Data.Aeson.Types+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import "unordered-containers" Data.HashSet (HashSet)+import qualified "unordered-containers" Data.HashSet as HashSet+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.Proxy+import Data.Set (Set)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Version (Version)+import Data.Word+import GHC.Generics++import Data.OpenApi+import Data.OpenApi.Declare++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Instances ()++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+ [ T.pack "personName" .= toJSON name+ , T.pack "personPhone" .= toJSON phone+ , T.pack "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_ ?~ 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+-- ========================================================================++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) ]
+ test/Data/OpenApi/SchemaSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module Data.OpenApi.SchemaSpec where++import Prelude ()+import Prelude.Compat++import Control.Lens ((^.))+import Data.Aeson (Value)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import Data.Proxy+import Data.Set (Set)+import qualified Data.Text as Text++import Data.OpenApi+import Data.OpenApi.Declare++import Data.OpenApi.CommonTestTypes+import SpecCommon+import Test.Hspec++import qualified Data.HashMap.Strict as HM+import Data.Time.LocalTime++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++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 "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON+ context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'+ context "Sum types" $ do+ context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON+ context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON+ context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON+ context "UnsignedInts" $ checkToSchema (Proxy :: Proxy UnsignedInts) unsignedIntsSchemaJSON+ context "Schema name" $ do+ context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)+ context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))+ context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)+ context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)+ describe "Generic Definitions" $ do+ context "Unit" $ checkDefs (Proxy :: Proxy Unit) []+ context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]+ context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]+ context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]+ context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]+ context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]+ context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]+ context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []+ describe "Inlining Schemas" $ do+ context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON+ context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON+ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON+ context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON+ context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON+ context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'+ describe "Bounded Enum key mapping" $ do+ context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON+ context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON++main :: IO ()+main = hspec spec
+ test/Data/OpenApiSpec.hs view
@@ -0,0 +1,946 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}+module Data.OpenApiSpec where++import Prelude ()+import Prelude.Compat++import Control.Lens++import Data.Aeson+import Data.Aeson.QQ.Simple+import Data.HashMap.Strict (HashMap)+import qualified Data.HashSet.InsOrd as InsOrdHS+import Data.Text (Text)++import Data.OpenApi+import SpecCommon+import Test.Hspec hiding (example)++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 "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON+ describe "Swagger Object" $ do+ context "Example with no paths" $ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON+ 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++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_ ?~ 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_ ?~ OpenApiString)+ & properties . at "status" ?~ Inline (mempty+ & description ?~ "Updated status of the pet"+ & type_ ?~ 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_ ?~ OpenApiString+ & format ?~ "email"++schemaPrimitiveExampleJSON :: Value+schemaPrimitiveExampleJSON = [aesonQQ|+{+ "type": "string",+ "format": "email"+}+|]++schemaSimpleModelExample :: Schema+schemaSimpleModelExample = mempty+ & type_ ?~ OpenApiObject+ & required .~ [ "name" ]+ & properties .~+ [ ("name", Inline (mempty & type_ ?~ OpenApiString))+ , ("address", Ref (Reference "Address"))+ , ("age", Inline $ mempty+ & minimum_ ?~ 0+ & type_ ?~ 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_ ?~ OpenApiObject+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ OpenApiString))++schemaModelDictExampleJSON :: Value+schemaModelDictExampleJSON = [aesonQQ|+{+ "type": "object",+ "additionalProperties": {+ "type": "string"+ }+}+|]++schemaAdditionalExample :: Schema+schemaAdditionalExample = mempty+ & type_ ?~ OpenApiObject+ & additionalProperties ?~ AdditionalPropertiesAllowed True++schemaAdditionalExampleJSON :: Value+schemaAdditionalExampleJSON = [aesonQQ|+{+ "type": "object",+ "additionalProperties": true+}+|]++schemaWithExampleExample :: Schema+schemaWithExampleExample = mempty+ & type_ ?~ OpenApiObject+ & properties .~+ [ ("id", Inline $ mempty+ & type_ ?~ OpenApiInteger+ & format ?~ "int64" )+ , ("name", Inline $ mempty+ & type_ ?~ 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_ ?~ OpenApiObject+ & properties .~+ [ ("id", Inline $ mempty+ & type_ ?~ OpenApiInteger+ & format ?~ "int64")+ , ("name", Inline (mempty & type_ ?~ OpenApiString)) ] )+ , ("Tag", mempty+ & type_ ?~ OpenApiObject+ & properties .~+ [ ("id", Inline $ mempty+ & type_ ?~ OpenApiInteger+ & format ?~ "int64")+ , ("name", Inline (mempty & type_ ?~ 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_ ?~ OpenApiInteger+ & format ?~ "int32" ))+ , ("limitParam", mempty+ & name .~ "limit"+ & description ?~ "max records to return"+ & required ?~ True+ & in_ .~ ParamQuery+ & schema ?~ Inline (mempty+ & type_ ?~ 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."+ }+}+|]++-- =======================================================================+-- Responses 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 })+ ]++oAuth2SecurityDefinitionsExample :: SecurityDefinitions+oAuth2SecurityDefinitionsExample =+ oAuth2SecurityDefinitionsWriteExample <>+ oAuth2SecurityDefinitionsReadExample++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"+ }+ }+ }+}+|]++-- =======================================================================+-- Swagger object+-- =======================================================================++emptyPathsFieldExample :: OpenApi+emptyPathsFieldExample = mempty++emptyPathsFieldExampleJSON :: Value+emptyPathsFieldExampleJSON = [aesonQQ|+{+ "openapi": "3.0.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_ ?~ OpenApiObject+ & example ?~ [aesonQQ|+ {+ "created": 100,+ "description": "get milk"+ } |]+ & description ?~ "This is some real Todo right here"+ & properties .~+ [ ("created", Inline $ mempty+ & type_ ?~ OpenApiInteger+ & format ?~ "int32")+ , ("description", Inline (mempty & type_ ?~ OpenApiString))])))+ & parameters .~+ [ Inline $ mempty+ & required ?~ True+ & name .~ "id"+ & description ?~ "TodoId param"+ & in_ .~ ParamPath+ & schema ?~ Inline (mempty+ & type_ ?~ OpenApiString ) ]+ & tags .~ InsOrdHS.fromList [ "todo" ] ))++swaggerExampleJSON :: Value+swaggerExampleJSON = [aesonQQ|+{+ "openapi": "3.0.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.0.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+ & type_ ?~ OpenApiObject+ & Data.OpenApi.allOf ?~ [+ Ref (Reference "Other")+ , Inline (mempty+ & type_ ?~ OpenApiObject+ & properties .~+ [ ("greet", Inline $ mempty+ & type_ ?~ OpenApiString) ])+ ]++compositionSchemaExampleJSON :: Value+compositionSchemaExampleJSON = [aesonQQ|+{+ "type": "object",+ "allOf": [+ {+ "$ref": "#/components/schemas/Other"+ },+ {+ "type": "object",+ "properties": {+ "greet": { "type": "string" }+ }+ }+ ]+}+|]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/SpecCommon.hs view
@@ -0,0 +1,30 @@+module SpecCommon where++import Data.Aeson+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Vector as Vector++import Test.Hspec++isSubJSON :: Value -> Value -> Bool+isSubJSON Null _ = True+isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i+ where+ i = HashMap.intersectionWith isSubJSON x y+isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)+isSubJSON x y = x == y++(<=>) :: (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
+ test/doctests.hs view
@@ -0,0 +1,12 @@+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ ["-package-db=/nix/store/vxcjnh0d9arx0pj8hz236lg32dk7lkkr-ghc-shell-for-openapi3-ghc-8.8.4-env/lib/ghc-8.8.4/package.conf.d"] ++ pkgs ++ module_sources