diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml new file mode 100644 index 00000000..d3b4c3ee --- /dev/null +++ b/.github/workflows/haskell-ci.yml @@ -0,0 +1,177 @@ +# This GitHub workflow config has been generated by a script via +# +# haskell-ci 'github' 'cabal.project' +# +# To regenerate the script (for example after adjusting tested-with) run +# +# haskell-ci regenerate +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.12 +# +# REGENDATA ("0.12",["github","cabal.project"]) +# +name: Haskell-CI +on: + - push + - pull_request +jobs: + linux: + name: Haskell-CI - Linux - ${{ matrix.compiler }} + runs-on: ubuntu-18.04 + container: + image: buildpack-deps:bionic + continue-on-error: ${{ matrix.allow-failure }} + strategy: + matrix: + include: + - compiler: ghc-9.0.1 + allow-failure: true + - compiler: ghc-8.10.4 + allow-failure: false + - compiler: ghc-8.8.4 + allow-failure: false + - compiler: ghc-8.6.5 + allow-failure: false + - compiler: ghc-8.4.4 + allow-failure: false + fail-fast: false + steps: + - name: apt + run: | + apt-get update + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common + apt-add-repository -y 'ppa:hvr/ghc' + apt-get update + apt-get install -y $CC cabal-install-3.4 + env: + CC: ${{ matrix.compiler }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> $GITHUB_ENV + echo "CABAL_DIR=$HOME/.cabal" >> $GITHUB_ENV + echo "CABAL_CONFIG=$HOME/.cabal/config" >> $GITHUB_ENV + HCDIR=$(echo "/opt/$CC" | sed 's/-/\//') + HCNAME=ghc + HC=$HCDIR/bin/$HCNAME + echo "HC=$HC" >> $GITHUB_ENV + echo "HCPKG=$HCDIR/bin/$HCNAME-pkg" >> $GITHUB_ENV + echo "HADDOCK=$HCDIR/bin/haddock" >> $GITHUB_ENV + echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> $GITHUB_ENV + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') + echo "HCNUMVER=$HCNUMVER" >> $GITHUB_ENV + echo "ARG_TESTS=--enable-tests" >> $GITHUB_ENV + echo "ARG_BENCH=--enable-benchmarks" >> $GITHUB_ENV + echo "HEADHACKAGE=false" >> $GITHUB_ENV + echo "ARG_COMPILER=--$HCNAME --with-compiler=$HC" >> $GITHUB_ENV + echo "GHCJSARITH=0" >> $GITHUB_ENV + env: + CC: ${{ matrix.compiler }} + - name: env + run: | + env + - name: write cabal config + run: | + mkdir -p $CABAL_DIR + cat >> $CABAL_CONFIG < cabal-plan.xz + echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - + xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan + rm -f cabal-plan.xz + chmod a+x $HOME/.cabal/bin/cabal-plan + cabal-plan --version + - name: checkout + uses: actions/checkout@v2 + with: + path: source + - name: initial cabal.project for sdist + run: | + touch cabal.project + echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project + cat cabal.project + - name: sdist + run: | + mkdir -p sdist + $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist + - name: unpack + run: | + mkdir -p unpacked + find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; + - name: generate cabal.project + run: | + PKGDIR_openapi3="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/openapi3-[0-9.]*')" + echo "PKGDIR_openapi3=${PKGDIR_openapi3}" >> $GITHUB_ENV + touch cabal.project + touch cabal.project.local + echo "packages: ${PKGDIR_openapi3}" >> cabal.project + echo "package openapi3" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project + cat >> cabal.project <> cabal.project.local + cat cabal.project + cat cabal.project.local + - name: dump install plan + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all + cabal-plan + - name: cache + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store + restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- + - name: install dependencies + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all + - name: build w/o tests + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: build + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + - name: cabal check + run: | + cd ${PKGDIR_openapi3} || false + ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + - name: unconstrained build + run: | + rm -f cabal.project.local + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 88db3dfb..00000000 --- a/.travis.yml +++ /dev/null @@ -1,149 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'openapi3.cabal' -# -# To regenerate the script (for example after adjusting tested-with) run -# -# haskell-ci regenerate -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.10.1 -# -version: ~> 1.0 -language: c -os: linux -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -branches: - only: - - master -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - - $HOME/.hlint -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -jobs: - include: - - compiler: ghc-8.10.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.8.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}} - os: linux -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - WITHCOMPILER="-w $HC" - - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap" - - set -o pipefail - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - | - echo "program-default-options" >> $CABALHOME/config - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ." >> cabal.project - - echo 'package openapi3' >> cabal.project - - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(openapi3)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_openapi3="$(find . -maxdepth 1 -type d -regex '.*/openapi3-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_openapi3}" >> cabal.project - - echo 'package openapi3' >> cabal.project - - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(openapi3)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building... - # this builds all libraries and executables (without tests/benchmarks) - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all - # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all - # cabal check... - - (cd ${PKGDIR_openapi3} && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - -# REGENDATA ("0.10.1",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","openapi3.cabal"]) -# EOF diff --git a/CHANGELOG.md b/CHANGELOG.md index 1479a8aa..25adef34 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +Unreleased +---------- + +3.1.0 +----- + +- Use `format: date-time` for `ToParamSchema ZonedTime` instance (see + [#20](https://github.com/biocad/openapi3/pull/20)). +- Support generating schema for any polymorphic types via `Typeable` (see + [#19](https://github.com/biocad/openapi3/pull/19)). +- Allow `hashable-1.3.1`, prettify doctests (see [#18](https://github.com/biocad/openapi3/pull/18)). + 3.0.2.0 ------- diff --git a/cabal.project b/cabal.project index b0a523c7..6c5f3cec 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,4 @@ packages: . tests: true + +allow-newer: http-media:base diff --git a/openapi3.cabal b/openapi3.cabal index 282bbf0f..484f5fe3 100644 --- a/openapi3.cabal +++ b/openapi3.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: openapi3 -version: 3.0.2.0 +version: 3.1.0 synopsis: OpenAPI 3.0 data model category: Web, Swagger, OpenApi @@ -25,8 +25,9 @@ extra-source-files: tested-with: GHC ==8.4.4 || ==8.6.5 - || ==8.8.3 - || ==8.10.1 + || ==8.8.4 + || ==8.10.4 + || ==9.0.1 custom-setup setup-depends: @@ -57,10 +58,10 @@ library -- GHC boot libraries build-depends: - base >=4.11.1.0 && <4.15 + base >=4.11.1.0 && <4.16 , bytestring >=0.10.8.2 && <0.11 , containers >=0.5.11.0 && <0.7 - , template-haskell >=2.13.0.0 && <2.17 + , template-haskell >=2.13.0.0 && <2.18 , time >=1.8.0.2 && <1.10 , transformers >=0.5.5.0 && <0.6 @@ -76,9 +77,7 @@ library -- 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 - -- <1.3.1 is a temporary measure, until we fix doctests not to depend on key order - -- see https://github.com/haskell/aeson/issues/837 - , hashable >=1.2.7.0 && <1.3.1 + , 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 && <5.1 @@ -120,14 +119,14 @@ test-suite spec -- test-suite only dependencies build-depends: - hspec >=2.5.5 && <2.8 + hspec >=2.5.5 && <2.9 , 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 + hspec-discover:hspec-discover >=2.5.5 && <2.9 other-modules: SpecCommon diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index bd5e361b..10d9445f 100644 --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -9,127 +9,128 @@ -- 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 +module Data.OpenApi + ( -- * How to use this library + -- $howto - -- ** @'Monoid'@ instances - -- $monoids + -- ** @'Monoid'@ instances + -- $monoids - -- ** Lenses and prisms - -- $lens + -- ** Lenses and prisms + -- $lens - -- ** Schema specification - -- $schema + -- ** Schema specification + -- $schema - -- ** Manipulation - -- $manipulation + -- ** Manipulation + -- $manipulation - -- ** Validation - -- $validation + -- ** 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, + -- * 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(..), + -- * Swagger specification + OpenApi (..), + Server (..), + ServerVariable (..), + Components (..), - -- ** Info types - Info(..), - Contact(..), - License(..), + -- ** Info types + Info (..), + Contact (..), + License (..), - -- ** PathItem - PathItem(..), + -- ** PathItem + PathItem (..), - -- ** Operations - Operation(..), - Tag(..), - TagName, + -- ** Operations + Operation (..), + Tag (..), + TagName, - -- ** Types and formats - OpenApiType(..), - Format, - Definitions, - Style(..), + -- ** Types and formats + OpenApiType (..), + Format, + Definitions, + Style (..), - -- ** Parameters - Param(..), - ParamLocation(..), - ParamName, - Header(..), - HeaderName, - Example(..), - RequestBody(..), - MediaTypeObject(..), - Encoding(..), + -- ** Parameters + Param (..), + ParamLocation (..), + ParamName, + Header (..), + HeaderName, + Example (..), + RequestBody (..), + MediaTypeObject (..), + Encoding (..), - -- ** Schemas - Schema(..), - NamedSchema(..), - OpenApiItems(..), - Xml(..), - Pattern, - AdditionalProperties(..), - Discriminator(..), + -- ** Schemas + Schema (..), + NamedSchema (..), + OpenApiItems (..), + Xml (..), + Pattern, + AdditionalProperties (..), + Discriminator (..), - -- ** Responses - Responses(..), - Response(..), - HttpStatusCode, - Link(..), - Callback(..), + -- ** Responses + Responses (..), + Response (..), + HttpStatusCode, + Link (..), + Callback (..), - -- ** Security - SecurityScheme(..), - SecuritySchemeType(..), - HttpSchemeType(..), - SecurityDefinitions(..), - SecurityRequirement(..), + -- ** Security + SecurityScheme (..), + SecuritySchemeType (..), + HttpSchemeType (..), + SecurityDefinitions (..), + SecurityRequirement (..), - -- *** API key - ApiKeyParams(..), - ApiKeyLocation(..), + -- *** API key + ApiKeyParams (..), + ApiKeyLocation (..), - -- *** OAuth2 - OAuth2Flows(..), - OAuth2Flow(..), - OAuth2ImplicitFlow(..), - OAuth2PasswordFlow(..), - OAuth2ClientCredentialsFlow(..), - OAuth2AuthorizationCodeFlow(..), - AuthorizationURL, - TokenURL, + -- *** OAuth2 + OAuth2Flows (..), + OAuth2Flow (..), + OAuth2ImplicitFlow (..), + OAuth2PasswordFlow (..), + OAuth2ClientCredentialsFlow (..), + OAuth2AuthorizationCodeFlow (..), + AuthorizationURL, + TokenURL, - -- ** External documentation - ExternalDocs(..), + -- ** External documentation + ExternalDocs (..), - -- ** References - Reference(..), - Referenced(..), + -- ** References + Reference (..), + Referenced (..), - -- ** Miscellaneous - MimeList(..), - URL(..), -) where + -- ** Miscellaneous + MimeList (..), + URL (..), + SpecificationExtensions (..), + ) +where +import Data.OpenApi.Internal import Data.OpenApi.Lens -import Data.OpenApi.Optics () import Data.OpenApi.Operation +import Data.OpenApi.Optics () import Data.OpenApi.ParamSchema import Data.OpenApi.Schema import Data.OpenApi.Schema.Validation -import Data.OpenApi.Internal - -- $setup -- >>> import Control.Lens -- >>> import Data.Aeson @@ -137,6 +138,7 @@ import Data.OpenApi.Internal -- >>> import Data.Proxy -- >>> import GHC.Generics -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL +-- >>> import Data.OpenApi.Internal.Utils -- >>> :set -XDeriveGeneric -- >>> :set -XOverloadedStrings -- >>> :set -XOverloadedLists @@ -153,8 +155,16 @@ import Data.OpenApi.Internal -- -- 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":{}} +-- >>> BSL.putStrLn $ encodePretty (mempty :: OpenApi) +-- { +-- "components": {}, +-- "info": { +-- "title": "", +-- "version": "" +-- }, +-- "openapi": "3.0.0", +-- "paths": {} +-- } -- -- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty. -- That is because these properties are actually required ones. @@ -162,13 +172,20 @@ import Data.OpenApi.Internal -- 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"} +-- >>> BSL.putStrLn $ encodePretty mempty { _infoTitle = "Todo API", _infoVersion = "1.0" } +-- { +-- "title": "Todo API", +-- "version": "1.0" +-- } -- -- You can merge two values using @'mappend'@ or its infix version @('<>')@: -- --- >>> BSL.putStrLn $ encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } --- {"version":"1.0","title":"Todo API"} +-- >>> BSL.putStrLn $ encodePretty $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } +-- { +-- "title": "Todo API", +-- "version": "1.0" +-- } + -- -- This can be useful for combining specifications of endpoints into a whole API specification: -- @@ -194,14 +211,48 @@ import Data.OpenApi.Internal -- make it fairly simple to construct/modify any part of the specification: -- -- >>> :{ --- BSL.putStrLn $ encode $ (mempty :: OpenApi) +-- BSL.putStrLn $ encodePretty $ (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"}}}} +-- { +-- "components": { +-- "schemas": { +-- "User": { +-- "type": "string" +-- } +-- } +-- }, +-- "info": { +-- "title": "", +-- "version": "" +-- }, +-- "openapi": "3.0.0", +-- "paths": { +-- "/user": { +-- "get": { +-- "responses": { +-- "200": { +-- "content": { +-- "application/json": { +-- "schema": { +-- "$ref": "#/components/schemas/User" +-- } +-- } +-- }, +-- "description": "OK" +-- }, +-- "404": { +-- "description": "User info not found" +-- } +-- } +-- } +-- } +-- } +-- } -- -- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@ -- which produces @application/json@ output. It should respond with code @200@ and body specified @@ -213,23 +264,34 @@ import Data.OpenApi.Internal -- 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 $ encodePretty $ (mempty :: Response) & description .~ "No content" +-- { +-- "description": "No content" +-- } -- >>> :{ --- BSL.putStrLn $ encode $ (mempty :: Schema) +-- BSL.putStrLn $ encodePretty $ (mempty :: Schema) -- & type_ ?~ OpenApiBoolean -- & description ?~ "To be or not to be" -- :} --- {"type":"boolean","description":"To be or not to be"} +-- { +-- "description": "To be or not to be", +-- "type": "boolean" +-- } -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@ -- have direct access to it via @'at' code@. Example: -- -- >>> :{ --- BSL.putStrLn $ encode $ (mempty :: Operation) +-- BSL.putStrLn $ encodePretty $ (mempty :: Operation) -- & at 404 ?~ "Not found" -- :} --- {"responses":{"404":{"description":"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. @@ -276,10 +338,27 @@ import Data.OpenApi.Internal -- >>> 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"}}} +-- >>> BSL.putStrLn $ encodePretty (Person "David" 28) +-- { +-- "age": 28, +-- "name": "David" +-- } +-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Person) +-- { +-- "properties": { +-- "age": { +-- "type": "integer" +-- }, +-- "name": { +-- "type": "string" +-- } +-- }, +-- "required": [ +-- "name", +-- "age" +-- ], +-- "type": "object" +-- } -- -- This package implements 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 @@ -290,8 +369,50 @@ import Data.OpenApi.Internal -- >>> 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"} +-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Error) +-- { +-- "oneOf": [ +-- { +-- "properties": { +-- "tag": { +-- "enum": [ +-- "ErrorNoUser" +-- ], +-- "type": "string" +-- }, +-- "userId": { +-- "maximum": 9223372036854775807, +-- "minimum": -9223372036854775808, +-- "type": "integer" +-- } +-- }, +-- "required": [ +-- "userId", +-- "tag" +-- ], +-- "type": "object" +-- }, +-- { +-- "properties": { +-- "requiredPermission": { +-- "type": "string" +-- }, +-- "tag": { +-- "enum": [ +-- "ErrorAccessDenied" +-- ], +-- "type": "string" +-- } +-- }, +-- "required": [ +-- "requiredPermission", +-- "tag" +-- ], +-- "type": "object" +-- } +-- ], +-- "type": "object" +-- } -- $manipulation -- Sometimes you have to work with an imported or generated @'Swagger'@. diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 4fab42f9..87cc06b0 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -13,53 +13,72 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Data.OpenApi.Internal where -import Prelude () -import Prelude.Compat +module Data.OpenApi.Internal where -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 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 qualified Data.HashMap.Strict as HashMap +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.HashSet.InsOrd (InsOrdHashSet) +import Data.Hashable (Hashable (..)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.Monoid (Monoid (..)) +import Data.OpenApi.Internal.AesonUtils + ( AesonDefaultValue (..), + HasSwaggerAesonOptions (..), + mkSwaggerAesonOptions, + saoAdditionalPairs, + saoSubObject, + sopSwaggerGenericParseJSON, + sopSwaggerGenericToEncoding, + sopSwaggerGenericToEncodingWithOpts, + sopSwaggerGenericToJSON, + sopSwaggerGenericToJSONWithOpts, + ) import Data.OpenApi.Internal.Utils -import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding) +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 Generics.SOP.TH (deriveGeneric) +import Network.HTTP.Media + ( MediaType, + mainType, + parameters, + parseAccept, + subType, + (//), + (/:), + ) +import Network.Socket (HostName, PortNumber) +import Prelude.Compat +import Text.Read (readMaybe) +import Prelude () -- $setup -- >>> :seti -XDataKinds -- >>> import Data.Aeson +-- >>> import Data.ByteString.Lazy.Char8 as BSL +-- >>> import Data.OpenApi.Internal.Utils -- | A list of definitions that can be used in references. type Definitions = InsOrdHashMap Text @@ -68,85 +87,83 @@ type Definitions = InsOrdHashMap Text data OpenApi = OpenApi { -- | Provides metadata about the API. -- The metadata can be used by the clients if needed. - _openApiInfo :: Info - + _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] - + _openApiServers :: [Server], -- | The available paths and operations for the API. - , _openApiPaths :: InsOrdHashMap FilePath PathItem - + _openApiPaths :: InsOrdHashMap FilePath PathItem, -- | An element to hold various schemas for the specification. - , _openApiComponents :: Components - + _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] - + _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 - + _openApiTags :: InsOrdHashSet Tag, -- | Additional external documentation. - , _openApiExternalDocs :: Maybe ExternalDocs - } deriving (Eq, Show, Generic, Data, Typeable) + _openApiExternalDocs :: Maybe ExternalDocs, + -- | Specification Extensions + _openApiExtensions :: SpecificationExtensions + } + 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 - + _infoTitle :: Text, -- | A short description of the API. -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. - , _infoDescription :: Maybe Text - + _infoDescription :: Maybe Text, -- | A URL to the Terms of Service for the API. MUST be in the format of a URL. - , _infoTermsOfService :: Maybe Text - + _infoTermsOfService :: Maybe Text, -- | The contact information for the exposed API. - , _infoContact :: Maybe Contact - + _infoContact :: Maybe Contact, -- | The license information for the exposed API. - , _infoLicense :: Maybe License - + _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) + _infoVersion :: Text, + -- | Specification Extensions + _infoExtensions :: SpecificationExtensions + } + 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 - + _contactName :: Maybe Text, -- | The URL pointing to the contact information. - , _contactUrl :: Maybe URL - + _contactUrl :: Maybe URL, -- | The email address of the contact person/organization. - , _contactEmail :: Maybe Text - } deriving (Eq, Show, Generic, Data, Typeable) + _contactEmail :: Maybe Text, + -- | Specification Extensions + _contactExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) -- | License information for the exposed API. data License = License { -- | The license name used for the API. - _licenseName :: Text - + _licenseName :: Text, -- | A URL to the license used for the API. - , _licenseUrl :: Maybe URL - } deriving (Eq, Show, Generic, Data, Typeable) + _licenseUrl :: Maybe URL, + -- | Specification Extensions + _licenseExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance IsString License where - fromString s = License (fromString s) Nothing + fromString s = License (fromString s) Nothing mempty -- | An object representing a Server. data Server = Server @@ -154,50 +171,54 @@ data Server = Server -- 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 - + _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 - + _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) + _serverVariables :: InsOrdHashMap Text ServerVariable, + -- | Specification Extensions + _serverExtensions :: SpecificationExtensions + } + 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 + _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 - + _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) + _serverVariableDescription :: Maybe Text, + -- | Specification Extensions + _serverVariableExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance IsString Server where - fromString s = Server (fromString s) Nothing mempty + fromString s = Server (fromString s) Nothing mempty 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) + { _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. @@ -205,110 +226,94 @@ data Components = Components -- 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 - + _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 - + _pathItemDescription :: Maybe Text, -- | A definition of a GET operation on this path. - , _pathItemGet :: Maybe Operation - + _pathItemGet :: Maybe Operation, -- | A definition of a PUT operation on this path. - , _pathItemPut :: Maybe Operation - + _pathItemPut :: Maybe Operation, -- | A definition of a POST operation on this path. - , _pathItemPost :: Maybe Operation - + _pathItemPost :: Maybe Operation, -- | A definition of a DELETE operation on this path. - , _pathItemDelete :: Maybe Operation - + _pathItemDelete :: Maybe Operation, -- | A definition of a OPTIONS operation on this path. - , _pathItemOptions :: Maybe Operation - + _pathItemOptions :: Maybe Operation, -- | A definition of a HEAD operation on this path. - , _pathItemHead :: Maybe Operation - + _pathItemHead :: Maybe Operation, -- | A definition of a PATCH operation on this path. - , _pathItemPatch :: Maybe Operation - + _pathItemPatch :: Maybe Operation, -- | A definition of a TRACE operation on this path. - , _pathItemTrace :: Maybe Operation - + _pathItemTrace :: Maybe Operation, -- | An alternative server array to service all operations in this path. - , _pathItemServers :: [Server] - + _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) + _pathItemParameters :: [Referenced Param], + -- | Specification Extensions + _pathItemExtensions :: SpecificationExtensions + } + 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 - + _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 - + _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 - + _operationDescription :: Maybe Text, -- | Additional external documentation for this operation. - , _operationExternalDocs :: Maybe ExternalDocs - + _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 - + _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] - + _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) - + _operationRequestBody :: Maybe (Referenced RequestBody), -- | The list of possible responses as they are returned from executing this operation. - , _operationResponses :: Responses - + _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) - + _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 - + _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] - + _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) + _operationServers :: [Server], + -- | Specification Extensions + _operationExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) -- This instance should be in @http-media@. instance Data MediaType where @@ -321,6 +326,7 @@ instance Data MediaType where dataTypeOf _ = mediaTypeData mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix + mediaTypeData = mkDataType "MediaType" [mediaTypeConstr] instance Hashable MediaType where @@ -330,59 +336,60 @@ instance Hashable MediaType where 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 - + _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 - + _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) + _requestBodyRequired :: Maybe Bool, + -- | Specification Extensions + _requestBodyExtensions :: SpecificationExtensions + } + 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) - + { _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 - + _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) - + _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) + _mediaTypeObjectEncoding :: InsOrdHashMap Text Encoding, + -- | Specification Extensions + _mediaTypeObjectExtensions :: SpecificationExtensions + } + 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). + = -- | Path-style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + StyleMatrix + | -- | Label style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + StyleLabel + | -- | Form style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). -- This option replaces @collectionFormat@ with a @csv@ (when @explode@ is false) or @multi@ -- (when explode is true) value from OpenAPI 2.0. - | StyleSimple - -- ^ Simple style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + StyleForm + | -- | Simple style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). -- This option replaces @collectionFormat@ with a @csv@ value from OpenAPI 2.0. - | StyleSpaceDelimited - -- ^ Space separated array values. + StyleSimple + | -- | Space separated array values. -- This option replaces @collectionFormat@ equal to @ssv@ from OpenAPI 2.0. - | StylePipeDelimited - -- ^ Pipe separated array values. + StyleSpaceDelimited + | -- | 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. + StylePipeDelimited + | -- | Provides a simple way of rendering nested objects using form parameters. + StyleDeepObject deriving (Eq, Show, Generic, Data, Typeable) data Encoding = Encoding @@ -393,21 +400,18 @@ data Encoding = Encoding -- 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 - + _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) - + _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 - + _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. @@ -415,17 +419,19 @@ data Encoding = Encoding -- 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 - + _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) + _encodingAllowReserved :: Maybe Bool, + -- | Specification Extensions + _encodingExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) -newtype MimeList = MimeList { getMimeList :: [MediaType] } +newtype MimeList = MimeList {getMimeList :: [MediaType]} deriving (Eq, Show, Semigroup, Monoid, Typeable) mimeListConstr :: Constr @@ -446,52 +452,42 @@ instance Data MimeList where data Param = Param { -- | The name of the parameter. -- Parameter names are case sensitive. - _paramName :: Text - + _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 - + _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 - + _paramRequired :: Maybe Bool, -- | Specifies that a parameter is deprecated and SHOULD be transitioned out of usage. -- Default value is @false@. - , _paramDeprecated :: Maybe Bool - + _paramDeprecated :: Maybe Bool, -- | The location of the parameter. - , _paramIn :: ParamLocation - + _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 - + _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 - + _paramAllowReserved :: Maybe Bool, -- | Parameter schema. - , _paramSchema :: Maybe (Referenced 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 - + _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 - + _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. @@ -499,41 +495,40 @@ data Param = Param -- 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 - + _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) - + _paramExamples :: InsOrdHashMap Text (Referenced Example) -- TODO -- _paramContent :: InsOrdHashMap MediaType MediaTypeObject -- should be singleton. mutually exclusive with _paramSchema. - } deriving (Eq, Show, Generic, Data, Typeable) + } + deriving (Eq, Show, Generic, Data, Typeable) data Example = Example { -- | Short description for the example. - _exampleSummary :: Maybe Text - + _exampleSummary :: Maybe Text, -- | Long description for the example. -- CommonMark syntax MAY be used for rich text representation. - , _exampleDescription :: Maybe Text - + _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 - + _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) + _exampleExternalValue :: Maybe URL, + -- | Specification Extensions + _exampleExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Typeable, Data) data ExpressionOrValue = Expression Text @@ -548,28 +543,26 @@ data Link = Link -- 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 - + _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 - + _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 - + _linkParameters :: InsOrdHashMap Text ExpressionOrValue, -- | A literal value or @{expression}@ to use as a request body when calling the target operation. - , _linkRequestBody :: Maybe ExpressionOrValue - + _linkRequestBody :: Maybe ExpressionOrValue, -- | A description of the link. - , _linkDescription :: Maybe Text - + _linkDescription :: Maybe Text, -- | A server object to be used by the target operation. - , _linkServer :: Maybe Server - } deriving (Eq, Show, Generic, Typeable, Data) + _linkServer :: Maybe Server, + -- | Specification Extensions + _linkExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'OpenApiArray'@ schemas. -- @@ -580,32 +573,32 @@ data Link = Link -- -- @'OpenApiItemsArray'@ should be used to specify tuple @'Schema'@s. data OpenApiItems where - OpenApiItemsObject :: Referenced Schema -> OpenApiItems - OpenApiItemsArray :: [Referenced Schema] -> OpenApiItems + 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 + 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. + | -- | 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 + ParamPath + | -- | Used to pass a specific cookie value to the API. + ParamCookie deriving (Eq, Show, Generic, Data, Typeable) type Format = Text @@ -613,70 +606,69 @@ 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, + { _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) + _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, + -- | Specification Extensions + _schemaExtensions :: SpecificationExtensions + } + 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 - + _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) + _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) + { _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. @@ -684,27 +676,26 @@ data Xml = Xml -- 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 - + _xmlName :: Maybe Text, -- | The URL of the namespace definition. -- Value SHOULD be in the form of a URL. - , _xmlNamespace :: Maybe Text - + _xmlNamespace :: Maybe Text, -- | The prefix to be used for the name. - , _xmlPrefix :: Maybe Text - + _xmlPrefix :: Maybe Text, -- | Declares whether the property definition translates to an attribute instead of an element. -- Default value is @False@. - , _xmlAttribute :: Maybe Bool - + _xmlAttribute :: Maybe Bool, -- | MAY be used only for an array definition. -- Signifies whether the array is wrapped -- (for example, @\\\\@) -- or unwrapped (@\\@). -- Default value is @False@. -- The definition takes effect only when defined alongside type being array (outside the items). - , _xmlWrapped :: Maybe Bool - } deriving (Eq, Show, Generic, Data, Typeable) + _xmlWrapped :: Maybe Bool, + -- | Specification Extensions + _xmlExtensions :: SpecificationExtensions + } + 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. @@ -714,12 +705,14 @@ data Xml = Xml 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) - + _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) + _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response), + -- | Specification Extensions + _responsesExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) type HttpStatusCode = Int @@ -727,25 +720,25 @@ type HttpStatusCode = Int data Response = Response { -- | A short description of the response. -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation. - _responseDescription :: Text - + _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 - + _responseContent :: InsOrdHashMap MediaType MediaTypeObject, -- | Maps a header name to its definition. - , _responseHeaders :: InsOrdHashMap HeaderName (Referenced Header) - + _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) + _responseLinks :: InsOrdHashMap Text (Referenced Link), + -- | Specification Extensions + _responseExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance IsString Response where - fromString s = Response (fromString s) mempty mempty mempty + fromString s = Response (fromString s) mempty 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 @@ -762,17 +755,16 @@ type HeaderName = Text -- 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) + _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 @@ -783,11 +775,11 @@ data ApiKeyLocation data ApiKeyParams = ApiKeyParams { -- | The name of the header or query parameter to be used. - _apiKeyName :: Text - + _apiKeyName :: Text, -- | The location of the API key. - , _apiKeyIn :: ApiKeyLocation - } deriving (Eq, Show, Generic, Data, Typeable) + _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 @@ -795,48 +787,47 @@ 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} +newtype OAuth2ImplicitFlow = OAuth2ImplicitFlow {_oAuth2ImplicitFlowAuthorizationUrl :: AuthorizationURL} deriving (Eq, Show, Generic, Data, Typeable) -newtype OAuth2PasswordFlow - = OAuth2PasswordFlow {_oAuth2PasswordFlowTokenUrl :: TokenURL} +newtype OAuth2PasswordFlow = OAuth2PasswordFlow {_oAuth2PasswordFlowTokenUrl :: TokenURL} deriving (Eq, Show, Generic, Data, Typeable) -newtype OAuth2ClientCredentialsFlow - = OAuth2ClientCredentialsFlow {_oAuth2ClientCredentialsFlowTokenUrl :: TokenURL} +newtype OAuth2ClientCredentialsFlow = OAuth2ClientCredentialsFlow {_oAuth2ClientCredentialsFlowTokenUrl :: TokenURL} deriving (Eq, Show, Generic, Data, Typeable) data OAuth2AuthorizationCodeFlow = OAuth2AuthorizationCodeFlow - { _oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL - , _oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL - } deriving (Eq, Show, Generic, Data, Typeable) + { _oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL, + _oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL + } + deriving (Eq, Show, Generic, Data, Typeable) data OAuth2Flow p = OAuth2Flow - { _oAuth2Params :: p - + { _oAuth2Params :: p, -- | The URL to be used for obtaining refresh tokens. - , _oAath2RefreshUrl :: Maybe URL - + _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) + _oAuth2Scopes :: InsOrdHashMap Text Text, + -- | Specification Extensions + _oAuth2Extensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) data OAuth2Flows = OAuth2Flows { -- | Configuration for the OAuth Implicit flow - _oAuth2FlowsImplicit :: Maybe (OAuth2Flow OAuth2ImplicitFlow) - + _oAuth2FlowsImplicit :: Maybe (OAuth2Flow OAuth2ImplicitFlow), -- | Configuration for the OAuth Resource Owner Password flow - , _oAuth2FlowsPassword :: Maybe (OAuth2Flow OAuth2PasswordFlow) - + _oAuth2FlowsPassword :: Maybe (OAuth2Flow OAuth2PasswordFlow), -- | Configuration for the OAuth Client Credentials flow - , _oAuth2FlowsClientCredentials :: Maybe (OAuth2Flow OAuth2ClientCredentialsFlow) - + _oAuth2FlowsClientCredentials :: Maybe (OAuth2Flow OAuth2ClientCredentialsFlow), -- | Configuration for the OAuth Authorization Code flow - , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow) - } deriving (Eq, Show, Generic, Data, Typeable) + _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow), + -- | Specification Extensions + _oAuth2FlowsExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) type BearerFormat = Text @@ -848,21 +839,37 @@ data HttpSchemeType -- | -- --- >>> encode (SecuritySchemeHttp (HttpSchemeBearer Nothing)) --- "{\"scheme\":\"bearer\",\"type\":\"http\"}" --- --- >>> encode (SecuritySchemeHttp (HttpSchemeBearer (Just "jwt"))) --- "{\"scheme\":\"bearer\",\"type\":\"http\",\"bearerFormat\":\"jwt\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer Nothing)) +-- { +-- "scheme": "bearer", +-- "type": "http" +-- } -- --- >>> encode (SecuritySchemeHttp HttpSchemeBasic) --- "{\"scheme\":\"basic\",\"type\":\"http\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer (Just "jwt"))) +-- { +-- "bearerFormat": "jwt", +-- "scheme": "bearer", +-- "type": "http" +-- } -- --- >>> encode (SecuritySchemeHttp (HttpSchemeCustom "CANARY")) --- "{\"scheme\":\"CANARY\",\"type\":\"http\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp HttpSchemeBasic) +-- { +-- "scheme": "basic", +-- "type": "http" +-- } -- --- >>> encode (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie)) --- "{\"in\":\"cookie\",\"name\":\"id\",\"type\":\"apiKey\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeCustom "CANARY")) +-- { +-- "scheme": "CANARY", +-- "type": "http" +-- } -- +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie)) +-- { +-- "in": "cookie", +-- "name": "id", +-- "type": "apiKey" +-- } data SecuritySchemeType = SecuritySchemeHttp HttpSchemeType | SecuritySchemeApiKey ApiKeyParams @@ -872,11 +879,13 @@ data SecuritySchemeType data SecurityScheme = SecurityScheme { -- | The type of the security scheme. - _securitySchemeType :: SecuritySchemeType - + _securitySchemeType :: SecuritySchemeType, -- | A short description for security scheme. - , _securitySchemeDescription :: Maybe Text - } deriving (Eq, Show, Generic, Data, Typeable) + _securitySchemeDescription :: Maybe Text, + -- | Specification Extensions + _securitySchemeExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) newtype SecurityDefinitions = SecurityDefinitions (Definitions SecurityScheme) @@ -887,7 +896,8 @@ newtype SecurityDefinitions -- (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) + } + deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable) -- | Tag name. type TagName = Text @@ -896,36 +906,39 @@ type TagName = Text -- It is not mandatory to have a @Tag@ per tag used there. data Tag = Tag { -- | The name of the tag. - _tagName :: TagName - + _tagName :: TagName, -- | A short description for the tag. -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. - , _tagDescription :: Maybe Text - + _tagDescription :: Maybe Text, -- | Additional external documentation for this tag. - , _tagExternalDocs :: Maybe ExternalDocs - } deriving (Eq, Ord, Show, Generic, Data, Typeable) + _tagExternalDocs :: Maybe ExternalDocs, + -- | Specification Extensions + _tagExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance Hashable Tag instance IsString Tag where - fromString s = Tag (fromString s) Nothing Nothing + fromString s = Tag (fromString s) Nothing Nothing mempty -- | 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 - + _externalDocsDescription :: Maybe Text, -- | The URL for the target documentation. - , _externalDocsUrl :: URL - } deriving (Eq, Ord, Show, Generic, Data, Typeable) + _externalDocsUrl :: URL, + -- | Specification Extensions + _externalDocsExtensions :: SpecificationExtensions + } + deriving (Eq, 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 } +newtype Reference = Reference {getReference :: Text} deriving (Eq, Show, Data, Typeable) data Referenced a @@ -936,13 +949,16 @@ data Referenced a instance IsString a => IsString (Referenced a) where fromString = Inline . fromString -newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable) +newtype URL = URL {getUrl :: Text} deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable, AesonDefaultValue) data AdditionalProperties = AdditionalPropertiesAllowed Bool | AdditionalPropertiesSchema (Referenced Schema) deriving (Eq, Show, Data, Typeable) +newtype SpecificationExtensions = SpecificationExtensions {getSpecificationExtensions :: Definitions Value} + deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid, AesonDefaultValue) + ------------------------------------------------------------------------------- -- Generic instances ------------------------------------------------------------------------------- @@ -965,6 +981,13 @@ deriveGeneric ''OpenApi deriveGeneric ''Example deriveGeneric ''Encoding deriveGeneric ''Link +deriveGeneric ''Info +deriveGeneric ''Contact +deriveGeneric ''License +deriveGeneric ''ServerVariable +deriveGeneric ''Tag +deriveGeneric ''Xml +deriveGeneric ''ExternalDocs -- ======================================================================= -- Monoid instances @@ -972,115 +995,131 @@ deriveGeneric ''Link 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 } + 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 - } + l <> r = + OAuth2Flows + { _oAuth2FlowsImplicit = _oAuth2FlowsImplicit l <> _oAuth2FlowsImplicit r, + _oAuth2FlowsPassword = _oAuth2FlowsPassword l <> _oAuth2FlowsPassword r, + _oAuth2FlowsClientCredentials = _oAuth2FlowsClientCredentials l <> _oAuth2FlowsClientCredentials r, + _oAuth2FlowsAuthorizationCode = _oAuth2FlowsAuthorizationCode l <> _oAuth2FlowsAuthorizationCode r, + _oAuth2FlowsExtensions = _oAuth2FlowsExtensions l <> _oAuth2FlowsExtensions 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) + SecurityScheme (SecuritySchemeOAuth2 lFlows) lDesc lExt + <> SecurityScheme (SecuritySchemeOAuth2 rFlows) rDesc rExt = + SecurityScheme (SecuritySchemeOAuth2 $ lFlows <> rFlows) (swaggerMappend lDesc rDesc) (lExt <> rExt) l <> _ = l instance Semigroup SecurityDefinitions where (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) = - SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2 + SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2 instance Monoid SecurityDefinitions where mempty = SecurityDefinitions InsOrdHashMap.empty @@ -1088,6 +1127,7 @@ instance Monoid SecurityDefinitions where instance Semigroup RequestBody where (<>) = genericMappend + instance Monoid RequestBody where mempty = genericMempty mappend = (<>) @@ -1097,17 +1137,27 @@ instance Monoid RequestBody where -- ======================================================================= 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 @@ -1140,33 +1190,12 @@ instance ToJSON OpenApiType where 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") @@ -1195,30 +1224,12 @@ instance FromJSON OpenApiType where 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") @@ -1256,47 +1267,74 @@ instance ToJSON OAuth2Flows where instance ToJSON SecuritySchemeType where toJSON (SecuritySchemeHttp ty) = case ty of HttpSchemeBearer mFmt -> - object $ [ "type" .= ("http" :: Text) - , "scheme" .= ("bearer" :: Text) - ] <> maybe [] (\t -> ["bearerFormat" .= t]) mFmt + object $ + [ "type" .= ("http" :: Text), + "scheme" .= ("bearer" :: Text) + ] + <> maybe [] (\t -> ["bearerFormat" .= t]) mFmt HttpSchemeBasic -> - object [ "type" .= ("http" :: Text) - , "scheme" .= ("basic" :: Text) - ] + object + [ "type" .= ("http" :: Text), + "scheme" .= ("basic" :: Text) + ] HttpSchemeCustom t -> - object [ "type" .= ("http" :: Text) - , "scheme" .= t - ] - toJSON (SecuritySchemeApiKey params) - = toJSON params - <+> object [ "type" .= ("apiKey" :: Text) ] - toJSON (SecuritySchemeOAuth2 params) = object - [ "type" .= ("oauth2" :: Text) - , "flows" .= toJSON params - ] - toJSON (SecuritySchemeOpenIdConnect url) = object - [ "type" .= ("openIdConnect" :: Text) - , "openIdConnectUrl" .= url - ] + object + [ "type" .= ("http" :: Text), + "scheme" .= t + ] + toJSON (SecuritySchemeApiKey params) = + toJSON params + <+> object ["type" .= ("apiKey" :: Text)] + toJSON (SecuritySchemeOAuth2 params) = + object + [ "type" .= ("oauth2" :: Text), + "flows" .= toJSON params + ] + toJSON (SecuritySchemeOpenIdConnect url) = + object + [ "type" .= ("openIdConnect" :: Text), + "openIdConnectUrl" .= url + ] instance ToJSON OpenApi where - toJSON a = sopSwaggerGenericToJSON a & - if InsOrdHashMap.null (_openApiPaths a) - then (<+> object ["paths" .= object []]) - else id + toJSON a = + sopSwaggerGenericToJSON a + & if InsOrdHashMap.null (_openApiPaths a) + then (<+> object ["paths" .= object []]) + else id + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Info where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Contact where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON License where + toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding instance ToJSON Server where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON ServerVariable where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityScheme where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding instance ToJSON Schema where - toJSON = sopSwaggerGenericToJSONWithOpts $ - mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items" + toJSON = + sopSwaggerGenericToJSONWithOpts $ + mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] + toEncoding = + sopSwaggerGenericToEncodingWithOpts $ + mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] instance ToJSON Header where toJSON = sopSwaggerGenericToJSON @@ -1305,17 +1343,21 @@ instance ToJSON Header where -- | As for nullary schema for 0-arity type constructors, see -- . -- --- >>> encode (OpenApiItemsArray []) --- "{\"example\":[],\"items\":{},\"maxItems\":0}" --- +-- >>> BSL.putStrLn $ encodePretty (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 ] + 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 @@ -1364,23 +1406,51 @@ instance ToJSON Link where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Tag where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Xml where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON ExternalDocs where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd instance ToJSON Reference where - toJSON (Reference ref) = object [ "$ref" .= ref ] + toJSON (Reference ref) = object ["$ref" .= ref] + toEncoding (Reference ref) = pairs ("$ref" .= ref) referencedToJSON :: ToJSON a => Text -> Referenced a -> Value -referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ] +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/" +referencedToEncoding :: ToJSON a => Text -> Referenced a -> JSON.Encoding +referencedToEncoding prefix (Ref (Reference ref)) = pairs ("$ref" .= (prefix <> ref)) +referencedToEncoding _ (Inline x) = toEncoding x + +instance ToJSON (Referenced Schema) where + toJSON = referencedToJSON "#/components/schemas/" + toEncoding = referencedToEncoding "#/components/schemas/" + +instance ToJSON (Referenced RequestBody) where + toJSON = referencedToJSON "#/components/requestBodies/" + toEncoding = referencedToEncoding "#/components/requestBodies/" + +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 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 @@ -1394,6 +1464,11 @@ instance ToJSON ExpressionOrValue where instance ToJSON Callback where toJSON (Callback ps) = toJSON ps +instance ToJSON SpecificationExtensions where + toJSON = toJSON . addExtPrefix . getSpecificationExtensions + where + addExtPrefix = InsOrdHashMap.mapKeys ("x-" <>) + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -1415,12 +1490,12 @@ instance FromJSON SecuritySchemeType where parseJSON js@(Object o) = do (t :: Text) <- o .: "type" case t of - "http" -> do - scheme <- o .: "scheme" - SecuritySchemeHttp <$> case scheme of - "bearer" -> HttpSchemeBearer <$> (o .:! "bearerFormat") - "basic" -> pure HttpSchemeBasic - t -> pure $ HttpSchemeCustom t + "http" -> do + scheme <- o .: "scheme" + SecuritySchemeHttp <$> case scheme of + "bearer" -> HttpSchemeBearer <$> (o .:! "bearerFormat") + "basic" -> pure HttpSchemeBasic + t -> pure $ HttpSchemeCustom t "apiKey" -> SecuritySchemeApiKey <$> parseJSON js "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows") "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl") @@ -1430,30 +1505,45 @@ instance FromJSON SecuritySchemeType where instance FromJSON OpenApi where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Info where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON Contact where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON License where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Server where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON ServerVariable 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 + 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 + | null obj = pure $ OpenApiItemsArray [] -- Nullary schema. + | otherwise = OpenApiItemsObject <$> parseJSON js + parseJSON js@(Array _) = OpenApiItemsArray <$> parseJSON js parseJSON _ = empty instance FromJSON Components where @@ -1466,11 +1556,24 @@ instance FromJSON Param where parseJSON = sopSwaggerGenericParseJSON instance FromJSON Responses where - parseJSON (Object o) = Responses - <$> o .:? "default" - <*> parseJSON (Object (HashMap.delete "default" o)) + parseJSON (Object o) = + Responses + <$> o .:? "default" + <*> parseJSON + ( Object + ( HashMap.filterWithKey (\k _ -> not $ isExt k) $ + HashMap.delete "default" o + ) + ) + <*> case HashMap.filterWithKey (\k _ -> isExt k) o of + exts + | HashMap.null exts -> pure (SpecificationExtensions mempty) + | otherwise -> parseJSON (Object exts) parseJSON _ = empty +isExt :: Text -> Bool +isExt = Text.isPrefixOf "x-" + instance FromJSON Example where parseJSON = sopSwaggerGenericParseJSON @@ -1498,6 +1601,15 @@ instance FromJSON Encoding where instance FromJSON Link where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Tag where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON Xml where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON ExternalDocs where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty @@ -1507,25 +1619,29 @@ referencedParseJSON prefix js@(Object o) = do ms <- o .:? "$ref" case ms of Nothing -> Inline <$> parseJSON js - Just s -> Ref <$> parseRef s + 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 + 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 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 (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 AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b @@ -1539,55 +1655,113 @@ instance FromJSON ExpressionOrValue where instance FromJSON Callback where parseJSON = fmap Callback . parseJSON +instance FromJSON SpecificationExtensions where + parseJSON = withObject "SpecificationExtensions" extFieldsParser + where + extFieldsParser = pure . SpecificationExtensions . InsOrdHashMap.fromList . catMaybes . filterExtFields + filterExtFields = fmap (\(k, v) -> fmap (\k' -> (k', v)) $ Text.stripPrefix "x-" k) . HashMap.toList + instance HasSwaggerAesonOptions Server where - swaggerAesonOptions _ = mkSwaggerAesonOptions "server" + swaggerAesonOptions _ = mkSwaggerAesonOptions "server" & saoSubObject .~ ["extensions"] + 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" + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject .~ ["params", "extensions"] + instance HasSwaggerAesonOptions OAuth2Flows where - swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Operation where - swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" + swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Param where swaggerAesonOptions _ = mkSwaggerAesonOptions "param" + instance HasSwaggerAesonOptions PathItem where - swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" + swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Response where - swaggerAesonOptions _ = mkSwaggerAesonOptions "response" + swaggerAesonOptions _ = mkSwaggerAesonOptions "response" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions RequestBody where - swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" + swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions MediaTypeObject where - swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" + swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Responses where - swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses" + swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject .~ ["responses", "extensions"] + instance HasSwaggerAesonOptions SecurityScheme where - swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type" + swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject .~ ["type", "extensions"] + instance HasSwaggerAesonOptions Schema where - swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" + swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject .~ ["paramSchema", "extensions"] + instance HasSwaggerAesonOptions OpenApi where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] + swaggerAesonOptions _ = + mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] + & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Example where - swaggerAesonOptions _ = mkSwaggerAesonOptions "example" + swaggerAesonOptions _ = mkSwaggerAesonOptions "example" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Encoding where - swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" + swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Link where - swaggerAesonOptions _ = mkSwaggerAesonOptions "link" + swaggerAesonOptions _ = mkSwaggerAesonOptions "link" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions Info where + swaggerAesonOptions _ = mkSwaggerAesonOptions "info" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions Contact where + swaggerAesonOptions _ = mkSwaggerAesonOptions "contact" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions License where + swaggerAesonOptions _ = mkSwaggerAesonOptions "license" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions ServerVariable where + swaggerAesonOptions _ = mkSwaggerAesonOptions "serverVariable" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions Tag where + swaggerAesonOptions _ = mkSwaggerAesonOptions "tag" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions Xml where + swaggerAesonOptions _ = mkSwaggerAesonOptions "xml" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions ExternalDocs where + swaggerAesonOptions _ = mkSwaggerAesonOptions "externalDocs" & saoSubObject .~ ["extensions"] 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 diff --git a/src/Data/OpenApi/Internal/AesonUtils.hs b/src/Data/OpenApi/Internal/AesonUtils.hs index 98e1ce06..5ee84b8e 100644 --- a/src/Data/OpenApi/Internal/AesonUtils.hs +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -11,6 +11,7 @@ module Data.OpenApi.Internal.AesonUtils ( sopSwaggerGenericToJSON, sopSwaggerGenericToEncoding, sopSwaggerGenericToJSONWithOpts, + sopSwaggerGenericToEncodingWithOpts, sopSwaggerGenericParseJSON, -- * Options HasSwaggerAesonOptions(..), @@ -48,13 +49,13 @@ import qualified Data.HashSet.InsOrd as InsOrdHS data SwaggerAesonOptions = SwaggerAesonOptions { _saoPrefix :: String , _saoAdditionalPairs :: [(Text, Value)] - , _saoSubObject :: Maybe String + , _saoSubObject :: [String] } mkSwaggerAesonOptions :: String -- ^ prefix -> SwaggerAesonOptions -mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing +mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] [] makeLenses ''SwaggerAesonOptions @@ -153,7 +154,7 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go 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 + | name' `elem` sub = case json of Object m -> HM.toList m ++ rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json @@ -226,7 +227,7 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go 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 = + | name' `elem` sub = -- Note: we might strip fields of outer structure. cons <$> (withDef $ parseJSON $ Object obj) <*> rest | otherwise = case def of @@ -267,6 +268,24 @@ sopSwaggerGenericToEncoding x = proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy +sopSwaggerGenericToEncodingWithOpts + :: forall a xs. + ( HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => SwaggerAesonOptions + -> a + -> Encoding +sopSwaggerGenericToEncodingWithOpts opts x = + let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) defs + in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps) + where + proxy = Proxy :: Proxy a + defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue + pairsToSeries :: [Pair] -> Series pairsToSeries = foldMap (\(k, v) -> (k .= v)) @@ -293,7 +312,7 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go 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 + | name' `elem` sub = case toJSON x of Object m -> pairsToSeries (HM.toList m) <> rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x) diff --git a/src/Data/OpenApi/Internal/ParamSchema.hs b/src/Data/OpenApi/Internal/ParamSchema.hs index ede6aa57..1699a0e4 100644 --- a/src/Data/OpenApi/Internal/ParamSchema.hs +++ b/src/Data/OpenApi/Internal/ParamSchema.hs @@ -15,58 +15,59 @@ {-# 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 qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Fixed (Fixed, HasResolution (..), Pico) import "unordered-containers" Data.HashSet (HashSet) +import Data.Int import Data.Monoid -import Data.Set (Set) +import Data.OpenApi.Internal +import Data.OpenApi.Lens +import Data.OpenApi.SchemaOptions +import Data.Proxy import Data.Scientific -import Data.Fixed (HasResolution(..), Fixed, Pico) +import Data.Set (Set) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time +import Data.UUID.Types (UUID) 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 GHC.Generics +import GHC.TypeLits (ErrorMessage (..), TypeError) +import Numeric.Natural.Compat (Natural) 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" +binarySchema = + mempty + & type_ ?~ OpenApiString + & format ?~ "binary" -- | Default schema for binary data (base64 encoded). byteSchema :: Schema -byteSchema = mempty - & type_ ?~ OpenApiString - & format ?~ "byte" +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" +passwordSchema = + mempty + & type_ ?~ OpenApiString + & format ?~ "password" -- | Convert a type into a plain @'Schema'@. -- @@ -112,8 +113,10 @@ passwordSchema = mempty class ToParamSchema a where -- | Convert a type into a plain parameter schema. -- - -- >>> encode $ toParamSchema (Proxy :: Proxy Integer) - -- "{\"type\":\"integer\"}" + -- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy Integer) + -- { + -- "type": "integer" + -- } toParamSchema :: Proxy a -> Schema default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema toParamSchema = genericToParamSchema defaultSchemaOptions @@ -128,14 +131,17 @@ instance ToParamSchema Integer where toParamSchema _ = mempty & type_ ?~ OpenApiInteger instance ToParamSchema Natural where - toParamSchema _ = mempty - & type_ ?~ OpenApiInteger - & minimum_ ?~ 0 - & exclusiveMinimum ?~ False + 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 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" @@ -143,8 +149,10 @@ instance ToParamSchema Int32 where instance ToParamSchema Int64 where toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64" -instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral -instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral + +instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral + instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word32 where @@ -155,42 +163,52 @@ instance ToParamSchema Word64 where -- | Default plain schema for @'Bounded'@, @'Integral'@ types. -- --- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8) --- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" +-- >>> BSL.putStrLn $ encodePretty $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8) +-- { +-- "maximum": 127, +-- "minimum": -128, +-- "type": "integer" +-- } toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema -toParamSchemaBoundedIntegral _ = mempty - & type_ ?~ OpenApiInteger - & minimum_ ?~ fromInteger (toInteger (minBound :: a)) - & maximum_ ?~ fromInteger (toInteger (maxBound :: a)) +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 + 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)) + toParamSchema _ = + mempty + & type_ ?~ OpenApiNumber + & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a)) instance ToParamSchema Double where - toParamSchema _ = mempty - & type_ ?~ OpenApiNumber - & format ?~ "double" + toParamSchema _ = + mempty + & type_ ?~ OpenApiNumber + & format ?~ "double" instance ToParamSchema Float where - toParamSchema _ = mempty - & type_ ?~ OpenApiNumber - & format ?~ "float" + toParamSchema _ = + mempty + & type_ ?~ OpenApiNumber + & format ?~ "float" timeParamSchema :: String -> Schema -timeParamSchema fmt = mempty - & type_ ?~ OpenApiString - & format ?~ T.pack fmt +timeParamSchema fmt = + mempty + & type_ ?~ OpenApiString + & format ?~ T.pack fmt -- | Format @"date"@ corresponds to @yyyy-mm-dd@ format. instance ToParamSchema Day where @@ -210,9 +228,9 @@ instance ToParamSchema LocalTime where -- | -- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format --- Just "yyyy-mm-ddThh:MM:ss+hhMM" +-- Just "date-time" instance ToParamSchema ZonedTime where - toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM" + toParamSchema _ = timeParamSchema "date-time" -- | -- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format @@ -230,69 +248,98 @@ instance ToParamSchema TL.Text where toParamSchema _ = toParamSchema (Proxy :: Proxy String) instance ToParamSchema Version where - toParamSchema _ = mempty - & type_ ?~ OpenApiString - & pattern ?~ "^\\d+(\\.\\d+)*$" + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & pattern ?~ "^\\d+(\\.\\d+)*$" instance ToParamSchema SetCookie where - toParamSchema _ = mempty - & type_ ?~ OpenApiString + toParamSchema _ = + mempty + & type_ ?~ OpenApiString type family ToParamSchemaByteStringError bs where - ToParamSchemaByteStringError bs = TypeError + 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." ) + :$$: '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 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 (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 (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)) + 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 + 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\":[\"_\"]}" +-- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy ()) +-- { +-- "enum": [ +-- "_" +-- ], +-- "type": "string" +-- } instance ToParamSchema () where - toParamSchema _ = mempty - & type_ ?~ OpenApiString - & enum_ ?~ ["_"] + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & enum_ ?~ ["_"] instance ToParamSchema UUID where - toParamSchema _ = mempty - & type_ ?~ OpenApiString - & format ?~ "uuid" + 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\"]}" +-- >>> BSL.putStrLn $ encodePretty $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color) +-- { +-- "enum": [ +-- "Red", +-- "Blue" +-- ], +-- "type": "string" +-- } genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty @@ -321,16 +368,18 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) 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 + 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) + addEnumValue x Nothing = Just [x] + addEnumValue x (Just xs) = Just (x : xs) data Proxy3 a b c = Proxy3 -- $setup -- >>> import Data.Aeson (encode) +-- >>> import Data.OpenApi.Internal.Utils diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 1ea3ead0..1964b5fd 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -19,61 +19,65 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For TypeErrors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -module Data.OpenApi.Internal.Schema where -import Prelude () -import Prelude.Compat +module Data.OpenApi.Internal.Schema where 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.Aeson + ( Object (..), + SumEncoding (..), + ToJSON (..), + ToJSONKey (..), + ToJSONKeyFunction (..), + Value (..), + ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Char import Data.Data (Data) +import Data.Data.Lens (template) +import Data.Fixed (Fixed, HasResolution, Pico) import Data.Foldable (traverse_) import Data.HashMap.Strict (HashMap) import 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 "unordered-containers" Data.HashSet (HashSet) +import qualified "unordered-containers" Data.HashSet as HashSet import Data.Int -import Data.IntSet (IntSet) import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.List (sort) import Data.List.NonEmpty.Compat (NonEmpty) import Data.Map (Map) import Data.Maybe (fromMaybe) +import Data.OpenApi.Declare +import Data.OpenApi.Internal +import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..)) +import Data.OpenApi.Internal.TypeShape +import Data.OpenApi.Lens hiding (name, schema) +import qualified Data.OpenApi.Lens as Swagger +import Data.OpenApi.SchemaOptions 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.UUID.Types as UUID 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 GHC.TypeLits (ErrorMessage (..), TypeError) +import Numeric.Natural.Compat (Natural) +import Prelude.Compat import Type.Reflection (Typeable, typeRep) - -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(..)) +import Prelude () unnamed :: Schema -> NamedSchema unnamed schema = NamedSchema Nothing schema @@ -134,19 +138,24 @@ rename name (NamedSchema _ schema) = NamedSchema name schema -- -- instance ToSchema Coord -- @ -class ToSchema a where +class Typeable a => ToSchema a where -- | Convert a type into an optionally named schema -- together with all used definitions. -- Note that the schema itself is included in definitions -- only if it is recursive (and thus needs its definition in scope). declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema - default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => - Proxy a -> Declare (Definitions Schema) NamedSchema + 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) + 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 @@ -156,13 +165,19 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema -- -- >>> toNamedSchema (Proxy :: Proxy String) ^. name -- Nothing --- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy String) ^. schema) --- {"type":"string"} +-- >>> BSL.putStrLn $ encodePretty (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"} +-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy Day) ^. schema) +-- { +-- "example": "2016-07-22", +-- "format": "date", +-- "type": "string" +-- } toNamedSchema :: ToSchema a => Proxy a -> NamedSchema toNamedSchema = undeclare . declareNamedSchema @@ -178,22 +193,35 @@ schemaName = _namedSchemaName . toNamedSchema -- | Convert a type into a schema. -- --- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Int8) --- {"maximum":127,"minimum":-128,"type":"integer"} +-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Int8) +-- { +-- "maximum": 127, +-- "minimum": -128, +-- "type": "integer" +-- } -- --- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy [Day]) --- {"items":{"$ref":"#/components/schemas/Day"},"type":"array"} +-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy [Day]) +-- { +-- "items": { +-- "$ref": "#/components/schemas/Day" +-- }, +-- "type": "array" +-- } toSchema :: ToSchema a => Proxy a -> Schema toSchema = _namedSchemaSchema . toNamedSchema -- | Convert a type into a referenced schema if possible. -- Only named schemas can be referenced, nameless schemas are inlined. -- --- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Integer) --- {"type":"integer"} +-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Integer) +-- { +-- "type": "integer" +-- } -- --- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Day) --- {"$ref":"#/components/schemas/Day"} +-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Day) +-- { +-- "$ref": "#/components/schemas/Day" +-- } toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema toSchemaRef = undeclare . declareSchemaRef @@ -235,9 +263,9 @@ 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 + 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) @@ -261,8 +289,15 @@ 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"} +-- >>> BSL.putStrLn $ encodePretty $ toInlinedSchema (Proxy :: Proxy [Day]) +-- { +-- "items": { +-- "example": "2016-07-22", +-- "format": "date", +-- "type": "string" +-- }, +-- "type": "array" +-- } -- -- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema -- when inlining recursive schemas. @@ -279,7 +314,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs nonRecursive name = case InsOrdHashMap.lookup name defs of Just schema -> name `notElem` execDeclare (usedNames schema) mempty - Nothing -> False + Nothing -> False usedNames schema = traverse_ schemaRefNames (schema ^.. template) @@ -295,19 +330,64 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs -- | 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 $ encodePretty $ sketchSchema "hello" +-- { +-- "example": "hello", +-- "type": "string" +-- } -- --- >>> BSL.putStrLn $ encode $ sketchSchema (1, 2, 3) --- {"example":[1,2,3],"items":{"type":"number"},"type":"array"} +-- >>> BSL.putStrLn $ encodePretty $ 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"} +-- >>> BSL.putStrLn $ encodePretty $ 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"}}} +-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (Person "Jack" 25) +-- { +-- "example": { +-- "age": 25, +-- "name": "Jack" +-- }, +-- "properties": { +-- "age": { +-- "type": "number" +-- }, +-- "name": { +-- "type": "string" +-- } +-- }, +-- "required": [ +-- "age", +-- "name" +-- ], +-- "type": "object" +-- } sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON where @@ -315,79 +395,200 @@ sketchSchema = sketch . toJSON sketch js@(Bool _) = go js sketch js = go js & example ?~ js - go Null = mempty & type_ ?~ OpenApiNull - go (Bool _) = mempty & type_ ?~ OpenApiBoolean + 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 + go (Array xs) = + mempty + & type_ ?~ OpenApiArray + & items ?~ case ischema of Just s -> OpenApiItemsObject (Inline s) - _ -> OpenApiItemsArray (map Inline ys) + _ -> 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) + (z : _) | allSame -> Just z + _ -> Nothing + go (Object o) = + mempty + & type_ ?~ OpenApiObject + & required .~ sort (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 $ encodePretty $ sketchStrictSchema "hello" +-- { +-- "enum": [ +-- "hello" +-- ], +-- "maxLength": 5, +-- "minLength": 5, +-- "pattern": "hello", +-- "type": "string" +-- } -- --- >>> 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 $ encodePretty $ sketchStrictSchema (1, 2, 3) +-- { +-- "enum": [ +-- [ +-- 1, +-- 2, +-- 3 +-- ] +-- ], +-- "items": [ +-- { +-- "enum": [ +-- 1 +-- ], +-- "maximum": 1, +-- "minimum": 1, +-- "multipleOf": 1, +-- "type": "number" +-- }, +-- { +-- "enum": [ +-- 2 +-- ], +-- "maximum": 2, +-- "minimum": 2, +-- "multipleOf": 2, +-- "type": "number" +-- }, +-- { +-- "enum": [ +-- 3 +-- ], +-- "maximum": 3, +-- "minimum": 3, +-- "multipleOf": 3, +-- "type": "number" +-- } +-- ], +-- "maxItems": 3, +-- "minItems": 3, +-- "type": "array", +-- "uniqueItems": true +-- } -- --- >>> 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]]} +-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema ("Jack", 25) +-- { +-- "enum": [ +-- [ +-- "Jack", +-- 25 +-- ] +-- ], +-- "items": [ +-- { +-- "enum": [ +-- "Jack" +-- ], +-- "maxLength": 4, +-- "minLength": 4, +-- "pattern": "Jack", +-- "type": "string" +-- }, +-- { +-- "enum": [ +-- 25 +-- ], +-- "maximum": 25, +-- "minimum": 25, +-- "multipleOf": 25, +-- "type": "number" +-- } +-- ], +-- "maxItems": 2, +-- "minItems": 2, +-- "type": "array", +-- "uniqueItems": true +-- } -- -- >>> 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"]}}} +-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (Person "Jack" 25) +-- { +-- "enum": [ +-- { +-- "age": 25, +-- "name": "Jack" +-- } +-- ], +-- "maxProperties": 2, +-- "minProperties": 2, +-- "properties": { +-- "age": { +-- "enum": [ +-- 25 +-- ], +-- "maximum": 25, +-- "minimum": 25, +-- "multipleOf": 25, +-- "type": "number" +-- }, +-- "name": { +-- "enum": [ +-- "Jack" +-- ], +-- "maxLength": 4, +-- "minLength": 4, +-- "pattern": "Jack", +-- "type": "string" +-- } +-- }, +-- "required": [ +-- "age", +-- "name" +-- ], +-- "type": "object" +-- } sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON where - go Null = mempty & type_ ?~ 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] + 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] + go js@(Object o) = + mempty + & type_ ?~ OpenApiObject + & required .~ sort names + & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) + & maxProperties ?~ fromIntegral (length names) + & minProperties ?~ fromIntegral (length names) + & enum_ ?~ [js] where names = HashMap.keys o @@ -397,78 +598,120 @@ class GToSchema (f :: * -> *) where instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where declareNamedSchema _ = do ref <- declareSchemaRef (Proxy :: Proxy a) - return $ unnamed $ mempty - & type_ ?~ OpenApiArray - & items ?~ OpenApiItemsObject ref + 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 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 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 '?' + 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 Scientific where declareNamedSchema = plain . paramSchemaToSchema -instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema -instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema -instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema +instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema a => ToSchema (Maybe a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where -- To match Aeson instance - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField } + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions {sumEncoding = ObjectWithSingleField} instance ToSchema () where declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema) -- | For 'ToJSON' instance, see package. instance ToSchema UUID.UUID where - declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p - & example ?~ toJSON (UUID.toText UUID.nil) + declareNamedSchema p = + pure $ + named "UUID" $ + paramSchemaToSchema p + & example ?~ toJSON (UUID.toText UUID.nil) + +instance (ToSchema a, ToSchema b) => ToSchema (a, b) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions + +instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions + +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions -instance (ToSchema a, ToSchema b) => ToSchema (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) +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions + +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions + +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions timeSchema :: T.Text -> Schema -timeSchema fmt = mempty - & type_ ?~ OpenApiString - & format ?~ fmt +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) + 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)) + 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. +-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format. instance ToSchema ZonedTime where - declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time" - & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3)) + 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) @@ -477,59 +720,76 @@ instance ToSchema NominalDiffTime where -- >>> 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) + 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 + 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." ) + :$$: 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 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 +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)]) + ToJSONKeyText _ _ -> declareObjectMapSchema + ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)]) where declareObjectMapSchema = do schema <- declareSchemaRef (Proxy :: Proxy v) - return $ unnamed $ mempty - & type_ ?~ OpenApiObject - & additionalProperties ?~ AdditionalPropertiesSchema schema + 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 + 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 + return $ + unnamed $ + schema + & uniqueItems ?~ True instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a)) @@ -537,45 +797,67 @@ instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declare instance ToSchema a => ToSchema (NonEmpty a) where declareNamedSchema _ = do schema <- declareSchema (Proxy :: Proxy [a]) - return $ unnamed $ schema - & minItems .~ Just 1 + 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 (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 (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"} +-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) +-- { +-- "maximum": 32767, +-- "minimum": -32768, +-- "type": "integer" +-- } toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema -toSchemaBoundedIntegral _ = mempty - & type_ ?~ OpenApiInteger - & minimum_ ?~ fromInteger (toInteger (minBound :: a)) - & maximum_ ?~ fromInteger (toInteger (maxBound :: a)) +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) +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 :: + forall a d c s i inner. + (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner)))) => + -- | How to derive the name. + SchemaOptions -> + -- | How to create a schema for the wrapped type. + (Proxy inner -> Declare (Definitions Schema) Schema) -> + Proxy a -> + Declare (Definitions Schema) NamedSchema genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner) -- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys. @@ -586,25 +868,47 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- >>> 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"}}} +-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- { +-- "properties": { +-- "Active": { +-- "type": "string" +-- }, +-- "Disabled": { +-- "type": "string" +-- }, +-- "Focus": { +-- "type": "string" +-- }, +-- "Hover": { +-- "type": "string" +-- }, +-- "Neutral": { +-- "type": "string" +-- } +-- }, +-- "type": "object" +-- } -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. -declareSchemaBoundedEnumKeyMapping :: forall map key value. - (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) - => Proxy (map key value) -> Declare (Definitions Schema) Schema +declareSchemaBoundedEnumKeyMapping :: + 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) + 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. @@ -614,46 +918,95 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- >>> 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"}}} +-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- { +-- "properties": { +-- "Active": { +-- "type": "string" +-- }, +-- "Disabled": { +-- "type": "string" +-- }, +-- "Focus": { +-- "type": "string" +-- }, +-- "Hover": { +-- "type": "string" +-- }, +-- "Neutral": { +-- "type": "string" +-- } +-- }, +-- "type": "object" +-- } -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. -toSchemaBoundedEnumKeyMapping :: forall map key value. - (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) - => Proxy (map key value) -> Schema +toSchemaBoundedEnumKeyMapping :: + 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 :: + (Generic a, GToSchema (Rep a), Typeable a) => + SchemaOptions -> + Proxy a -> + Declare (Definitions Schema) Schema genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy -- | A configurable generic @'NamedSchema'@ creator. -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@. -genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) => - SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty +-- +-- Default implementation will use the name from 'Typeable' instance, including concrete +-- instantioations of type variables. +-- +-- For example: +-- +-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool)) +-- Just "Either_Int_Bool" +genericDeclareNamedSchema :: + forall a. + (Generic a, GToSchema (Rep a), Typeable a) => + SchemaOptions -> + Proxy a -> + Declare (Definitions Schema) NamedSchema +genericDeclareNamedSchema opts _ = + rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty + where + unspace ' ' = '_' + unspace x = x + orig = fmap unspace $ show $ typeRep @a + name = datatypeNameModifier opts orig -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. -genericNameSchema :: forall a d f. - (Generic a, Rep a ~ D1 d f, Datatype d) - => SchemaOptions -> Proxy a -> Schema -> NamedSchema +genericNameSchema :: + 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) + (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 :: + (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'. @@ -661,9 +1014,10 @@ paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema paramSchemaToSchema = toParamSchema nullarySchema :: Schema -nullarySchema = mempty - & type_ ?~ OpenApiArray - & items ?~ OpenApiItemsArray [] +nullarySchema = + mempty + & type_ ?~ OpenApiArray + & items ?~ OpenApiItemsArray [] gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty @@ -692,15 +1046,15 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s gdeclareNamedSchema opts _ s | unwrapUnaryRecords opts = fieldSchema | otherwise = - case schema ^. items of - Just (OpenApiItemsArray [_]) -> fieldSchema - _ -> do - declare defs - return (unnamed schema) + 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 + fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema) gdeclareSchemaRef opts proxy = do @@ -726,21 +1080,29 @@ 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 :: + 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 + 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 @@ -760,32 +1122,37 @@ instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) -instance ( GSumToSchema f - , GSumToSchema g - ) => GToSchema (f :+: g) - where +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 + 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) + 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 + toStringTag schemas = + mempty + & type_ ?~ OpenApiString + & enum_ ?~ map (String . fst) sumSchemas type AllNullary = All -class GSumToSchema (f :: * -> *) where +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 @@ -793,8 +1160,13 @@ instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where (<>) <$> 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 :: + 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 @@ -802,35 +1174,46 @@ gsumConToSchemaWith ref opts _ = (tag, schema) 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]) - + 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 - + _ + | 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] + _ -> + 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 + 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))) @@ -838,8 +1221,11 @@ gsumConToSchemaWith ref opts _ = (tag, schema) 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 :: + (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] @@ -855,64 +1241,18 @@ instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f) lift $ gsumConToSchema opts proxy instance Constructor c => GSumToSchema (C1 c U1) where - gsumToSchema opts proxy = pure $ (:[]) $ gsumConToSchemaWith Nothing opts proxy + gsumToSchema opts proxy = pure $ (: []) $ gsumConToSchemaWith Nothing opts proxy data Proxy2 a b = Proxy2 data Proxy3 a b c = Proxy3 --- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@). --- --- Intended usage: --- --- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1) --- >>> :{ --- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where --- declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy --- :} --- --- >>> toNamedSchema @(Foo Int) Proxy ^. name --- Just "Foo_Int" --- >>> toNamedSchema @(Foo Bool) Proxy ^. name --- Just "Foo_Bool" --- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name --- Just "Foo_(Foo_Text)" -class ToSchema1 (f :: * -> *) where - declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema - - -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method - -- above, however sadly GHC does not like it. - default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema - declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy - -{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema' -using 'ToSchema1' instance, like this: - -#if __GLASGOW_HASKELL__ >= 806 ->>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1) ->>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a) -#else -> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1) -> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a) -#endif --} -newtype BySchema1 f a = BySchema1 (f a) - -instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where - declareNamedSchema _ = do - sch <- declareNamedSchema1 @f @a Proxy Proxy - let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a) - return $ rename (Just tName) sch - -{- $setup ->>> import Data.OpenApi ->>> import Data.Aeson (encode) ->>> import Data.Aeson.Types (toJSONKeyText) ->>> :set -XScopedTypeVariables ->>> :set -XDeriveAnyClass ->>> :set -XStandaloneDeriving ->>> :set -XTypeApplications -#if __GLASGOW_HASKELL__ >= 806 ->>> :set -XDerivingVia -#endif --} +-- $setup +-- >>> import Data.OpenApi +-- >>> import Data.Aeson (encode) +-- >>> import Data.Aeson.Types (toJSONKeyText) +-- >>> import Data.OpenApi.Internal.Utils +-- >>> :set -XScopedTypeVariables +-- >>> :set -XDeriveAnyClass +-- >>> :set -XStandaloneDeriving +-- >>> :set -XTypeApplications diff --git a/src/Data/OpenApi/Internal/Schema/Validation.hs b/src/Data/OpenApi/Internal/Schema/Validation.hs index 3287a36a..52c758c8 100644 --- a/src/Data/OpenApi/Internal/Schema/Validation.hs +++ b/src/Data/OpenApi/Internal/Schema/Validation.hs @@ -31,7 +31,6 @@ 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) @@ -50,6 +49,7 @@ import qualified Data.Vector as Vector import Data.OpenApi.Declare import Data.OpenApi.Internal +import Data.OpenApi.Internal.Utils import Data.OpenApi.Internal.Schema import Data.OpenApi.Lens @@ -103,33 +103,33 @@ validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checke -- -- Swagger Schema: -- { --- "required": [ --- "name", --- "phone" --- ], --- "type": "object", -- "properties": { --- "phone": { --- "$ref": "#/components/schemas/Phone" --- }, -- "name": { -- "type": "string" +-- }, +-- "phone": { +-- "$ref": "#/components/schemas/Phone" -- } --- } +-- }, +-- "required": [ +-- "name", +-- "phone" +-- ], +-- "type": "object" -- } -- -- Swagger Description Context: -- { -- "Phone": { --- "required": [ --- "value" --- ], --- "type": "object", -- "properties": { -- "value": { -- "type": "string" -- } --- } +-- }, +-- "required": [ +-- "value" +-- ], +-- "type": "object" -- } -- } -- diff --git a/src/Data/OpenApi/Internal/Utils.hs b/src/Data/OpenApi/Internal/Utils.hs index e60d7ec2..8bcdd3b1 100644 --- a/src/Data/OpenApi/Internal/Utils.hs +++ b/src/Data/OpenApi/Internal/Utils.hs @@ -13,6 +13,8 @@ import Control.Lens ((&), (%~)) import Control.Lens.TH import Data.Aeson import Data.Aeson.Types +import qualified Data.Aeson.Encode.Pretty as P +import qualified Data.ByteString.Lazy as BSL import Data.Char import Data.Data import Data.Hashable (Hashable) @@ -132,3 +134,6 @@ instance SwaggerMonoid (Maybe a) where swaggerMempty = Nothing swaggerMappend x Nothing = x swaggerMappend _ y = y + +encodePretty :: ToJSON a => a -> BSL.ByteString +encodePretty = P.encodePretty' $ P.defConfig { P.confCompare = P.compare } diff --git a/src/Data/OpenApi/Operation.hs b/src/Data/OpenApi/Operation.hs index 5558aa33..18b46c31 100644 --- a/src/Data/OpenApi/Operation.hs +++ b/src/Data/OpenApi/Operation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} + -- | -- Module: Data.OpenApi.Operation -- Maintainer: Nickolay Kudasov @@ -7,61 +8,63 @@ -- 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, +module Data.OpenApi.Operation + ( -- * Operation traversals + allOperations, + operationsOf, - -- * Manipulation - -- ** Tags - applyTags, - applyTagsFor, + -- * Manipulation - -- ** Responses - setResponse, - setResponseWith, - setResponseFor, - setResponseForWith, + -- ** Tags + applyTags, + applyTagsFor, - -- ** Paths - prependPath, + -- ** Responses + setResponse, + setResponseWith, + setResponseFor, + setResponseForWith, - -- * Miscellaneous - declareResponse, -) where + -- ** Paths + prependPath, -import Prelude () -import Prelude.Compat + -- * Miscellaneous + declareResponse, + ) +where import Control.Lens import Data.Data.Lens +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import qualified Data.HashSet.InsOrd as InsOrdHS 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 +import Data.Proxy +import qualified Data.Set as Set +import Data.Text (Text) +import Network.HTTP.Media (MediaType) +import Prelude.Compat +import Prelude () -- $setup -- >>> import Data.Aeson -- >>> import Data.Proxy -- >>> import Data.Time -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL +-- >>> import Data.OpenApi.Internal.Utils -- | Prepend path piece to all operations of the spec. -- Leading and trailing slashes are trimmed/added automatically. -- -- >>> let api = (mempty :: OpenApi) & paths .~ [("/info", mempty)] --- >>> BSL.putStrLn $ encode $ prependPath "user/{user_id}" api ^. paths --- {"/user/{user_id}/info":{}} +-- >>> BSL.putStrLn $ encodePretty $ prependPath "user/{user_id}" api ^. paths +-- { +-- "/user/{user_id}/info": {} +-- } prependPath :: FilePath -> OpenApi -> OpenApi prependPath path = paths %~ InsOrdHashMap.mapKeys (path ) where @@ -73,7 +76,7 @@ prependPath path = paths %~ InsOrdHashMap.mapKeys (path ) -- | All operations of a Swagger spec. allOperations :: Traversal' OpenApi Operation -allOperations = paths.traverse.template +allOperations = paths . traverse . template -- | @'operationsOf' sub@ will traverse only those operations -- that are present in @sub@. Note that @'Operation'@ is determined @@ -82,26 +85,75 @@ allOperations = paths.traverse.template -- >>> 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":{}} +-- >>> BSL.putStrLn $ encodePretty api +-- { +-- "components": {}, +-- "info": { +-- "title": "", +-- "version": "" +-- }, +-- "openapi": "3.0.0", +-- "paths": { +-- "/user": { +-- "get": { +-- "responses": { +-- "200": { +-- "description": "OK" +-- } +-- } +-- }, +-- "post": { +-- "responses": { +-- "200": { +-- "description": "OK" +-- } +-- } +-- } +-- } +-- } +-- } +-- >>> BSL.putStrLn $ encodePretty $ api & operationsOf sub . at 404 ?~ "Not found" +-- { +-- "components": {}, +-- "info": { +-- "title": "", +-- "version": "" +-- }, +-- "openapi": "3.0.0", +-- "paths": { +-- "/user": { +-- "get": { +-- "responses": { +-- "200": { +-- "description": "OK" +-- }, +-- "404": { +-- "description": "Not found" +-- } +-- } +-- }, +-- "post": { +-- "responses": { +-- "200": { +-- "description": "OK" +-- } +-- } +-- } +-- } +-- } +-- } operationsOf :: OpenApi -> Traversal' OpenApi Operation -operationsOf sub = paths.itraversed.withIndex.subops +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. + Nothing -> pure (path, item) 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 + ns = mapMaybe (fmap fst . sequenceA) $ zip [0 ..] ops -- | Apply tags to all operations and update the global list of tags. -- @@ -114,21 +166,40 @@ 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) +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"}}}}] +-- >>> BSL.putStrLn $ encodePretty $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty +-- [ +-- { +-- "Day": { +-- "example": "2016-07-22", +-- "format": "date", +-- "type": "string" +-- } +-- }, +-- { +-- "content": { +-- "application/json": { +-- "schema": { +-- "$ref": "#/components/schemas/Day" +-- } +-- } +-- }, +-- "description": "" +-- } +-- ] declareResponse :: ToSchema a => MediaType -> Proxy a -> Declare (Definitions Schema) Response declareResponse cType proxy = do s <- declareSchemaRef proxy - return (mempty & content.at cType ?~ (mempty & schema ?~ s)) + return (mempty & content . at cType ?~ (mempty & schema ?~ s)) -- | Set response for all operations. -- This will also update global schema definitions. @@ -143,8 +214,41 @@ declareResponse cType proxy = do -- -- >>> 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"}}}} +-- >>> BSL.putStrLn $ encodePretty $ api & setResponse 200 res +-- { +-- "components": { +-- "schemas": { +-- "Day": { +-- "example": "2016-07-22", +-- "format": "date", +-- "type": "string" +-- } +-- } +-- }, +-- "info": { +-- "title": "", +-- "version": "" +-- }, +-- "openapi": "3.0.0", +-- "paths": { +-- "/user": { +-- "get": { +-- "responses": { +-- "200": { +-- "content": { +-- "application/json": { +-- "schema": { +-- "$ref": "#/components/schemas/Day" +-- } +-- } +-- }, +-- "description": "" +-- } +-- } +-- } +-- } +-- } +-- } -- -- See also @'setResponseWith'@. setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi @@ -171,9 +275,10 @@ setResponseWith = setResponseForWith allOperations -- -- 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 +setResponseFor ops code dres swag = + swag + & components . schemas %~ (<> defs) + & ops . at code ?~ Inline res where (defs, res) = runDeclare dres mempty @@ -185,14 +290,15 @@ setResponseFor ops code dres swag = swag -- -- 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 +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 + 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 + Nothing -> new -- response name can't be dereferenced, replacing with new response combine (Just (Inline old)) = f old new combine Nothing = new diff --git a/src/Data/OpenApi/Optics.hs b/src/Data/OpenApi/Optics.hs index 5dbbbc0c..271f3564 100644 --- a/src/Data/OpenApi/Optics.hs +++ b/src/Data/OpenApi/Optics.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + -- | -- Module: Data.OpenApi.Optics -- Maintainer: Andrzej Rybczak @@ -22,43 +23,88 @@ -- Example from the "Data.OpenApi" module using @optics@: -- -- >>> :{ --- BSL.putStrLn $ encode $ (mempty :: OpenApi) +-- BSL.putStrLn $ encodePretty $ (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"}}}} +-- { +-- "components": { +-- "schemas": { +-- "User": { +-- "type": "string" +-- } +-- } +-- }, +-- "info": { +-- "title": "", +-- "version": "" +-- }, +-- "openapi": "3.0.0", +-- "paths": { +-- "/user": { +-- "get": { +-- "responses": { +-- "200": { +-- "content": { +-- "application/json": { +-- "schema": { +-- "$ref": "#/components/schemas/User" +-- } +-- } +-- }, +-- "description": "OK" +-- }, +-- "404": { +-- "description": "User info not found" +-- } +-- } +-- } +-- } +-- } +-- } -- -- For convenience optics are defined as /labels/. It means that field accessor -- names can be overloaded for different types. One such common field is -- @#description@. Many components of 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 $ encodePretty $ (mempty :: Response) & #description .~ "No content" +-- { +-- "description": "No content" +-- } -- >>> :{ --- BSL.putStrLn $ encode $ (mempty :: Schema) +-- BSL.putStrLn $ encodePretty $ (mempty :: Schema) -- & #type ?~ OpenApiBoolean -- & #description ?~ "To be or not to be" -- :} --- {"type":"boolean","description":"To be or not to be"} +-- { +-- "description": "To be or not to be", +-- "type": "boolean" +-- } -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and -- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example: -- -- >>> :{ --- BSL.putStrLn $ encode $ (mempty :: Operation) +-- BSL.putStrLn $ encodePretty $ (mempty :: Operation) -- & at 404 ?~ "Not found" -- :} --- {"responses":{"404":{"description":"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.OpenApi.Internal.Utils +import Data.Scientific (Scientific) import Data.Text (Text) import Optics.Core import Optics.TH @@ -106,26 +152,32 @@ makePrismLabels ''Referenced -- OpenApiItems prisms instance - ( a ~ [Referenced Schema] - , b ~ [Referenced Schema] - ) => LabelOptic "_OpenApiItemsArray" - A_Review - OpenApiItems - OpenApiItems - a - b where + ( 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 + ( a ~ Referenced Schema, + b ~ Referenced Schema + ) => + LabelOptic + "_OpenApiItemsObject" + A_Review + OpenApiItems + OpenApiItems + a + b + where labelOptic = unto (\x -> OpenApiItemsObject x) {-# INLINE labelOptic #-} @@ -133,151 +185,201 @@ instance -- 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 + +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 + +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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( 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 + ( a ~ Maybe Scientific, + b ~ Maybe Scientific + ) => + LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b + where labelOptic = #schema % #multipleOf {-# INLINE labelOptic #-} diff --git a/src/Data/OpenApi/Schema.hs b/src/Data/OpenApi/Schema.hs index cde8f98b..5b790a69 100644 --- a/src/Data/OpenApi/Schema.hs +++ b/src/Data/OpenApi/Schema.hs @@ -13,8 +13,6 @@ module Data.OpenApi.Schema ( toSchemaRef, schemaName, toInlinedSchema, - ToSchema1(..), - BySchema1(..), -- * Generic schema encoding genericDeclareNamedSchema, diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs index fe724d52..1d409d5d 100644 --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -13,6 +13,7 @@ import Data.Aeson import Data.Aeson.QQ.Simple import Data.HashMap.Strict (HashMap) import qualified Data.HashSet.InsOrd as InsOrdHS +import qualified Data.HashMap.Strict.InsOrd as InsOrdHM import Data.Text (Text) import Data.OpenApi @@ -144,6 +145,7 @@ operationExample = mempty & at 200 ?~ "Pet updated." & at 405 ?~ "Invalid input" & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] + & extensions .~ SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)]) operationExampleJSON :: Value operationExampleJSON = [aesonQQ| @@ -198,7 +200,8 @@ operationExampleJSON = [aesonQQ| "read:pets" ] } - ] + ], + "x-ext1": true } |] @@ -230,6 +233,7 @@ schemaSimpleModelExample = mempty & minimum_ ?~ 0 & type_ ?~ OpenApiInteger & format ?~ "int32" ) ] + & extensions .~ SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)]) schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ| @@ -247,7 +251,8 @@ schemaSimpleModelExampleJSON = [aesonQQ| "type": "integer" } }, - "type": "object" + "type": "object", + "x-ext1": true } |] @@ -448,15 +453,18 @@ securityDefinitionsExample :: SecurityDefinitions securityDefinitionsExample = SecurityDefinitions [ ("api_key", SecurityScheme { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader) - , _securitySchemeDescription = Nothing }) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty}) , ("petstore_auth", SecurityScheme { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing + , _oAuth2Extensions = mempty , _oAuth2Scopes = [ ("write:pets", "modify pets in your account") , ("read:pets", "read your pets") ] } ) - , _securitySchemeDescription = Nothing }) ] + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)])}) ] securityDefinitionsExampleJSON :: Value securityDefinitionsExampleJSON = [aesonQQ| @@ -476,7 +484,8 @@ securityDefinitionsExampleJSON = [aesonQQ| }, "authorizationUrl": "http://swagger.io/api/oauth/dialog" } - } + }, + "x-ext1": true } } @@ -488,9 +497,11 @@ oAuth2SecurityDefinitionsReadExample = SecurityDefinitions { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing + , _oAuth2Extensions = mempty , _oAuth2Scopes = [ ("read:pets", "read your pets") ] } ) - , _securitySchemeDescription = Nothing }) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty }) ] oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions @@ -499,9 +510,12 @@ oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing + , _oAuth2Extensions = mempty , _oAuth2Scopes = [ ("write:pets", "modify pets in your account") ] } ) - , _securitySchemeDescription = Nothing }) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty + }) ] oAuth2SecurityDefinitionsExample :: SecurityDefinitions