From e4b27f3b5dbc938a10b4a78eb88d0dca6341eab9 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Wed, 7 Apr 2021 11:58:51 +0300 Subject: [PATCH 01/11] Switch to Github Actions, allow GHC 9.0.1 and hashable 1.3.1.0 (#18) * Try actions & GHC-9.0.1 * Fix doctests to allow newer hashable * Allow fail for 9.0.1 --- .github/workflows/haskell-ci.yml | 177 ++++++++++ .travis.yml | 149 --------- CHANGELOG.md | 5 + cabal.project | 2 + openapi3.cabal | 13 +- src/Data/OpenApi.hs | 160 +++++++-- src/Data/OpenApi/Internal.hs | 47 ++- src/Data/OpenApi/Internal/ParamSchema.hs | 36 ++- src/Data/OpenApi/Internal/Schema.hs | 305 +++++++++++++++--- .../OpenApi/Internal/Schema/Validation.hs | 30 +- src/Data/OpenApi/Internal/Utils.hs | 5 + src/Data/OpenApi/Operation.hs | 127 +++++++- src/Data/OpenApi/Optics.hs | 63 +++- 13 files changed, 850 insertions(+), 269 deletions(-) create mode 100644 .github/workflows/haskell-ci.yml delete mode 100644 .travis.yml 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..51e78b2d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +Unreleased +---------- + +- Allow `hashable-1.3.1`, prettify doctests. + 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..00154dcf 100644 --- a/openapi3.cabal +++ b/openapi3.cabal @@ -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 diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index bd5e361b..e8c8ea6e 100644 --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -137,6 +137,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 +154,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 +171,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 +210,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 +263,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 +337,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 +368,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..f6ae8811 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -60,6 +60,8 @@ import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding) -- $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 @@ -848,20 +850,37 @@ data HttpSchemeType -- | -- --- >>> encode (SecuritySchemeHttp (HttpSchemeBearer Nothing)) --- "{\"scheme\":\"bearer\",\"type\":\"http\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer Nothing)) +-- { +-- "scheme": "bearer", +-- "type": "http" +-- } -- --- >>> encode (SecuritySchemeHttp (HttpSchemeBearer (Just "jwt"))) --- "{\"scheme\":\"bearer\",\"type\":\"http\",\"bearerFormat\":\"jwt\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer (Just "jwt"))) +-- { +-- "bearerFormat": "jwt", +-- "scheme": "bearer", +-- "type": "http" +-- } -- --- >>> encode (SecuritySchemeHttp HttpSchemeBasic) --- "{\"scheme\":\"basic\",\"type\":\"http\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp HttpSchemeBasic) +-- { +-- "scheme": "basic", +-- "type": "http" +-- } -- --- >>> encode (SecuritySchemeHttp (HttpSchemeCustom "CANARY")) --- "{\"scheme\":\"CANARY\",\"type\":\"http\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeCustom "CANARY")) +-- { +-- "scheme": "CANARY", +-- "type": "http" +-- } -- --- >>> encode (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie)) --- "{\"in\":\"cookie\",\"name\":\"id\",\"type\":\"apiKey\"}" +-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie)) +-- { +-- "in": "cookie", +-- "name": "id", +-- "type": "apiKey" +-- } -- data SecuritySchemeType = SecuritySchemeHttp HttpSchemeType @@ -1305,8 +1324,12 @@ 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 ] diff --git a/src/Data/OpenApi/Internal/ParamSchema.hs b/src/Data/OpenApi/Internal/ParamSchema.hs index ede6aa57..9db058fb 100644 --- a/src/Data/OpenApi/Internal/ParamSchema.hs +++ b/src/Data/OpenApi/Internal/ParamSchema.hs @@ -46,7 +46,7 @@ import Data.OpenApi.Lens import Data.OpenApi.SchemaOptions import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL import GHC.TypeLits (TypeError, ErrorMessage(..)) -- | Default schema for binary data (any sequence of octets). @@ -112,8 +112,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 @@ -155,8 +157,12 @@ 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 @@ -275,8 +281,13 @@ 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 @@ -291,8 +302,14 @@ instance ToParamSchema UUID where -- -- >>> :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 @@ -334,3 +351,4 @@ 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..3f6d4c18 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -42,6 +42,7 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Int import Data.IntSet (IntSet) import Data.IntMap (IntMap) +import Data.List (sort) import Data.List.NonEmpty.Compat (NonEmpty) import Data.Map (Map) import Data.Maybe (fromMaybe) @@ -156,13 +157,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 +185,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 @@ -261,8 +281,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. @@ -295,19 +322,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 @@ -333,25 +405,139 @@ sketchSchema = sketch . toJSON _ -> Nothing go (Object o) = mempty & type_ ?~ OpenApiObject - & required .~ HashMap.keys o + & 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 @@ -383,7 +569,7 @@ sketchStrictSchema = go . toJSON allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs)) go js@(Object o) = mempty & type_ ?~ OpenApiObject - & required .~ names + & required .~ sort names & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) & maxProperties ?~ fromIntegral (length names) & minProperties ?~ fromIntegral (length names) @@ -553,8 +739,12 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar -- | 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 @@ -586,8 +776,27 @@ 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. @@ -614,8 +823,27 @@ 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. @@ -908,6 +1136,7 @@ instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToS >>> import Data.OpenApi >>> import Data.Aeson (encode) >>> import Data.Aeson.Types (toJSONKeyText) +>>> import Data.OpenApi.Internal.Utils >>> :set -XScopedTypeVariables >>> :set -XDeriveAnyClass >>> :set -XStandaloneDeriving 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..9a2484b1 100644 --- a/src/Data/OpenApi/Operation.hs +++ b/src/Data/OpenApi/Operation.hs @@ -55,13 +55,16 @@ import qualified Data.HashSet.InsOrd as InsOrdHS -- >>> 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 @@ -82,10 +85,63 @@ 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 where @@ -123,8 +179,26 @@ applyTagsFor ops ts swag = swag -- -- 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 @@ -143,8 +217,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 diff --git a/src/Data/OpenApi/Optics.hs b/src/Data/OpenApi/Optics.hs index 5dbbbc0c..feb125d7 100644 --- a/src/Data/OpenApi/Optics.hs +++ b/src/Data/OpenApi/Optics.hs @@ -22,43 +22,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.Text (Text) import Optics.Core import Optics.TH From d7cd058bb3584ec04f07adfa070e4cf488f32246 Mon Sep 17 00:00:00 2001 From: iko Date: Sat, 6 Feb 2021 15:49:27 +0300 Subject: [PATCH 02/11] Better parametric polymorphism type names --- src/Data/OpenApi/Internal/Schema.hs | 37 ++++++++++++++++------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 3f6d4c18..ec33f1dc 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -141,7 +141,7 @@ class ToSchema a where -- 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)) => + default declareNamedSchema :: (Generic a, GToSchema (Rep a), Typeable a) => Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions @@ -615,7 +615,7 @@ instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain instance ToSchema a => ToSchema (Maybe a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) -instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where +instance (ToSchema a, ToSchema b, Typeable a, Typeable b) => ToSchema (Either a b) where -- To match Aeson instance declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField } @@ -627,12 +627,12 @@ instance ToSchema UUID.UUID where declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p & example ?~ toJSON (UUID.toText UUID.nil) -instance (ToSchema a, ToSchema b) => ToSchema (a, b) -instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e) => ToSchema (a, b, c, d, e) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f) => ToSchema (a, b, c, d, e, f) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f, ToSchema g, Typeable g) => ToSchema (a, b, c, d, e, f, g) timeSchema :: T.Text -> Schema timeSchema fmt = mempty @@ -683,10 +683,10 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where 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, Typeable a) => ToSchema (IntMap a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)]) -instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where +instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (Map k v) where declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of ToJSONKeyText _ _ -> declareObjectMapSchema ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)]) @@ -697,7 +697,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where & type_ ?~ OpenApiObject & additionalProperties ?~ AdditionalPropertiesSchema schema -instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where +instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (HashMap k v) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v)) instance {-# OVERLAPPING #-} ToSchema Object where @@ -801,7 +801,7 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- 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) + (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value) => Proxy (map key value) -> Declare (Definitions Schema) Schema declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of ToJSONKeyText keyToText _ -> objectSchema keyToText @@ -848,12 +848,12 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- 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) + (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value) => Proxy (map key value) -> Schema toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping -- | A configurable generic @'Schema'@ creator. -genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => +genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy @@ -861,9 +861,12 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche -- 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)) => +genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty +genericDeclareNamedSchema opts _ = + rename (Just tName) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty + where tName = T.replace " " "_" $ T.pack $ show $ typeRep @a + -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. genericNameSchema :: forall a d f. @@ -1110,7 +1113,7 @@ class ToSchema1 (f :: * -> *) where -- 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 + default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a)), Typeable (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' From ba06726784b61796aa6dc08cc233133aa368d906 Mon Sep 17 00:00:00 2001 From: iko Date: Sat, 6 Feb 2021 16:50:50 +0300 Subject: [PATCH 03/11] Fixed tests --- src/Data/OpenApi/Internal/Schema.hs | 30 +++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index ec33f1dc..ace5ae25 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -627,12 +627,18 @@ instance ToSchema UUID.UUID where declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p & example ?~ toJSON (UUID.toText UUID.nil) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e) => ToSchema (a, b, c, d, e) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f) => ToSchema (a, b, c, d, e, f) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f, ToSchema g, Typeable g) => ToSchema (a, b, c, d, e, f, g) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e) => ToSchema (a, b, c, d, e) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f) => ToSchema (a, b, c, d, e, f) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f, ToSchema g, Typeable g) => ToSchema (a, b, c, d, e, f, g) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions timeSchema :: T.Text -> Schema timeSchema fmt = mempty @@ -864,8 +870,12 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchema opts _ = - rename (Just tName) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty - where tName = T.replace " " "_" $ T.pack $ show $ typeRep @a + 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'. @@ -1109,7 +1119,7 @@ data Proxy3 a b c = Proxy3 -- >>> 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 + declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a, Typeable 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. @@ -1129,7 +1139,7 @@ using 'ToSchema1' instance, like this: -} 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 +instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a, Typeable a) => ToSchema (BySchema1 f a) where declareNamedSchema _ = do sch <- declareNamedSchema1 @f @a Proxy Proxy let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a) From 869a867bbad5238b4d8ca338d004b7bca0932914 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 17 Apr 2021 12:00:07 +0300 Subject: [PATCH 04/11] Make Typeable a superclass of ToSchema Also remove ToSchema1, no longer needed --- src/Data/OpenApi/Internal/Schema.hs | 84 ++++++++--------------------- src/Data/OpenApi/Schema.hs | 2 - 2 files changed, 23 insertions(+), 63 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index ace5ae25..438fa8f1 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -135,13 +135,13 @@ 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), Typeable a) => + default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions @@ -610,12 +610,12 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema -instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema +instance (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, Typeable a, Typeable b) => ToSchema (Either a b) where +instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where -- To match Aeson instance declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField } @@ -627,17 +627,17 @@ instance ToSchema UUID.UUID where declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p & example ?~ toJSON (UUID.toText UUID.nil) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) where +instance (ToSchema a, ToSchema b) => ToSchema (a, b) where declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) where +instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) where +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e) => ToSchema (a, b, c, d, e) where +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, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f) => ToSchema (a, b, c, d, e, f) where +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, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f, ToSchema g, Typeable g) => ToSchema (a, b, c, d, e, f, g) where +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 @@ -689,10 +689,10 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int)) -- | NOTE: This schema does not account for the uniqueness of keys. -instance (ToSchema a, Typeable 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, Typeable k, Typeable v) => ToSchema (Map k v) where +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)]) @@ -703,7 +703,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSche & type_ ?~ OpenApiObject & additionalProperties ?~ AdditionalPropertiesSchema schema -instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (HashMap k v) where +instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v)) instance {-# OVERLAPPING #-} ToSchema Object where @@ -807,7 +807,7 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- 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, Typeable key, Typeable 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 @@ -854,7 +854,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- 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, Typeable key, Typeable value) + (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) => Proxy (map key value) -> Schema toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping @@ -867,6 +867,14 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@. +-- +-- Default implementation will use the name from 'Typeable' instance, including concrete +-- instantioations of type variables. +-- +-- For example: +-- +-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool)) +-- Just "Either_Int_Bool" genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchema opts _ = @@ -1102,49 +1110,6 @@ 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, Typeable 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)), Typeable (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, Typeable 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) @@ -1154,7 +1119,4 @@ instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToS >>> :set -XDeriveAnyClass >>> :set -XStandaloneDeriving >>> :set -XTypeApplications -#if __GLASGOW_HASKELL__ >= 806 ->>> :set -XDerivingVia -#endif -} 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, From 1357ab9ffcc1dd264d79bcf8a8fc7dcac0998a50 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 17 Apr 2021 16:58:50 +0300 Subject: [PATCH 05/11] Use date-time format for ZonedTime (#20) Previously ToParamSchema ZonedTime instance used custom format instead of OpenAPI default "date-time". Partially fixes #16. --- src/Data/OpenApi/Internal/ParamSchema.hs | 4 ++-- src/Data/OpenApi/Internal/Schema.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/OpenApi/Internal/ParamSchema.hs b/src/Data/OpenApi/Internal/ParamSchema.hs index 9db058fb..75b637a2 100644 --- a/src/Data/OpenApi/Internal/ParamSchema.hs +++ b/src/Data/OpenApi/Internal/ParamSchema.hs @@ -216,9 +216,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 diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 438fa8f1..7bede45b 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -657,7 +657,7 @@ instance ToSchema LocalTime where declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss" & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) --- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format. +-- | 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)) From 26d8def3d0b1b4c55fea29be7e93d901d9ba9733 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 17 Apr 2021 17:02:43 +0300 Subject: [PATCH 06/11] Release 3.1.0 --- CHANGELOG.md | 9 ++++++++- openapi3.cabal | 2 +- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 51e78b2d..25adef34 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,14 @@ Unreleased ---------- -- Allow `hashable-1.3.1`, prettify doctests. +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/openapi3.cabal b/openapi3.cabal index 00154dcf..ac82f478 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 From ea20d096f2c47132dd0f75cc4c7038daa42b6e63 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 14 May 2021 11:27:19 +0300 Subject: [PATCH 07/11] Relax hspec dependency to <2.9 --- openapi3.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/openapi3.cabal b/openapi3.cabal index ac82f478..484f5fe3 100644 --- a/openapi3.cabal +++ b/openapi3.cabal @@ -119,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 From 81584d56203a9c3a7e93ea3dbdf95b014275e016 Mon Sep 17 00:00:00 2001 From: Magesh Date: Mon, 8 Feb 2021 20:18:27 +0530 Subject: [PATCH 08/11] Extension support for OpenAPI Info Contact License Server ServerVariable PathItem Operation RequestBody MediaType Encoding Example Link Response Tag --- src/Data/OpenApi.hs | 1 + src/Data/OpenApi/Internal.hs | 176 ++++++++++++++++++++++++++--------- 2 files changed, 133 insertions(+), 44 deletions(-) diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index e8c8ea6e..330ed2e3 100644 --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -119,6 +119,7 @@ module Data.OpenApi ( -- ** Miscellaneous MimeList(..), URL(..), + SpecificationExtensions(..), ) where import Data.OpenApi.Lens diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index f6ae8811..4f41b079 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -29,6 +29,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.HashSet.InsOrd (InsOrdHashSet) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (catMaybes) import Data.Monoid (Monoid (..)) import Data.Scientific (Scientific) import Data.Semigroup.Compat (Semigroup (..)) @@ -99,6 +100,9 @@ data OpenApi = OpenApi -- | Additional external documentation. , _openApiExternalDocs :: Maybe ExternalDocs + + -- | Specification Extensions + , _openApiExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | The object provides metadata about the API. @@ -124,6 +128,9 @@ data Info = Info -- | The version of the OpenAPI document (which is distinct from the -- OpenAPI Specification version or the API implementation version). , _infoVersion :: Text + + -- | Specification Extensions + , _infoExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | Contact information for the exposed API. @@ -136,6 +143,9 @@ data Contact = Contact -- | The email address of the contact person/organization. , _contactEmail :: Maybe Text + + -- | Specification Extensions + , _contactExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | License information for the exposed API. @@ -145,10 +155,13 @@ data License = License -- | A URL to the license used for the API. , _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 @@ -165,6 +178,9 @@ data Server = Server -- | 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 + + -- | Specification Extensions + , _serverExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) data ServerVariable = ServerVariable @@ -181,10 +197,13 @@ data ServerVariable = ServerVariable -- | An optional description for the server variable. -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. , _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 @@ -245,6 +264,9 @@ data PathItem = PathItem -- The list MUST NOT include duplicated parameters. -- A unique parameter is defined by a combination of a name and location. , _pathItemParameters :: [Referenced Param] + + -- | Specification Extensions + , _pathItemExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | Describes a single API operation on a path. @@ -310,6 +332,9 @@ data Operation = Operation -- If an alternative server object is specified at the 'PathItem' Object or Root level, -- it will be overridden by this value. , _operationServers :: [Server] + + -- | Specification Extensions + , _operationExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- This instance should be in @http-media@. @@ -343,6 +368,9 @@ data RequestBody = RequestBody -- | Determines if the request body is required in the request. -- Defaults to 'False'. , _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. @@ -362,6 +390,9 @@ data MediaTypeObject = MediaTypeObject -- 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 + + -- | 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. @@ -425,6 +456,9 @@ data Encoding = 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 + + -- | Specification Extensions + , _encodingExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } @@ -535,6 +569,9 @@ data Example = Example -- in JSON or YAML documents. The '_exampleValue' field -- and '_exampleExternalValue' field are mutually exclusive. , _exampleExternalValue :: Maybe URL + + -- | Specification Extensions + , _exampleExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Typeable, Data) data ExpressionOrValue @@ -571,6 +608,9 @@ data Link = Link -- | A server object to be used by the target operation. , _linkServer :: Maybe Server + + -- | Specification Extensions + , _linkExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'OpenApiArray'@ schemas. @@ -744,10 +784,13 @@ data Response = 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) + + -- | 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 @@ -923,12 +966,15 @@ data Tag = Tag -- | Additional external documentation for this tag. , _tagExternalDocs :: Maybe ExternalDocs - } deriving (Eq, Ord, Show, Generic, Data, Typeable) + + -- | 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 @@ -962,6 +1008,10 @@ data AdditionalProperties | 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 ------------------------------------------------------------------------------- @@ -984,6 +1034,11 @@ deriveGeneric ''OpenApi deriveGeneric ''Example deriveGeneric ''Encoding deriveGeneric ''Link +deriveGeneric ''Info +deriveGeneric ''Contact +deriveGeneric ''License +deriveGeneric ''ServerVariable +deriveGeneric ''Tag -- ======================================================================= -- Monoid instances @@ -1159,27 +1214,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") @@ -1214,27 +1254,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") @@ -1305,10 +1330,26 @@ instance ToJSON OpenApi where 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 @@ -1387,6 +1428,10 @@ instance ToJSON Link where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Tag where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd @@ -1417,6 +1462,12 @@ 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 -- ======================================================================= @@ -1453,9 +1504,21 @@ 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 @@ -1521,6 +1584,9 @@ instance FromJSON Encoding where instance FromJSON Link where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Tag where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty @@ -1562,8 +1628,14 @@ 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 @@ -1573,17 +1645,17 @@ instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where instance HasSwaggerAesonOptions OAuth2Flows where swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" 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" instance HasSwaggerAesonOptions SecurityScheme where @@ -1592,13 +1664,29 @@ instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions OpenApi where 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 AesonDefaultValue Server instance AesonDefaultValue Components From a6aa1dda4329a2940a1a84d49d334242fa284e65 Mon Sep 17 00:00:00 2001 From: Magesh Date: Wed, 21 Apr 2021 00:17:32 +0530 Subject: [PATCH 09/11] Made SubObjects as List and Added extensions for following ExternalDocumentation Responses Schema XML Security Scheme OAUTH Flows OAUTH Flow --- src/Data/OpenApi/Internal.hs | 118 ++++++++++++++++-------- src/Data/OpenApi/Internal/AesonUtils.hs | 10 +- 2 files changed, 84 insertions(+), 44 deletions(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 4f41b079..dbf9f8c5 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -700,6 +700,9 @@ data Schema = Schema , _schemaUniqueItems :: Maybe Bool , _schemaEnum :: Maybe [Value] , _schemaMultipleOf :: Maybe Scientific + + -- | Specification Extensions + , _schemaExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | Regex pattern for @string@ type. @@ -746,6 +749,9 @@ data Xml = Xml -- Default value is @False@. -- The definition takes effect only when defined alongside type being array (outside the items). , _xmlWrapped :: Maybe Bool + + -- | Specification Extensions + , _xmlExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | A container for the expected responses of an operation. @@ -761,6 +767,9 @@ data Responses = Responses -- | 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) + + -- | Specification Extensions + , _responsesExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) type HttpStatusCode = Int @@ -867,6 +876,9 @@ data OAuth2Flow p = OAuth2Flow -- A map between the scope name and a short description for it. -- The map MAY be empty. , _oAuth2Scopes :: InsOrdHashMap Text Text + + -- | Specification Extensions + , _oAuth2Extensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) data OAuth2Flows = OAuth2Flows @@ -881,6 +893,9 @@ data OAuth2Flows = OAuth2Flows -- | Configuration for the OAuth Authorization Code flow , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow) + + -- | Specification Extensions + , _oAuth2FlowsExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) type BearerFormat = Text @@ -938,6 +953,9 @@ data SecurityScheme = SecurityScheme -- | A short description for security scheme. , _securitySchemeDescription :: Maybe Text + + -- | Specification Extensions + , _securitySchemeExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) newtype SecurityDefinitions @@ -984,7 +1002,10 @@ data ExternalDocs = ExternalDocs -- | The URL for the target documentation. , _externalDocsUrl :: URL - } deriving (Eq, Ord, Show, Generic, Data, Typeable) + + -- | Specification Extensions + , _externalDocsExtensions :: SpecificationExtensions + } deriving (Eq, Show, Generic, Data, Typeable) instance Hashable ExternalDocs @@ -1001,7 +1022,7 @@ 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 @@ -1039,6 +1060,8 @@ deriveGeneric ''Contact deriveGeneric ''License deriveGeneric ''ServerVariable deriveGeneric ''Tag +deriveGeneric ''Xml +deriveGeneric ''ExternalDocs -- ======================================================================= -- Monoid instances @@ -1140,6 +1163,7 @@ instance Semigroup OAuth2Flows where , _oAuth2FlowsPassword = _oAuth2FlowsPassword l <> _oAuth2FlowsPassword r , _oAuth2FlowsClientCredentials = _oAuth2FlowsClientCredentials l <> _oAuth2FlowsClientCredentials r , _oAuth2FlowsAuthorizationCode = _oAuth2FlowsAuthorizationCode l <> _oAuth2FlowsAuthorizationCode r + , _oAuth2FlowsExtensions = _oAuth2FlowsExtensions l <> _oAuth2FlowsExtensions r } instance Monoid OAuth2Flows where @@ -1147,9 +1171,9 @@ instance Monoid OAuth2Flows where 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 @@ -1220,12 +1244,6 @@ instance ToJSON ApiKeyLocation where instance ToJSON ApiKeyParams where toJSON = genericToJSON (jsonPrefix "apiKey") -instance ToJSON ExternalDocs where - toJSON = genericToJSON (jsonPrefix "ExternalDocs") - -instance ToJSON Xml where - toJSON = genericToJSON (jsonPrefix "Xml") - instance ToJSON Discriminator where toJSON = genericToJSON (jsonPrefix "Discriminator") @@ -1260,9 +1278,6 @@ instance FromJSON ApiKeyLocation where instance FromJSON ApiKeyParams where parseJSON = genericParseJSON (jsonPrefix "apiKey") -instance FromJSON ExternalDocs where - parseJSON = genericParseJSON (jsonPrefix "ExternalDocs") - instance FromJSON Discriminator where parseJSON = genericParseJSON (jsonPrefix "Discriminator") @@ -1356,7 +1371,7 @@ instance ToJSON SecurityScheme where instance ToJSON Schema where toJSON = sopSwaggerGenericToJSONWithOpts $ - mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items" + mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] instance ToJSON Header where toJSON = sopSwaggerGenericToJSON @@ -1432,6 +1447,14 @@ 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 @@ -1554,9 +1577,17 @@ instance FromJSON Param where instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" - <*> parseJSON (Object (HashMap.delete "default" o)) + <*> 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 @@ -1587,6 +1618,12 @@ instance FromJSON Link where 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 @@ -1613,9 +1650,6 @@ instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "# instance FromJSON (Referenced Link) where parseJSON = referencedParseJSON "#/components/links/" instance FromJSON (Referenced Callback) where parseJSON = referencedParseJSON "#/components/callbacks/" -instance FromJSON Xml where - parseJSON = genericParseJSON (jsonPrefix "xml") - instance FromJSON AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js @@ -1635,58 +1669,64 @@ instance FromJSON SpecificationExtensions where filterExtFields = fmap (\(k,v) -> fmap (\k' -> (k',v)) $ Text.stripPrefix "x-" k) . HashMap.toList instance HasSwaggerAesonOptions Server where - swaggerAesonOptions _ = mkSwaggerAesonOptions "server" & saoSubObject ?~ "extensions" + 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" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Param where swaggerAesonOptions _ = mkSwaggerAesonOptions "param" instance HasSwaggerAesonOptions PathItem where - swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Response where - swaggerAesonOptions _ = mkSwaggerAesonOptions "response" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "response" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions RequestBody where - swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions MediaTypeObject where - swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" & saoSubObject ?~ "extensions" + 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")] - & saoSubObject ?~ "extensions" + & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Example where - swaggerAesonOptions _ = mkSwaggerAesonOptions "example" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "example" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Encoding where - swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Link where - swaggerAesonOptions _ = mkSwaggerAesonOptions "link" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "link" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Info where - swaggerAesonOptions _ = mkSwaggerAesonOptions "info" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "info" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Contact where - swaggerAesonOptions _ = mkSwaggerAesonOptions "contact" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "contact" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions License where - swaggerAesonOptions _ = mkSwaggerAesonOptions "license" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "license" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions ServerVariable where - swaggerAesonOptions _ = mkSwaggerAesonOptions "serverVariable" & saoSubObject ?~ "extensions" + swaggerAesonOptions _ = mkSwaggerAesonOptions "serverVariable" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Tag where - swaggerAesonOptions _ = mkSwaggerAesonOptions "tag" & saoSubObject ?~ "extensions" + 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 diff --git a/src/Data/OpenApi/Internal/AesonUtils.hs b/src/Data/OpenApi/Internal/AesonUtils.hs index 98e1ce06..a0cf08dc 100644 --- a/src/Data/OpenApi/Internal/AesonUtils.hs +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -48,13 +48,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 +153,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 +226,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 @@ -293,7 +293,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) From 9067ae9ccde74c3a4485b38274ce246c5b7ceeaa Mon Sep 17 00:00:00 2001 From: Sreenidhi Date: Fri, 9 Apr 2021 13:04:58 +0530 Subject: [PATCH 10/11] explicit ToEncoding for Schema and Referenced --- src/Data/OpenApi/Internal.hs | 1031 ++++++++++++----------- src/Data/OpenApi/Internal/AesonUtils.hs | 19 + 2 files changed, 546 insertions(+), 504 deletions(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index dbf9f8c5..87cc06b0 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -13,50 +13,66 @@ {-# 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.Maybe (catMaybes) -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 @@ -71,94 +87,80 @@ 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 - + _openApiExternalDocs :: Maybe ExternalDocs, -- | Specification Extensions - , _openApiExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 - + _infoVersion :: Text, -- | Specification Extensions - , _infoExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 - + _contactEmail :: Maybe Text, -- | Specification Extensions - , _contactExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 - + _licenseUrl :: Maybe URL, -- | Specification Extensions - , _licenseExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _licenseExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance IsString License where fromString s = License (fromString s) Nothing mempty @@ -169,38 +171,35 @@ 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 - + _serverVariables :: InsOrdHashMap Text ServerVariable, -- | Specification Extensions - , _serverExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 - + _serverVariableDescription :: Maybe Text, -- | Specification Extensions - , _serverVariableExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _serverVariableExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance IsString Server where fromString s = Server (fromString s) Nothing mempty mempty @@ -209,16 +208,17 @@ instance IsString Server where -- 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. @@ -226,116 +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] - + _pathItemParameters :: [Referenced Param], -- | Specification Extensions - , _pathItemExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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] - + _operationServers :: [Server], -- | Specification Extensions - , _operationExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _operationExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) -- This instance should be in @http-media@. instance Data MediaType where @@ -348,6 +326,7 @@ instance Data MediaType where dataTypeOf _ = mediaTypeData mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix + mediaTypeData = mkDataType "MediaType" [mediaTypeConstr] instance Hashable MediaType where @@ -357,65 +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 - + _requestBodyRequired :: Maybe Bool, -- | Specification Extensions - , _requestBodyExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 - + _mediaTypeObjectEncoding :: InsOrdHashMap Text Encoding, -- | Specification Extensions - , _mediaTypeObjectExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 @@ -426,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. @@ -448,20 +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 - + _encodingAllowReserved :: Maybe Bool, -- | Specification Extensions - , _encodingExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 @@ -482,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. @@ -535,44 +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 - + _exampleExternalValue :: Maybe URL, -- | Specification Extensions - , _exampleExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Typeable, Data) + _exampleExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Typeable, Data) data ExpressionOrValue = Expression Text @@ -587,31 +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 - + _linkServer :: Maybe Server, -- | Specification Extensions - , _linkExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Typeable, Data) + _linkExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'OpenApiArray'@ schemas. -- @@ -622,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 @@ -655,73 +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 - + _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) + _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. @@ -729,30 +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 - + _xmlWrapped :: Maybe Bool, -- | Specification Extensions - , _xmlExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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. @@ -762,15 +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) - + _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response), -- | Specification Extensions - , _responsesExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _responsesExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) type HttpStatusCode = Int @@ -778,25 +720,22 @@ 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) - + _responseLinks :: InsOrdHashMap Text (Referenced Link), -- | Specification Extensions - , _responseExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _responseExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance IsString Response where fromString s = Response (fromString s) mempty mempty mempty mempty @@ -816,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 @@ -837,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 @@ -849,54 +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 - + _oAuth2Scopes :: InsOrdHashMap Text Text, -- | Specification Extensions - , _oAuth2Extensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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) - + _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow), -- | Specification Extensions - , _oAuth2FlowsExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _oAuth2FlowsExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) type BearerFormat = Text @@ -939,7 +870,6 @@ data HttpSchemeType -- "name": "id", -- "type": "apiKey" -- } --- data SecuritySchemeType = SecuritySchemeHttp HttpSchemeType | SecuritySchemeApiKey ApiKeyParams @@ -949,14 +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 - + _securitySchemeDescription :: Maybe Text, -- | Specification Extensions - , _securitySchemeExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _securitySchemeExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) newtype SecurityDefinitions = SecurityDefinitions (Definitions SecurityScheme) @@ -967,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 @@ -976,18 +906,16 @@ 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 - + _tagExternalDocs :: Maybe ExternalDocs, -- | Specification Extensions - , _tagExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _tagExtensions :: SpecificationExtensions + } + deriving (Eq, Show, Generic, Data, Typeable) instance Hashable Tag @@ -998,20 +926,19 @@ instance IsString Tag where 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 - + _externalDocsUrl :: URL, -- | Specification Extensions - , _externalDocsExtensions :: SpecificationExtensions - } deriving (Eq, Show, Generic, Data, Typeable) + _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 @@ -1022,17 +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, AesonDefaultValue) +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} +newtype SpecificationExtensions = SpecificationExtensions {getSpecificationExtensions :: Definitions Value} deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid, AesonDefaultValue) - ------------------------------------------------------------------------------- -- Generic instances ------------------------------------------------------------------------------- @@ -1069,102 +995,117 @@ deriveGeneric ''ExternalDocs 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 - , _oAuth2FlowsExtensions = _oAuth2FlowsExtensions l <> _oAuth2FlowsExtensions 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 @@ -1178,7 +1119,7 @@ instance Semigroup SecurityScheme where 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 @@ -1186,6 +1127,7 @@ instance Monoid SecurityDefinitions where instance Semigroup RequestBody where (<>) = genericMappend + instance Monoid RequestBody where mempty = genericMempty mappend = (<>) @@ -1195,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 @@ -1315,34 +1267,41 @@ 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 @@ -1370,7 +1329,11 @@ instance ToJSON SecurityScheme where toEncoding = sopSwaggerGenericToEncoding instance ToJSON Schema where - toJSON = sopSwaggerGenericToJSONWithOpts $ + toJSON = + sopSwaggerGenericToJSONWithOpts $ + mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] + toEncoding = + sopSwaggerGenericToEncodingWithOpts $ mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] instance ToJSON Header where @@ -1386,15 +1349,15 @@ instance ToJSON Header where -- "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 @@ -1459,19 +1422,35 @@ 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 @@ -1490,7 +1469,6 @@ instance ToJSON SpecificationExtensions where where addExtPrefix = InsOrdHashMap.mapKeys ("x-" <>) - -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -1512,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") @@ -1547,22 +1525,25 @@ instance FromJSON SecurityScheme where 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 @@ -1575,19 +1556,24 @@ instance FromJSON Param where parseJSON = sopSwaggerGenericParseJSON instance FromJSON Responses where - 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 (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 @@ -1633,21 +1619,28 @@ 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 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 @@ -1666,41 +1659,58 @@ 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 + filterExtFields = fmap (\(k, v) -> fmap (\k' -> (k', v)) $ Text.stripPrefix "x-" k) . HashMap.toList instance HasSwaggerAesonOptions Server where 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", "extensions"] + instance HasSwaggerAesonOptions OAuth2Flows where swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Operation where swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Param where swaggerAesonOptions _ = mkSwaggerAesonOptions "param" + instance HasSwaggerAesonOptions PathItem where swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Response where swaggerAesonOptions _ = mkSwaggerAesonOptions "response" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions RequestBody where swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions MediaTypeObject where swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Responses where swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject .~ ["responses", "extensions"] + instance HasSwaggerAesonOptions SecurityScheme where swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject .~ ["type", "extensions"] + instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject .~ ["paramSchema", "extensions"] + instance HasSwaggerAesonOptions OpenApi where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] - & saoSubObject .~ ["extensions"] + swaggerAesonOptions _ = + mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] + & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Example where swaggerAesonOptions _ = mkSwaggerAesonOptions "example" & saoSubObject .~ ["extensions"] + instance HasSwaggerAesonOptions Encoding where swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" & saoSubObject .~ ["extensions"] @@ -1729,16 +1739,29 @@ 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 a0cf08dc..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(..), @@ -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)) From 7c42e6546701cfb24ec9589226dae89c8eb973ab Mon Sep 17 00:00:00 2001 From: Magesh Date: Wed, 21 Apr 2021 02:54:22 +0530 Subject: [PATCH 11/11] Fixed the tests --- src/Data/OpenApi.hs | 190 +++---- src/Data/OpenApi/Internal/ParamSchema.hs | 197 +++++--- src/Data/OpenApi/Internal/Schema.hs | 616 ++++++++++++++--------- src/Data/OpenApi/Operation.hs | 95 ++-- src/Data/OpenApi/Optics.hs | 163 ++++-- test/Data/OpenApiSpec.hs | 28 +- 6 files changed, 763 insertions(+), 526 deletions(-) diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index 330ed2e3..10d9445f 100644 --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -9,128 +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(..), - SpecificationExtensions(..), -) 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 diff --git a/src/Data/OpenApi/Internal/ParamSchema.hs b/src/Data/OpenApi/Internal/ParamSchema.hs index 75b637a2..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.Char8 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'@. -- @@ -130,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" @@ -145,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 @@ -164,39 +170,45 @@ instance ToParamSchema Word64 where -- "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 @@ -236,46 +248,62 @@ 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)) @@ -289,14 +317,16 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where -- "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. -- @@ -338,14 +368,15 @@ 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 diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 7bede45b..1964b5fd 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -19,62 +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 @@ -141,13 +144,18 @@ class Typeable a => ToSchema a where -- 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 @@ -255,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) @@ -306,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) @@ -387,26 +395,28 @@ 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 .~ sort (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. @@ -541,39 +551,44 @@ sketchSchema = sketch . toJSON 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 .~ sort 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 @@ -583,32 +598,50 @@ 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 (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema @@ -617,50 +650,68 @@ instance ToSchema a => ToSchema (Maybe a) where 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 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-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) @@ -669,21 +720,28 @@ 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)) @@ -694,34 +752,44 @@ instance (ToSchema a) => ToSchema (IntMap a) where 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)) @@ -729,17 +797,24 @@ 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) @@ -752,26 +827,37 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar -- "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. @@ -806,20 +892,23 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- -- 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. @@ -853,14 +942,19 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- -- 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), Typeable 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. @@ -875,8 +969,12 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche -- -- >>> _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 :: + 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 @@ -885,24 +983,30 @@ genericDeclareNamedSchema opts _ = 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'. @@ -910,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 @@ -941,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 @@ -975,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 @@ -1009,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 @@ -1042,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 @@ -1051,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))) @@ -1087,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] @@ -1104,19 +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 -{- $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 --} +-- $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/Operation.hs b/src/Data/OpenApi/Operation.hs index 9a2484b1..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,48 +8,47 @@ -- 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 @@ -76,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 @@ -143,21 +143,17 @@ allOperations = paths.traverse.template -- } -- } 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. -- @@ -170,9 +166,10 @@ 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. @@ -202,7 +199,7 @@ applyTagsFor ops ts swag = swag 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. @@ -278,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 @@ -292,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 feb125d7..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 @@ -101,9 +102,9 @@ 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 @@ -151,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 #-} @@ -178,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/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