From 39fb875951b23cf1be491dd894e1a36dbe3282bc Mon Sep 17 00:00:00 2001 From: akhesacaro Date: Wed, 17 Nov 2021 12:33:17 +0100 Subject: [PATCH] moving servant-swagger into the main servant repo --- cabal.project | 1 + servant-swagger/.travis.yml | 167 ++++++ servant-swagger/CHANGELOG.md | 143 +++++ servant-swagger/LICENSE | 28 + servant-swagger/README.md | 47 ++ servant-swagger/Setup.hs | 33 ++ servant-swagger/cabal.haskell-ci | 14 + servant-swagger/cabal.project | 2 + servant-swagger/example/LICENSE | 28 + servant-swagger/example/example.cabal | 62 +++ servant-swagger/example/server/Main.hs | 11 + servant-swagger/example/src/Todo.hs | 73 +++ servant-swagger/example/swagger.json | 158 ++++++ servant-swagger/example/test/Spec.hs | 1 + servant-swagger/example/test/TodoSpec.hs | 28 + servant-swagger/servant-swagger.cabal | 127 +++++ servant-swagger/src/Servant/Swagger.hs | 186 +++++++ .../src/Servant/Swagger/Internal.hs | 477 +++++++++++++++++ .../src/Servant/Swagger/Internal/Orphans.hs | 27 + .../src/Servant/Swagger/Internal/Test.hs | 205 ++++++++ .../src/Servant/Swagger/Internal/TypeLevel.hs | 9 + .../Servant/Swagger/Internal/TypeLevel/API.hs | 86 +++ .../Swagger/Internal/TypeLevel/Every.hs | 63 +++ .../Swagger/Internal/TypeLevel/TMap.hs | 37 ++ servant-swagger/src/Servant/Swagger/Test.hs | 13 + .../src/Servant/Swagger/TypeLevel.hs | 15 + servant-swagger/stack.yaml | 8 + servant-swagger/test/Servant/SwaggerSpec.hs | 489 ++++++++++++++++++ servant-swagger/test/Spec.hs | 1 + servant-swagger/test/doctests.hs | 12 + 30 files changed, 2551 insertions(+) create mode 100644 servant-swagger/.travis.yml create mode 100644 servant-swagger/CHANGELOG.md create mode 100644 servant-swagger/LICENSE create mode 100644 servant-swagger/README.md create mode 100644 servant-swagger/Setup.hs create mode 100644 servant-swagger/cabal.haskell-ci create mode 100644 servant-swagger/cabal.project create mode 100644 servant-swagger/example/LICENSE create mode 100644 servant-swagger/example/example.cabal create mode 100644 servant-swagger/example/server/Main.hs create mode 100644 servant-swagger/example/src/Todo.hs create mode 100644 servant-swagger/example/swagger.json create mode 100644 servant-swagger/example/test/Spec.hs create mode 100644 servant-swagger/example/test/TodoSpec.hs create mode 100644 servant-swagger/servant-swagger.cabal create mode 100644 servant-swagger/src/Servant/Swagger.hs create mode 100644 servant-swagger/src/Servant/Swagger/Internal.hs create mode 100644 servant-swagger/src/Servant/Swagger/Internal/Orphans.hs create mode 100644 servant-swagger/src/Servant/Swagger/Internal/Test.hs create mode 100644 servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs create mode 100644 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs create mode 100644 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs create mode 100644 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs create mode 100644 servant-swagger/src/Servant/Swagger/Test.hs create mode 100644 servant-swagger/src/Servant/Swagger/TypeLevel.hs create mode 100644 servant-swagger/stack.yaml create mode 100644 servant-swagger/test/Servant/SwaggerSpec.hs create mode 100644 servant-swagger/test/Spec.hs create mode 100644 servant-swagger/test/doctests.hs diff --git a/cabal.project b/cabal.project index 04b29bd5..ac4a4e3b 100644 --- a/cabal.project +++ b/cabal.project @@ -12,6 +12,7 @@ packages: servant-docs/ servant-foreign/ servant-server/ + servant-swagger/ doc/tutorial/ -- servant streaming diff --git a/servant-swagger/.travis.yml b/servant-swagger/.travis.yml new file mode 100644 index 00000000..ee3600ca --- /dev/null +++ b/servant-swagger/.travis.yml @@ -0,0 +1,167 @@ +# This Travis job script has been generated by a script via +# +# haskell-ci '--config=cabal.haskell-ci' '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.10.3 +# +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.2 + 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.2","cabal-install-3.2"]}} + os: linux + - compiler: ghc-8.8.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.8.4","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 + - compiler: ghc-8.2.2 + 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.2.2","cabal-install-3.2"]}} + os: linux + - compiler: ghc-8.0.2 + 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.0.2","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 + - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-swagger' >> cabal.project ; fi + - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" + - | + echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-swagger)$' || 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_servant_swagger="$(find . -maxdepth 1 -type d -regex '.*/servant-swagger-[0-9.]*')" + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo "packages: ${PKGDIR_servant_swagger}" >> cabal.project + - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-swagger' >> cabal.project ; fi + - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" + - | + echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-swagger)$' || 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_servant_swagger} && ${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 + # Constraint sets + - rm -rf cabal.project.local + # Constraint set swagger2-2.3 + - if [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='swagger2 ==2.3.*' all ; fi + # Constraint set swagger2-2.4 + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='swagger2 ==2.4.*' all + # Constraint set swagger2-2.5 + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='swagger2 ==2.5.*' all + # Constraint set servant-0.18.1 + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='servant == 0.18.1' all + +# REGENDATA ("0.10.3",["--config=cabal.haskell-ci","cabal.project"]) +# EOF diff --git a/servant-swagger/CHANGELOG.md b/servant-swagger/CHANGELOG.md new file mode 100644 index 00000000..0ee616b1 --- /dev/null +++ b/servant-swagger/CHANGELOG.md @@ -0,0 +1,143 @@ +1.1.9 +------- + +* Support `servant-0.18` + +1.1.8 +------- + +* Support `servant-0.17` + +1.1.7.1 +------- + +* Support `swagger2-2.4` + +1.1.7 +----- + +* Support servant-0.15 + - support for 'Stream' and 'StreamBody' combinators + - orphan 'ToSchema (SourceT m a)' instance +* Fix BodyTypes to work with generalized ReqBody' + [#88](https://github.com/haskell-servant/servant-swagger/pull/88) + +1.1.6 +----- + +* Fixes: + * `validateEveryToJSON` now prints validation errors + +* Notes: + * GHC-8.6 compatible release + +1.1.5 +----- + +* Notes: + * `servant-0.13` compatible release + * Drops compatibility with previous `servant` versions. + +1.1.4 +----- + +* Notes: + * `servant-0.12` compatible release + +1.1.3.1 +--- + +* Notes: + * GHC-8.2 compatible release + +1.1.3 +--- + +* Notes: + * `servant-0.11` compatible release + +1.1.2.1 +--- + +* Notes: + * `servant-0.10` compatible release + +1.1.2 +--- + +* Minor fixes: + * Support for aeson-1, insert-ordered-containers-0.2 + * CaptureAll instance + +1.1.1 +--- + +* Minor fixes: + * Fix `unused-imports` and `unused-foralls` warnings; + * Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema). + +1.1 +--- + +* Breaking changes: + * Requires `swagger2 >= 2.1` + * Requires `servant >= 0.5` + +* Notes: + * GHC-8.0 compatible release + +1.0.3 +--- + +* Fixes: + * Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))! + +1.0.2 +--- + +* Minor changes: + * Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)). + +* Fixes: + * Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)). + +1.0.1 +--- + +* Fixes: + * Stop using `Data.Swagger.Internal`; + * Documentation fixes (links to examples). + +1.0 +--- + +* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)): + * Switch to `swagger2-2.*`; + * Add automatic `ToJSON`/`ToSchema` validation tests; + * Add great documentation; + * Export some type-level functions for servant API. + +* Minor changes: + * Rework Todo API example; + * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2)); + * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147)); + * Include changelog and example files into `extra-source-files`. + +0.1.2 +--- + +* Fixes: + * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22)); + * Set version bounds for `swagger2`. + +0.1.1 +--- + +* Fixes: + * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18)); + * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)). + +0.1 +--- +* Major changes + * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything. diff --git a/servant-swagger/LICENSE b/servant-swagger/LICENSE new file mode 100644 index 00000000..17ec62d2 --- /dev/null +++ b/servant-swagger/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015-2016, Servant contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of servant-swagger nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/servant-swagger/README.md b/servant-swagger/README.md new file mode 100644 index 00000000..c21bfd60 --- /dev/null +++ b/servant-swagger/README.md @@ -0,0 +1,47 @@ +# servant-swagger + +[![Build Status](https://travis-ci.org/haskell-servant/servant-swagger.svg?branch=master)](https://travis-ci.org/haskell-servant/servant-swagger) +[![Hackage](https://img.shields.io/hackage/v/servant-swagger.svg)](http://hackage.haskell.org/package/servant-swagger) +[![Stackage LTS](http://stackage.org/package/servant-swagger/badge/lts)](http://stackage.org/lts/package/servant-swagger) +[![Stackage Nightly](http://stackage.org/package/servant-swagger/badge/nightly)](http://stackage.org/nightly/package/servant-swagger) + +Swagger 2.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs. + +![servant-swagger robot](http://s16.postimg.org/rndz1wbyt/servant.png) + +### Motivation + +Swagger is a project used to describe and document RESTful APIs. +Unlike Servant it is language-agnostic and thus is quite popular among developers +in different languages. It also exists for a longer time and has more tools to work with. + +This package provides means to generate Swagger specification for a Servant API +and also to partially test whether API conforms with its specification. + +Generated Swagger specification then can be used for many things such as +- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/); +- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/); +- and [many others](http://swagger.io/open-source-integrations/). + +### Usage + +Please refer to [haddock documentation](http://hackage.haskell.org/package/servant-swagger). + +Some examples can be found in [`example/` directory](/example). + +### Try it out + +All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/). + +Ready-to-use specification can be served as JSON and interactive API documentation +can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui). + +Many Swagger tools, including server and client code generation for many languages, can be found on +[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/). + +### Contributing + +We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. + +Please report bugs via the [github issue tracker](https://github.com/haskell-servant/servant-swagger/issues). + diff --git a/servant-swagger/Setup.hs b/servant-swagger/Setup.hs new file mode 100644 index 00000000..8ec54a08 --- /dev/null +++ b/servant-swagger/Setup.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif diff --git a/servant-swagger/cabal.haskell-ci b/servant-swagger/cabal.haskell-ci new file mode 100644 index 00000000..05a9061c --- /dev/null +++ b/servant-swagger/cabal.haskell-ci @@ -0,0 +1,14 @@ +branches: master + +constraint-set swagger2-2.3 + ghc: <8.8 + constraints: swagger2 ==2.3.* + +constraint-set swagger2-2.4 + constraints: swagger2 ==2.4.* + +constraint-set swagger2-2.5 + constraints: swagger2 ==2.5.* + +constraint-set servant-0.17 + constraints: servant == 0.17.* diff --git a/servant-swagger/cabal.project b/servant-swagger/cabal.project new file mode 100644 index 00000000..2d61bba2 --- /dev/null +++ b/servant-swagger/cabal.project @@ -0,0 +1,2 @@ +packages: . +allow-newer: aeson-pretty-0.8.7:base-compat diff --git a/servant-swagger/example/LICENSE b/servant-swagger/example/LICENSE new file mode 100644 index 00000000..17ec62d2 --- /dev/null +++ b/servant-swagger/example/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015-2016, Servant contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of servant-swagger nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/servant-swagger/example/example.cabal b/servant-swagger/example/example.cabal new file mode 100644 index 00000000..6abc75f6 --- /dev/null +++ b/servant-swagger/example/example.cabal @@ -0,0 +1,62 @@ +name: example +version: 1.0 +synopsis: servant-swagger demonstration +description: servant-swagger demonstration +license: BSD3 +license-file: LICENSE +author: David Johnson, Nickolay Kudasov +maintainer: nickolay.kudasov@gmail.com +copyright: (c) 2015-2016, Servant contributors +category: Web +build-type: Simple +cabal-version: >=1.10 +data-files: + swagger.json + +library + ghc-options: -Wall + hs-source-dirs: src/ + exposed-modules: + Todo + build-depends: base + , aeson + , aeson-pretty + , bytestring + , lens + , servant + , servant-server + , servant-swagger + , swagger2 + , text + , time + default-language: Haskell2010 + +executable swagger-server + ghc-options: -Wall + hs-source-dirs: server/ + main-is: Main.hs + build-depends: base + , example + , servant-server + , warp + default-language: Haskell2010 + +test-suite swagger-server-spec + ghc-options: -Wall + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + TodoSpec + Paths_example + build-depends: base == 4.* + , base-compat >= 0.6.0 + , aeson >=0.11.2.0 + , bytestring + , example + , hspec + , servant-swagger + , QuickCheck + , quickcheck-instances + default-language: Haskell2010 + diff --git a/servant-swagger/example/server/Main.hs b/servant-swagger/example/server/Main.hs new file mode 100644 index 00000000..69197690 --- /dev/null +++ b/servant-swagger/example/server/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Network.Wai.Handler.Warp +import Servant +import Todo + +main :: IO () +main = do + putStrLn "Running on port 8000" + run 8000 $ serve (Proxy :: Proxy API) server + diff --git a/servant-swagger/example/src/Todo.hs b/servant-swagger/example/src/Todo.hs new file mode 100644 index 00000000..e562e98e --- /dev/null +++ b/servant-swagger/example/src/Todo.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Todo where + +import Control.Lens +import Data.Aeson +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Proxy +import Data.Swagger +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Data.Typeable (Typeable) +import GHC.Generics +import Servant +import Servant.Swagger + +todoAPI :: Proxy TodoAPI +todoAPI = Proxy + +-- | The API of a Todo service. +type TodoAPI + = "todo" :> Get '[JSON] [Todo] + :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId + :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo + :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId + +-- | API for serving @swagger.json@. +type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger + +-- | Combined API of a Todo service with Swagger documentation. +type API = SwaggerAPI :<|> TodoAPI + +-- | A single Todo entry. +data Todo = Todo + { created :: UTCTime -- ^ Creation datetime. + , summary :: Text -- ^ Task summary. + } deriving (Show, Generic, Typeable) + +-- | A unique Todo entry ID. +newtype TodoId = TodoId Int + deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData) + +instance ToJSON Todo +instance FromJSON Todo + +instance ToSchema Todo where + declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy + & mapped.schema.description ?~ "This is some real Todo right here" + & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk") + +instance ToParamSchema TodoId +instance ToSchema TodoId + +-- | Swagger spec for Todo API. +todoSwagger :: Swagger +todoSwagger = toSwagger todoAPI + & info.title .~ "Todo API" + & info.version .~ "1.0" + & info.description ?~ "This is an API that tests swagger integration" + & info.license ?~ ("MIT" & url ?~ URL "http://mit.com") + +-- | Combined server of a Todo service with Swagger documentation. +server :: Server API +server = return todoSwagger :<|> error "not implemented" + +-- | Output generated @swagger.json@ file for the @'TodoAPI'@. +writeSwaggerJSON :: IO () +writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger) diff --git a/servant-swagger/example/swagger.json b/servant-swagger/example/swagger.json new file mode 100644 index 00000000..018bd8f5 --- /dev/null +++ b/servant-swagger/example/swagger.json @@ -0,0 +1,158 @@ +{ + "swagger": "2.0", + "info": { + "version": "1.0", + "title": "Todo API", + "license": { + "url": "http://mit.com", + "name": "MIT" + }, + "description": "This is an API that tests swagger integration" + }, + "definitions": { + "Todo": { + "example": { + "summary": "get milk", + "created": "2015-12-31T00:00:00Z" + }, + "required": [ + "created", + "summary" + ], + "type": "object", + "description": "This is some real Todo right here", + "properties": { + "summary": { + "type": "string" + }, + "created": { + "$ref": "#/definitions/UTCTime" + } + } + }, + "UTCTime": { + "example": "2016-07-22T00:00:00Z", + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + }, + "TodoId": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } + }, + "paths": { + "/todo/{id}": { + "get": { + "responses": { + "400": { + "description": "Invalid `id`" + }, + "200": { + "schema": { + "$ref": "#/definitions/Todo" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ], + "parameters": [ + { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "required": true, + "in": "path", + "name": "id", + "type": "integer" + } + ] + }, + "put": { + "consumes": [ + "application/json;charset=utf-8" + ], + "responses": { + "400": { + "description": "Invalid `body` or `id`" + }, + "200": { + "schema": { + "$ref": "#/definitions/TodoId" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ], + "parameters": [ + { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "required": true, + "in": "path", + "name": "id", + "type": "integer" + }, + { + "required": true, + "schema": { + "$ref": "#/definitions/Todo" + }, + "in": "body", + "name": "body" + } + ] + } + }, + "/todo": { + "post": { + "consumes": [ + "application/json;charset=utf-8" + ], + "responses": { + "400": { + "description": "Invalid `body`" + }, + "200": { + "schema": { + "$ref": "#/definitions/TodoId" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ], + "parameters": [ + { + "required": true, + "schema": { + "$ref": "#/definitions/Todo" + }, + "in": "body", + "name": "body" + } + ] + }, + "get": { + "responses": { + "200": { + "schema": { + "items": { + "$ref": "#/definitions/Todo" + }, + "type": "array" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ] + } + } + } +} \ No newline at end of file diff --git a/servant-swagger/example/test/Spec.hs b/servant-swagger/example/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-swagger/example/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-swagger/example/test/TodoSpec.hs b/servant-swagger/example/test/TodoSpec.hs new file mode 100644 index 00000000..1e44274b --- /dev/null +++ b/servant-swagger/example/test/TodoSpec.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module TodoSpec where + +import Prelude () +import Prelude.Compat + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Paths_example +import Servant.Swagger.Test +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Todo + +spec :: Spec +spec = describe "Swagger" $ do + context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI + it "swagger.json is up-to-date" $ do + path <- getDataFileName "swagger.json" + swag <- eitherDecode <$> BL8.readFile path + swag `shouldBe` Right todoSwagger + +instance Arbitrary Todo where + arbitrary = Todo <$> arbitrary <*> arbitrary + +instance Arbitrary TodoId where + arbitrary = TodoId <$> arbitrary diff --git a/servant-swagger/servant-swagger.cabal b/servant-swagger/servant-swagger.cabal new file mode 100644 index 00000000..60f3cacc --- /dev/null +++ b/servant-swagger/servant-swagger.cabal @@ -0,0 +1,127 @@ +name: servant-swagger +version: 1.1.11 +synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API. +description: + Swagger is a project used to describe and document RESTful APIs. The core of the + project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/). + This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is + quite popular among developers in different languages. It has also existed for a longer time + and has more helpful tooling. + . + This package provides means to generate a Swagger/OAS specification for a Servant API + and also to partially test whether an API conforms with its specification. + . + Generated Swagger specification then can be used for many things such as + . + * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/); + . + * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/); + . + * and [many others](http://swagger.io/open-source-integrations/). +homepage: https://github.com/haskell-servant/servant-swagger +bug-reports: https://github.com/haskell-servant/servant-swagger/issues +license: BSD3 +license-file: LICENSE +author: David Johnson, Nickolay Kudasov +maintainer: nickolay.kudasov@gmail.com +copyright: (c) 2015-2018, Servant contributors +category: Web, Servant, Swagger +build-type: Custom +cabal-version: 1.18 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 + +extra-source-files: + README.md + , CHANGELOG.md + , example/server/*.hs + , example/src/*.hs + , example/test/*.hs + , example/*.cabal + , example/swagger.json + , example/LICENSE +extra-doc-files: + example/src/*.hs + , example/test/*.hs + +source-repository head + type: git + location: https://github.com/haskell-servant/servant-swagger.git + +custom-setup + setup-depends: + base >=4.9 && <5, + Cabal >= 1.24 && <3.3, + cabal-doctest >=1.0.6 && <1.1 + +library + ghc-options: -Wall + exposed-modules: + Servant.Swagger + Servant.Swagger.Test + Servant.Swagger.TypeLevel + + -- Internal modules + Servant.Swagger.Internal + Servant.Swagger.Internal.Orphans + Servant.Swagger.Internal.Test + Servant.Swagger.Internal.TypeLevel + Servant.Swagger.Internal.TypeLevel.API + Servant.Swagger.Internal.TypeLevel.Every + Servant.Swagger.Internal.TypeLevel.TMap + hs-source-dirs: src + build-depends: aeson >=1.4.2.0 && <1.6 + , aeson-pretty >=0.8.7 && <0.9 + , base >=4.9.1.0 && <5 + , base-compat >=0.10.5 && <0.12 + , bytestring >=0.10.8.1 && <0.11 + , http-media >=0.7.1.3 && <0.9 + , insert-ordered-containers >=0.2.1.0 && <0.3 + , lens >=4.17 && <6 + , servant >=0.18.1 && <0.19 + , singleton-bool >=0.1.4 && <0.2 + , swagger2 >=2.3.0.1 && <3 + , text >=1.2.3.0 && <1.3 + , unordered-containers >=0.2.9.0 && <0.3 + + , hspec + , QuickCheck + default-language: Haskell2010 + +test-suite doctests + ghc-options: -Wall + build-depends: + base, + directory >= 1.0, + doctest >= 0.18 && <0.19, + servant, + QuickCheck, + filepath + default-language: Haskell2010 + hs-source-dirs: test + main-is: doctests.hs + type: exitcode-stdio-1.0 + +test-suite spec + ghc-options: -Wall + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8 + build-depends: base + , base-compat + , aeson + , hspec >=2.6.0 && <2.8 + , QuickCheck + , lens + , lens-aeson >=1.0.2 && <1.2 + , servant + , servant-swagger + , swagger2 + , text + , template-haskell + , utf8-string >=1.0.1.1 && <1.1 + , time + , vector + other-modules: + Servant.SwaggerSpec + default-language: Haskell2010 diff --git a/servant-swagger/src/Servant/Swagger.hs b/servant-swagger/src/Servant/Swagger.hs new file mode 100644 index 00000000..c45b0fbc --- /dev/null +++ b/servant-swagger/src/Servant/Swagger.hs @@ -0,0 +1,186 @@ +-- | +-- Module: Servant.Swagger +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- This module provides means to generate and manipulate +-- Swagger specification for servant APIs. +-- +-- Swagger is a project used to describe and document RESTful APIs. +-- +-- The Swagger specification defines a set of files required to describe such an API. +-- These files can then be used by the Swagger-UI project to display the API +-- and Swagger-Codegen to generate clients in various languages. +-- Additional utilities can also take advantage of the resulting files, such as testing tools. +-- +-- For more information see . +module Servant.Swagger ( + -- * How to use this library + -- $howto + + -- ** Generate @'Swagger'@ + -- $generate + + -- ** Annotate + -- $annotate + + -- ** Test + -- $test + + -- ** Serve + -- $serve + + -- * @'HasSwagger'@ class + HasSwagger(..), + + -- * Manipulation + subOperations, + + -- * Testing + validateEveryToJSON, + validateEveryToJSONWithPatternChecker, +) where + +import Servant.Swagger.Internal +import Servant.Swagger.Test +import Servant.Swagger.Internal.Orphans () + +-- $setup +-- >>> import Control.Applicative +-- >>> import Control.Lens +-- >>> import Data.Aeson +-- >>> import Data.Aeson.Encode.Pretty +-- >>> import Data.Swagger +-- >>> import Data.Typeable +-- >>> import GHC.Generics +-- >>> import Servant.API +-- >>> import Test.Hspec +-- >>> import Test.QuickCheck +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8 +-- >>> :set -XDataKinds +-- >>> :set -XDeriveDataTypeable +-- >>> :set -XDeriveGeneric +-- >>> :set -XGeneralizedNewtypeDeriving +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeOperators +-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable) +-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON) +-- >>> instance ToJSON User +-- >>> instance ToSchema User +-- >>> instance ToSchema UserId +-- >>> instance ToParamSchema UserId +-- >>> type GetUsers = Get '[JSON] [User] +-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User +-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId +-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser +-- >>> orderedKeys = encodePretty' (defConfig { confCompare = compare, confIndent = Spaces 0 }) + +-- $howto +-- +-- This section explains how to use this library to generate Swagger specification, +-- modify it and run automatic tests for a servant API. +-- +-- For the purposes of this section we will use this servant API: +-- +-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable) +-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON) +-- >>> instance ToJSON User +-- >>> instance ToSchema User +-- >>> instance ToSchema UserId +-- >>> instance ToParamSchema UserId +-- >>> type GetUsers = Get '[JSON] [User] +-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User +-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId +-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser +-- +-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users. +-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID. + +-- $generate +-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@: +-- +-- >>> BSL8.putStrLn . orderedKeys $ toSwagger (Proxy :: Proxy UserAPI) +-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"} +-- +-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas. +-- +-- For some parameters it will also add 400 responses with a description mentioning parameter name. +-- +-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes. + +-- $annotate +-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API. +-- +-- We can add this information using field lenses from @"Data.Swagger"@: +-- +-- >>> :{ +-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI) +-- & info.title .~ "User API" +-- & info.version .~ "1.0" +-- & info.description ?~ "This is an API for the Users service" +-- & info.license ?~ "MIT" +-- & host ?~ "example.com" +-- :} +-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"host":"example.com","info":{"description":"This is an API for the Users service","license":{"name":"MIT"},"title":"User API","version":"1.0"},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"} +-- +-- It is also useful to annotate or modify certain endpoints. +-- @'subOperations'@ provides a convenient way to zoom into a part of an API. +-- +-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@. +-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck. +-- +-- @"Data.Swagger.Operation"@ provides some useful helpers that can be used with @'subOperations'@. +-- One example is applying tags to certain endpoints: +-- +-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI) +-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI) +-- >>> :{ +-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI) +-- & applyTagsFor getOps ["get" & description ?~ "GET operations"] +-- & applyTagsFor postOps ["post" & description ?~ "POST operations"] +-- :} +-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}},"tags":["get"]},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}},"tags":["post"]}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}},"tags":["get"]}}},"swagger":"2.0","tags":[{"description":"GET operations","name":"get"},{"description":"POST operations","name":"post"}]} +-- +-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API. + +-- $test +-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types +-- used in a servant API. But to encode/decode actual data servant uses different classes. +-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances. +-- +-- To be sure your Haskell server/client handles data properly you need to check +-- that @'ToJSON'@ instance always generates values that satisfy schema produced +-- by @'ToSchema'@ instance. +-- +-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically, +-- without having to write down every type: +-- +-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary +-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary +-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI) +-- +-- [User] +-- ... +-- User +-- ... +-- UserId +-- ... +-- Finished in ... seconds +-- 3 examples, 0 failures +-- +-- Although servant is great, chances are that your API clients don't use Haskell. +-- In many cases @swagger.json@ serves as a specification, not a Haskell type. +-- +-- In this cases it is a good idea to store generated and annotated @'Swagger'@ in a @swagger.json@ file +-- under a version control system (such as Git, Subversion, Mercurial, etc.). +-- +-- It is also recommended to version API based on changes to the @swagger.json@ rather than changes +-- to the Haskell API. +-- +-- See for an example of a complete test suite for a swagger specification. + +-- $serve +-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification. +-- +-- See for an example of a server. diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs new file mode 100644 index 00000000..c4cc2780 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE UndecidableInstances #-} +#endif +module Servant.Swagger.Internal where + +import Prelude () +import Prelude.Compat + +import Control.Applicative ((<|>)) +import Control.Lens +import Data.Aeson +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.Foldable (toList) +import Data.Proxy +import Data.Typeable +import Data.Singletons.Bool +import Data.Swagger hiding (Header) +import qualified Data.Swagger as Swagger +import Data.Swagger.Declare +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.TypeLits +import Network.HTTP.Media (MediaType) +import Servant.API +import Servant.API.Description (FoldDescription, + reflectDescription) +import Servant.API.Modifiers (FoldRequired) + +import Servant.Swagger.Internal.TypeLevel.API + +-- | Generate a Swagger specification for a servant API. +-- +-- To generate Swagger specification, your data types need +-- @'ToParamSchema'@ and/or @'ToSchema'@ instances. +-- +-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@. +-- @'ToSchema'@ is used for @'ReqBody'@ and response data types. +-- +-- You can easily derive those instances via @Generic@. +-- For more information, refer to . +-- +-- Example: +-- +-- @ +-- newtype Username = Username String deriving (Generic, ToText) +-- +-- instance ToParamSchema Username +-- +-- data User = User +-- { username :: Username +-- , fullname :: String +-- } deriving (Generic) +-- +-- instance ToJSON User +-- instance ToSchema User +-- +-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User +-- +-- mySwagger :: Swagger +-- mySwagger = toSwagger (Proxy :: Proxy MyAPI) +-- @ +class HasSwagger api where + -- | Generate a Swagger specification for a servant API. + toSwagger :: Proxy api -> Swagger + +instance HasSwagger Raw where + toSwagger _ = mempty & paths . at "/" ?~ mempty + +instance HasSwagger EmptyAPI where + toSwagger _ = mempty + +-- | All operations of sub API. +-- This is similar to @'operationsOf'@ but ensures that operations +-- indeed belong to the API at compile time. +subOperations :: (IsSubAPI sub api, HasSwagger sub) => + Proxy sub -- ^ Part of a servant API. + -> Proxy api -- ^ The whole servant API. + -> Traversal' Swagger Operation +subOperations sub _ = operationsOf (toSwagger sub) + +-- | Make a singleton Swagger spec (with only one endpoint). +-- For endpoints with no content see 'mkEndpointNoContent'. +mkEndpoint :: forall a cs hs proxy method status. + (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status) + => FilePath -- ^ Endpoint path. + -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response. + -> Swagger +mkEndpoint path proxy + = mkEndpointWithSchemaRef (Just ref) path proxy + & definitions .~ defs + where + (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty + +-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema. +mkEndpointNoContent :: forall nocontent cs hs proxy method status. + (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status) + => FilePath -- ^ Endpoint path. + -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response. + -> Swagger +mkEndpointNoContent path proxy + = mkEndpointWithSchemaRef Nothing path proxy + +-- | Like @'mkEndpoint'@ but with explicit schema reference. +-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@. +mkEndpointWithSchemaRef :: forall cs hs proxy method status a. + (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status) + => Maybe (Referenced Schema) + -> FilePath + -> proxy (Verb method status cs (Headers hs a)) + -> Swagger +mkEndpointWithSchemaRef mref path _ = mempty + & paths.at path ?~ + (mempty & method ?~ (mempty + & produces ?~ MimeList responseContentTypes + & at code ?~ Inline (mempty + & schema .~ mref + & headers .~ responseHeaders))) + where + method = swaggerMethod (Proxy :: Proxy method) + code = fromIntegral (natVal (Proxy :: Proxy status)) + responseContentTypes = allContentType (Proxy :: Proxy cs) + responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs) + +mkEndpointNoContentVerb :: forall proxy method. + (SwaggerMethod method) + => FilePath -- ^ Endpoint path. + -> proxy (NoContentVerb method) -- ^ Method + -> Swagger +mkEndpointNoContentVerb path _ = mempty + & paths.at path ?~ + (mempty & method ?~ (mempty + & at code ?~ Inline mempty)) + where + method = swaggerMethod (Proxy :: Proxy method) + code = 204 -- hardcoded in servant-server + +-- | Add parameter to every operation in the spec. +addParam :: Param -> Swagger -> Swagger +addParam param = allOperations.parameters %~ (Inline param :) + +-- | Add accepted content types to every operation in the spec. +addConsumes :: [MediaType] -> Swagger -> Swagger +addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs)) + +-- | Format given text as inline code in Markdown. +markdownCode :: Text -> Text +markdownCode s = "`" <> s <> "`" + +addDefaultResponse400 :: ParamName -> Swagger -> Swagger +addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400) + where + sname = markdownCode pname + description400 = "Invalid " <> sname + alter400 = description %~ (<> (" or " <> sname)) + response400 = mempty & description .~ description400 + +-- | Methods, available for Swagger. +class SwaggerMethod method where + swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation) + +instance SwaggerMethod 'GET where swaggerMethod _ = get +instance SwaggerMethod 'PUT where swaggerMethod _ = put +instance SwaggerMethod 'POST where swaggerMethod _ = post +instance SwaggerMethod 'DELETE where swaggerMethod _ = delete +instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options +instance SwaggerMethod 'HEAD where swaggerMethod _ = head_ +instance SwaggerMethod 'PATCH where swaggerMethod _ = patch + +instance HasSwagger (UVerb method cs '[]) where + toSwagger _ = mempty + +-- | @since +instance + {-# OVERLAPPABLE #-} + ( ToSchema a, + HasStatus a, + AllAccept cs, + SwaggerMethod method, + HasSwagger (UVerb method cs as) + ) => + HasSwagger (UVerb method cs (a ': as)) + where + toSwagger _ = + toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a)) + `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as)) + +-- ATTENTION: do not remove this instance! +-- A similar instance above will always use the more general +-- polymorphic -- HasSwagger instance and will result in a type error +-- since 'NoContent' does not have a 'ToSchema' instance. +instance + ( KnownNat status, + AllAccept cs, + SwaggerMethod method, + HasSwagger (UVerb method cs as) + ) => + HasSwagger (UVerb method cs (WithStatus status NoContent ': as)) + where + toSwagger _ = + toSwagger (Proxy :: Proxy (Verb method status cs NoContent)) + `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as)) + + +-- workaround for https://github.com/GetShopTV/swagger2/issues/218 +-- We'd like to juse use (<>) but the instances are wrong +combinePathItem :: PathItem -> PathItem -> PathItem +combinePathItem s t = PathItem + { _pathItemGet = _pathItemGet s <> _pathItemGet t + , _pathItemPut = _pathItemPut s <> _pathItemPut t + , _pathItemPost = _pathItemPost s <> _pathItemPost t + , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t + , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t + , _pathItemHead = _pathItemHead s <> _pathItemHead t + , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t + , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t + } + +combineSwagger :: Swagger -> Swagger -> Swagger +combineSwagger s t = Swagger + { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t + , _swaggerHost = _swaggerHost s <|> _swaggerHost t + , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t + , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t + , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t + , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t + , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t) + , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t + , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t + , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t + , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t + , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t + , _swaggerTags = _swaggerTags s <> _swaggerTags t + , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t + } + +instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where + toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a))) + +-- | @since 1.1.7 +instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where + toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a))) + +instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) + => HasSwagger (Verb method status cs (Headers hs a)) where + toSwagger = mkEndpoint "/" + +-- ATTENTION: do not remove this instance! +-- A similar instance above will always use the more general +-- polymorphic -- HasSwagger instance and will result in a type error +-- since 'NoContent' does not have a 'ToSchema' instance. +instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where + toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent))) + +instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) + => HasSwagger (Verb method status cs (Headers hs NoContent)) where + toSwagger = mkEndpointNoContent "/" + +instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where + toSwagger = mkEndpointNoContentVerb "/" + +instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where + toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b) + +-- | @'Vault'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (Vault :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'IsSecure'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'RemoteHost'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'Fragment'@ combinator does not change our specification at all. +instance HasSwagger sub => HasSwagger (Fragment a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'HttpVersion'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'WithNamedContext'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where + toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub)) + where + piece = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & prependPath capture + & addDefaultResponse400 tname + where + symbol = symbolVal (Proxy :: Proxy sym) + pname = if symbol == "" + then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) + else symbol + tname = Text.pack pname + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) + capture = "{" <> pname <> "}" + param = mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema .~ ParamOther (mempty + & in_ .~ ParamPath + & paramSchema .~ toParamSchema (Proxy :: Proxy a)) + +-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort. +instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub)) + +instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where + toSwagger _ = toSwagger (Proxy :: Proxy api) + & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) + +instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where + toSwagger _ = toSwagger (Proxy :: Proxy api) + & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) + +instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname + where + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) + param = mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) + & schema .~ ParamOther sch + sch = mempty + & in_ .~ ParamQuery + & paramSchema .~ toParamSchema (Proxy :: Proxy a) + +instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname + where + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) + param = mempty + & name .~ tname + & schema .~ ParamOther sch + sch = mempty + & in_ .~ ParamQuery + & paramSchema .~ pschema + pschema = mempty +#if MIN_VERSION_swagger2(2,4,0) + & type_ ?~ SwaggerArray +#else + & type_ .~ SwaggerArray +#endif + & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a)) + +instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname + where + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) + param = mempty + & name .~ tname + & schema .~ ParamOther (mempty + & in_ .~ ParamQuery + & allowEmptyValue ?~ True + & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool) + & default_ ?~ toJSON False)) + +instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname + where + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) + param = mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) + & schema .~ ParamOther (mempty + & in_ .~ ParamHeader + & paramSchema .~ toParamSchema (Proxy :: Proxy a)) + +instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addConsumes (allContentType (Proxy :: Proxy cs)) + & addDefaultResponse400 tname + & definitions %~ (<> defs) + where + tname = "body" + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) + (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty + param = mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema .~ ParamBody ref + +-- | This instance is an approximation. +-- +-- @since 1.1.7 +instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addConsumes (toList (contentTypes (Proxy :: Proxy ct))) + & addDefaultResponse400 tname + & definitions %~ (<> defs) + where + tname = "body" + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) + (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty + param = mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema .~ ParamBody ref + +-- ======================================================================= +-- Below are the definitions that should be in Servant.API.ContentTypes +-- ======================================================================= + +class AllAccept cs where + allContentType :: Proxy cs -> [MediaType] + +instance AllAccept '[] where + allContentType _ = [] + +instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where + allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs) + +class ToResponseHeader h where + toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header) + +instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where + toResponseHeader _ = (hname, Swagger.Header Nothing hschema) + where + hname = Text.pack (symbolVal (Proxy :: Proxy sym)) + hschema = toParamSchema (Proxy :: Proxy a) + +class AllToResponseHeader hs where + toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header + +instance AllToResponseHeader '[] where + toAllResponseHeaders _ = mempty + +instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where + toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs + where + (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h) + hdrs = toAllResponseHeaders (Proxy :: Proxy hs) + +instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where + toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) diff --git a/servant-swagger/src/Servant/Swagger/Internal/Orphans.hs b/servant-swagger/src/Servant/Swagger/Internal/Orphans.hs new file mode 100644 index 00000000..22263eca --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/Orphans.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +module Servant.Swagger.Internal.Orphans where + +import Data.Proxy + (Proxy (..)) +import Data.Swagger +import Servant.Types.SourceT + (SourceT) +#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) +import Servant.API (WithStatus(..)) +#endif + +-- | Pretend that 'SourceT m a' is '[a]'. +-- +-- @since 1.1.7 +-- +instance ToSchema a => ToSchema (SourceT m a) where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) + +#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) +-- @since 1.1.11 +deriving instance ToSchema a => ToSchema (WithStatus s a) +#endif diff --git a/servant-swagger/src/Servant/Swagger/Internal/Test.hs b/servant-swagger/src/Servant/Swagger/Internal/Test.hs new file mode 100644 index 00000000..0fecb0a1 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/Test.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.Swagger.Internal.Test where + +import Data.Aeson (ToJSON (..)) +import Data.Aeson.Encode.Pretty (encodePretty', defConfig, + confCompare) +import Data.Swagger (Pattern, ToSchema, + toSchema) +import Data.Swagger.Schema.Validation +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.Typeable +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck (Arbitrary, Property, + counterexample, property) + +import Servant.API +import Servant.Swagger.Internal.TypeLevel + +-- $setup +-- >>> import Control.Applicative +-- >>> import GHC.Generics +-- >>> import Test.QuickCheck +-- >>> :set -XDeriveGeneric +-- >>> :set -XGeneralizedNewtypeDeriving +-- >>> :set -XDataKinds +-- >>> :set -XTypeOperators + +-- | Verify that every type used with @'JSON'@ content type in a servant API +-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@. +-- +-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation. +-- See @'validateEveryToJSONWithPatternChecker'@. +-- +-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API. +-- Each type only gets one test, even if it occurs multiple times in the API. +-- +-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable) +-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary) +-- >>> instance ToJSON User +-- >>> instance ToSchema User +-- >>> instance ToSchema UserId +-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary +-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId) +-- +-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI) +-- +-- ToJSON matches ToSchema +-- User +-- ... +-- UserId +-- ... +-- Finished in ... seconds +-- 2 examples, 0 failures +-- +-- For the test to compile all body types should have the following instances: +-- +-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation; +-- * @'Typeable'@ is used to name the test for each type; +-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@. +-- * @'Arbitrary'@ is used to arbitrarily generate values. +-- +-- If any of the instances is missing, you'll get a descriptive type error: +-- +-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic) +-- >>> instance ToJSON Contact +-- >>> instance ToSchema Contact +-- >>> type ContactAPI = Get '[JSON] Contact +-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI) +-- ... +-- ...No instance for (Arbitrary Contact) +-- ... arising from a use of ‘validateEveryToJSON’ +-- ... +validateEveryToJSON + :: forall proxy api . + TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) + (BodyTypes JSON api) + => proxy api -- ^ Servant API. + -> Spec +validateEveryToJSON _ = props + (Proxy :: Proxy [ToJSON, ToSchema]) + (maybeCounterExample . prettyValidateWith validateToJSON) + (Proxy :: Proxy (BodyTypes JSON api)) + +-- | Verify that every type used with @'JSON'@ content type in a servant API +-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@. +-- +-- For validation without patterns see @'validateEveryToJSON'@. +validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) => + (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker. + -> proxy api -- ^ Servant API. + -> Spec +validateEveryToJSONWithPatternChecker checker _ = props + (Proxy :: Proxy [ToJSON, ToSchema]) + (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker)) + (Proxy :: Proxy (BodyTypes JSON api)) + +-- * QuickCheck-related stuff + +-- | Construct property tests for each type in a list. +-- The name for each property is the name of the corresponding type. +-- +-- >>> :{ +-- hspec $ +-- context "read . show == id" $ +-- props +-- (Proxy :: Proxy [Eq, Show, Read]) +-- (\x -> read (show x) === x) +-- (Proxy :: Proxy [Bool, Int, String]) +-- :} +-- +-- read . show == id +-- Bool +-- ... +-- Int +-- ... +-- [Char] +-- ... +-- Finished in ... seconds +-- 3 examples, 0 failures +props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs => + p cs -- ^ A list of constraints. + -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate. + -> p'' xs -- ^ A list of types. + -> Spec +props _ f px = sequence_ specs + where + specs :: [Spec] + specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px + + aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec + aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property) + +-- | Pretty print validation errors +-- together with actual JSON and Swagger Schema +-- (using 'encodePretty'). +-- +-- >>> import Data.Aeson +-- >>> import Data.Foldable (traverse_) +-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic) +-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ] +-- >>> instance ToSchema Person +-- >>> let person = Person { name = "John", phone = 123456 } +-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person +-- Validation against the schema fails: +-- * property "phone" is required, but not found in "{\"name\":\"John\"}" +-- +-- JSON value: +-- { +-- "name": "John" +-- } +-- +-- Swagger Schema: +-- { +-- "properties": { +-- "name": { +-- "type": "string" +-- }, +-- "phone": { +-- "type": "integer" +-- } +-- }, +-- "required": [ +-- "name", +-- "phone" +-- ], +-- "type": "object" +-- } +-- +-- +-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@). +prettyValidateWith + :: forall a. (ToJSON a, ToSchema a) + => (a -> [ValidationError]) -> a -> Maybe String +prettyValidateWith f x = + case f x of + [] -> Nothing + errors -> Just $ unlines + [ "Validation against the schema fails:" + , unlines (map (" * " ++) errors) + , "JSON value:" + , ppJSONString json + , "" + , "Swagger Schema:" + , ppJSONString (toJSON schema) + ] + where + ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg + ppCfg = defConfig { confCompare = compare } + + json = toJSON x + schema = toSchema (Proxy :: Proxy a) + +-- | Provide a counterexample if there is any. +maybeCounterExample :: Maybe String -> Property +maybeCounterExample Nothing = property True +maybeCounterExample (Just s) = counterexample s (property False) diff --git a/servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs new file mode 100644 index 00000000..f050c117 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs @@ -0,0 +1,9 @@ +module Servant.Swagger.Internal.TypeLevel ( + module Servant.Swagger.Internal.TypeLevel.API, + module Servant.Swagger.Internal.TypeLevel.Every, + module Servant.Swagger.Internal.TypeLevel.TMap, +) where + +import Servant.Swagger.Internal.TypeLevel.API +import Servant.Swagger.Internal.TypeLevel.Every +import Servant.Swagger.Internal.TypeLevel.TMap diff --git a/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs new file mode 100644 index 00000000..818e378b --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Swagger.Internal.TypeLevel.API where + +import GHC.Exts (Constraint) +import Servant.API + +-- | Build a list of endpoints from an API. +type family EndpointsList api where + EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b) + EndpointsList (e :> a) = MapSub e (EndpointsList a) + EndpointsList a = '[a] + +-- | Check whether @sub@ is a sub API of @api@. +type family IsSubAPI sub api :: Constraint where + IsSubAPI sub api = AllIsElem (EndpointsList sub) api + +-- | Check that every element of @xs@ is an endpoint of @api@. +type family AllIsElem xs api :: Constraint where + AllIsElem '[] api = () + AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api) + +-- | Apply @(e :>)@ to every API in @xs@. +type family MapSub e xs where + MapSub e '[] = '[] + MapSub e (x ': xs) = (e :> x) ': MapSub e xs + +-- | Append two type-level lists. +type family AppendList xs ys where + AppendList '[] ys = ys + AppendList (x ': xs) ys = x ': AppendList xs ys + +type family Or (a :: Constraint) (b :: Constraint) :: Constraint where + Or () b = () + Or a () = () + +type family IsIn sub api :: Constraint where + IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b) + IsIn (e :> a) (e :> b) = IsIn a b + IsIn e e = () + +-- | Check whether a type is a member of a list of types. +-- This is a type-level analogue of @'elem'@. +type family Elem x xs where + Elem x '[] = 'False + Elem x (x ': xs) = 'True + Elem x (y ': xs) = Elem x xs + +-- | Remove duplicates from a type-level list. +type family Nub xs where + Nub '[] = '[] + Nub (x ': xs) = x ': Nub (Remove x xs) + +-- | Remove element from a type-level list. +type family Remove x xs where + Remove x '[] = '[] + Remove x (x ': ys) = Remove x ys + Remove x (y ': ys) = y ': Remove x ys + +-- | Extract a list of unique "body" types for a specific content-type from a servant API. +type BodyTypes c api = Nub (BodyTypes' c api) + +-- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@ +-- only if @c@ is in @cs@. +type AddBodyType c cs a as = If (Elem c cs) (a ': as) as + +-- | Extract a list of "body" types for a specific content-type from a servant API. +-- To extract unique types see @'BodyTypes'@. +-- +-- @'NoContent'@ is removed from the list and not tested. (This allows for leaving the body +-- completely empty on responses to requests that only accept 'application/json', while +-- setting the content-type in the response accordingly.) +type family BodyTypes' c api :: [*] where + BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[] + BodyTypes' c (Verb verb b cs NoContent) = '[] + BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[] + BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api) + BodyTypes' c (e :> api) = BodyTypes' c api + BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b) + BodyTypes' c api = '[] + diff --git a/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs new file mode 100644 index 00000000..b1d64b0e --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE UndecidableSuperClasses #-} +#endif +module Servant.Swagger.Internal.TypeLevel.Every where + +import Data.Proxy +import GHC.Exts (Constraint) + +import Servant.Swagger.Internal.TypeLevel.TMap + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XFlexibleContexts +-- >>> :set -XGADTs +-- >>> :set -XRankNTypes +-- >>> :set -XScopedTypeVariables +-- >>> import GHC.TypeLits +-- >>> import Data.List + +-- | Apply multiple constraint constructors to a type. +-- +-- @ +-- EveryTF '[Show, Read] a ~ (Show a, Read a) +-- @ +-- +-- Note that since this is a type family, you have to alway fully apply @'EveryTF'@. +-- +-- For partial application of multiple constraint constructors see @'Every'@. +type family EveryTF cs x :: Constraint where + EveryTF '[] x = () + EveryTF (c ': cs) x = (c x, EveryTF cs x) + +-- | Apply multiple constraint constructors to a type as a class. +-- +-- This is different from @'EveryTF'@ in that it allows partial application. +class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where + +instance Every '[] x where +instance (c x, Every cs x) => Every (c ': cs) x where + +-- | Like @'tmap'@, but uses @'Every'@ for multiple constraints. +-- +-- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a) +-- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String] +-- ["0","0.0"] +tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) => + p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a] +tmapEvery _ = tmap (Proxy :: Proxy (Every cs)) diff --git a/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs new file mode 100644 index 00000000..d2aa3b04 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Swagger.Internal.TypeLevel.TMap where + +import Data.Proxy +import GHC.Exts (Constraint) + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XFlexibleContexts +-- >>> :set -XGADTs +-- >>> :set -XRankNTypes +-- >>> :set -XScopedTypeVariables +-- >>> import GHC.TypeLits +-- >>> import Data.List + +-- | Map a list of constrained types to a list of values. +-- +-- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"]) +-- ["hello","world"] +class TMap (q :: k -> Constraint) (xs :: [k]) where + tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a] + +instance TMap q '[] where + tmap _ _ _ = [] + +instance (q x, TMap q xs) => TMap q (x ': xs) where + tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs) + diff --git a/servant-swagger/src/Servant/Swagger/Test.hs b/servant-swagger/src/Servant/Swagger/Test.hs new file mode 100644 index 00000000..7fa2e406 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Test.hs @@ -0,0 +1,13 @@ +-- | +-- Module: Servant.Swagger.Test +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Automatic tests for servant API against Swagger spec. +module Servant.Swagger.Test ( + validateEveryToJSON, + validateEveryToJSONWithPatternChecker, +) where + +import Servant.Swagger.Internal.Test diff --git a/servant-swagger/src/Servant/Swagger/TypeLevel.hs b/servant-swagger/src/Servant/Swagger/TypeLevel.hs new file mode 100644 index 00000000..89b8af93 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/TypeLevel.hs @@ -0,0 +1,15 @@ +-- | +-- Module: Servant.Swagger.TypeLevel +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Useful type families for servant APIs. +module Servant.Swagger.TypeLevel ( + IsSubAPI, + EndpointsList, + BodyTypes, +) where + +import Servant.Swagger.Internal.TypeLevel + diff --git a/servant-swagger/stack.yaml b/servant-swagger/stack.yaml new file mode 100644 index 00000000..4011b92a --- /dev/null +++ b/servant-swagger/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-16.7 +packages: +- '.' +- example/ + +extra-deps: +- servant-0.18.1 +- servant-server-0.18.1 diff --git a/servant-swagger/test/Servant/SwaggerSpec.hs b/servant-swagger/test/Servant/SwaggerSpec.hs new file mode 100644 index 00000000..c422c95c --- /dev/null +++ b/servant-swagger/test/Servant/SwaggerSpec.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PackageImports #-} +module Servant.SwaggerSpec where + +import Control.Lens +import Data.Aeson (ToJSON(toJSON), Value, genericToJSON) +import Data.Aeson.QQ.Simple +import qualified Data.Aeson.Types as JSON +import Data.Char (toLower) +import Data.Int (Int64) +import Data.Proxy +import Data.Swagger +import Data.Text (Text) +import Data.Time +import GHC.Generics +import Servant.API +import Servant.Swagger +import Servant.Test.ComprehensiveAPI (comprehensiveAPI) +import Test.Hspec hiding (example) + +#if !MIN_VERSION_swagger2(2,4,0) +import Data.Aeson.Lens (key, _Array) +import qualified Data.Vector as V +#endif + +checkAPI :: HasSwagger api => Proxy api -> Value -> IO () +checkAPI proxy = checkSwagger (toSwagger proxy) + +checkSwagger :: Swagger -> Value -> IO () +checkSwagger swag js = toJSON swag `shouldBe` js + +spec :: Spec +spec = describe "HasSwagger" $ do + it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI + it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI + it "GetPost API (test subOperations)" $ checkSwagger getPostSwagger getPostAPI + it "UVerb API" $ checkSwagger uverbSwagger uverbAPI + it "Comprehensive API" $ do + let _x = toSwagger comprehensiveAPI + True `shouldBe` True -- type-level test + +main :: IO () +main = hspec spec + +-- ======================================================================= +-- Todo API +-- ======================================================================= + +data Todo = Todo + { created :: UTCTime + , title :: String + , summary :: Maybe String + } deriving (Generic) + +instance ToJSON Todo +instance ToSchema Todo + +newtype TodoId = TodoId String deriving (Generic) +instance ToParamSchema TodoId + +type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo + +todoAPI :: Value +todoAPI = [aesonQQ| +{ + "swagger":"2.0", + "info": + { + "title": "", + "version": "" + }, + "definitions": + { + "Todo": + { + "type": "object", + "required": [ "created", "title" ], + "properties": + { + "created": { "$ref": "#/definitions/UTCTime" }, + "title": { "type": "string" }, + "summary": { "type": "string" } + } + }, + "UTCTime": + { + "type": "string", + "format": "yyyy-mm-ddThh:MM:ssZ", + "example": "2016-07-22T00:00:00Z" + } + }, + "paths": + { + "/todo/{id}": + { + "get": + { + "responses": + { + "200": + { + "schema": { "$ref":"#/definitions/Todo" }, + "description": "" + }, + "400": { "description": "Invalid `id`" } + }, + "produces": [ "application/json;charset=utf-8" ], + "parameters": + [ + { + "required": true, + "in": "path", + "name": "id", + "type": "string" + } + ] + } + } + } +} +|] + +-- ======================================================================= +-- Hackage API +-- ======================================================================= + +type HackageAPI + = HackageUserAPI + :<|> HackagePackagesAPI + +type HackageUserAPI = + "users" :> Get '[JSON] [UserSummary] + :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed + +type HackagePackagesAPI + = "packages" :> Get '[JSON] [Package] + +type Username = Text + +data UserSummary = UserSummary + { summaryUsername :: Username + , summaryUserid :: Int64 -- Word64 would make sense too + } deriving (Eq, Show, Generic) + +lowerCutPrefix :: String -> String -> String +lowerCutPrefix s = map toLower . drop (length s) + +instance ToJSON UserSummary where + toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" } + +instance ToSchema UserSummary where + declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy + & mapped.schema.example ?~ toJSON UserSummary + { summaryUsername = "JohnDoe" + , summaryUserid = 123 } + +type Group = Text + +data UserDetailed = UserDetailed + { username :: Username + , userid :: Int64 + , groups :: [Group] + } deriving (Eq, Show, Generic) +instance ToSchema UserDetailed + +newtype Package = Package { packageName :: Text } + deriving (Eq, Show, Generic) +instance ToSchema Package + +hackageSwaggerWithTags :: Swagger +hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI) + & host ?~ Host "hackage.haskell.org" Nothing + & applyTagsFor usersOps ["users" & description ?~ "Operations about user"] + & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"] + where + usersOps, packagesOps :: Traversal' Swagger Operation + usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI) + packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI) + +hackageAPI :: Value +hackageAPI = modifyValue [aesonQQ| +{ + "swagger":"2.0", + "host":"hackage.haskell.org", + "info":{ + "version":"", + "title":"" + }, + "definitions":{ + "UserDetailed":{ + "required":[ + "username", + "userid", + "groups" + ], + "type":"object", + "properties":{ + "groups":{ + "items":{ + "type":"string" + }, + "type":"array" + }, + "username":{ + "type":"string" + }, + "userid":{ + "maximum":9223372036854775807, + "minimum":-9223372036854775808, + "type":"integer", + "format":"int64" + } + } + }, + "Package":{ + "required":[ + "packageName" + ], + "type":"object", + "properties":{ + "packageName":{ + "type":"string" + } + } + }, + "UserSummary":{ + "required":[ + "username", + "userid" + ], + "type":"object", + "properties":{ + "username":{ + "type":"string" + }, + "userid":{ + "maximum":9223372036854775807, + "minimum":-9223372036854775808, + "type":"integer", + "format":"int64" + } + }, + "example":{ + "username": "JohnDoe", + "userid": 123 + } + } + }, + "paths":{ + "/users":{ + "get":{ + "responses":{ + "200":{ + "schema":{ + "items":{ + "$ref":"#/definitions/UserSummary" + }, + "type":"array" + }, + "description":"" + } + }, + "produces":[ + "application/json;charset=utf-8" + ], + "tags":[ + "users" + ] + } + }, + "/packages":{ + "get":{ + "responses":{ + "200":{ + "schema":{ + "items":{ + "$ref":"#/definitions/Package" + }, + "type":"array" + }, + "description":"" + } + }, + "produces":[ + "application/json;charset=utf-8" + ], + "tags":[ + "packages" + ] + } + }, + "/user/{username}":{ + "get":{ + "responses":{ + "400":{ + "description":"Invalid `username`" + }, + "200":{ + "schema":{ + "$ref":"#/definitions/UserDetailed" + }, + "description":"" + } + }, + "produces":[ + "application/json;charset=utf-8" + ], + "parameters":[ + { + "required":true, + "in":"path", + "name":"username", + "type":"string" + } + ], + "tags":[ + "users" + ] + } + } + }, + "tags":[ + { + "name":"users", + "description":"Operations about user" + }, + { + "name":"packages", + "description":"Query packages" + } + ] +} +|] + where + modifyValue :: Value -> Value +#if MIN_VERSION_swagger2(2,4,0) + modifyValue = id +#else + -- swagger2-2.4 preserves order of tags + -- swagger2-2.3 used Set, so they are ordered + -- packages comes before users. + -- We simply reverse, not properly sort here for simplicity: 2 elements. + modifyValue = over (key "tags" . _Array) V.reverse +#endif + + +-- ======================================================================= +-- Get/Post API (test for subOperations) +-- ======================================================================= + +type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String + +getPostSwagger :: Swagger +getPostSwagger = toSwagger (Proxy :: Proxy GetPostAPI) + & applyTagsFor getOps ["get" & description ?~ "GET operations"] + where + getOps :: Traversal' Swagger Operation + getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI) + +getPostAPI :: Value +getPostAPI = [aesonQQ| +{ + "swagger":"2.0", + "info":{ + "version":"", + "title":"" + }, + "paths":{ + "/":{ + "post":{ + "responses":{ + "200":{ + "schema":{ + "type":"string" + }, + "description":"" + } + }, + "produces":[ "application/json;charset=utf-8" ] + }, + "get":{ + "responses":{ + "200":{ + "schema":{ + "type":"string" + }, + "description":"" + } + }, + "produces":[ "application/json;charset=utf-8" ], + "tags":[ "get" ] + } + } + }, + "tags":[ + { + "name":"get", + "description":"GET operations" + } + ] +} +|] + +-- ======================================================================= +-- UVerb API +-- ======================================================================= + +data Lunch = Lunch {name :: String} + deriving (Eq, Show, Generic) + +instance ToSchema Lunch + +instance HasStatus Lunch where + type StatusOf Lunch = 200 + +data NoLunch = NoLunch + deriving (Eq, Show, Generic) + +instance ToSchema NoLunch + +instance HasStatus NoLunch where + type StatusOf NoLunch = 404 + +type UVerbAPI2 = + "lunch" :> UVerb 'GET '[JSON] '[Lunch, NoLunch] + +uverbSwagger :: Swagger +uverbSwagger = toSwagger (Proxy :: Proxy UVerbAPI2) + +uverbAPI :: Value +uverbAPI = + [aesonQQ| + { + "swagger": "2.0", + "info": { + "version": "", + "title": "" + }, + "definitions": { + "Lunch": { + "required": [ + "name" + ], + "type": "object", + "properties": { + "name": { + "type": "string" + } + } + }, + "NoLunch": { + "type": "string", + "enum": [ + "NoLunch" + ] + } + }, + "paths": { + "/lunch": { + "get": { + "responses": { + "404": { + "schema": { + "$ref": "#/definitions/NoLunch" + }, + "description": "" + }, + "200": { + "schema": { + "$ref": "#/definitions/Lunch" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ] + } + } + } +} +|] diff --git a/servant-swagger/test/Spec.hs b/servant-swagger/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-swagger/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-swagger/test/doctests.hs b/servant-swagger/test/doctests.hs new file mode 100644 index 00000000..aff961f5 --- /dev/null +++ b/servant-swagger/test/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources