git.iko.soy/typeable/openapi3
on master help sign in
.github/workflows/haskell-ci.ymlnew file+243
since splitsnapshots
unifiedsplit
@@ -0,0 +1,243 @@
1+# This GitHub workflow config has been generated by a script via
2+#
3+# haskell-ci 'github' 'cabal.project'
4+#
5+# To regenerate the script (for example after adjusting tested-with) run
6+#
7+# haskell-ci regenerate
8+#
9+# For more information, see https://github.com/haskell-CI/haskell-ci
10+#
11+# version: 0.14.3
12+#
13+# REGENDATA ("0.14.3",["github","cabal.project"])
14+#
15+name: Haskell-CI
16+on:
17+ push:
18+ branches:
19+ - master
20+ pull_request:
21+ branches:
22+ - master
23+jobs:
24+ linux:
25+ name: Haskell-CI - Linux - ${{ matrix.compiler }}
26+ runs-on: ubuntu-18.04
27+ timeout-minutes:
28+ 60
29+ container:
30+ image: buildpack-deps:focal
31+ continue-on-error: ${{ matrix.allow-failure }}
32+ strategy:
33+ matrix:
34+ include:
35+ - compiler: ghc-9.2.2
36+ compilerKind: ghc
37+ compilerVersion: 9.2.2
38+ setup-method: ghcup
39+ allow-failure: true
40+ - compiler: ghc-9.0.2
41+ compilerKind: ghc
42+ compilerVersion: 9.0.2
43+ setup-method: ghcup
44+ allow-failure: false
45+ - compiler: ghc-8.10.7
46+ compilerKind: ghc
47+ compilerVersion: 8.10.7
48+ setup-method: ghcup
49+ allow-failure: false
50+ - compiler: ghc-8.8.4
51+ compilerKind: ghc
52+ compilerVersion: 8.8.4
53+ setup-method: hvr-ppa
54+ allow-failure: false
55+ - compiler: ghc-8.6.5
56+ compilerKind: ghc
57+ compilerVersion: 8.6.5
58+ setup-method: hvr-ppa
59+ allow-failure: false
60+ - compiler: ghc-8.4.4
61+ compilerKind: ghc
62+ compilerVersion: 8.4.4
63+ setup-method: hvr-ppa
64+ allow-failure: false
65+ fail-fast: false
66+ steps:
67+ - name: apt
68+ run: |
69+ apt-get update
70+ apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
71+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
72+ mkdir -p "$HOME/.ghcup/bin"
73+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
74+ chmod a+x "$HOME/.ghcup/bin/ghcup"
75+ "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
76+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
77+ else
78+ apt-add-repository -y 'ppa:hvr/ghc'
79+ apt-get update
80+ apt-get install -y "$HCNAME"
81+ mkdir -p "$HOME/.ghcup/bin"
82+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
83+ chmod a+x "$HOME/.ghcup/bin/ghcup"
84+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
85+ fi
86+ env:
87+ HCKIND: ${{ matrix.compilerKind }}
88+ HCNAME: ${{ matrix.compiler }}
89+ HCVER: ${{ matrix.compilerVersion }}
90+ - name: Set PATH and environment variables
91+ run: |
92+ echo "$HOME/.cabal/bin" >> $GITHUB_PATH
93+ echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
94+ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
95+ echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
96+ HCDIR=/opt/$HCKIND/$HCVER
97+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
98+ HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
99+ echo "HC=$HC" >> "$GITHUB_ENV"
100+ echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
101+ echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
102+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
103+ else
104+ HC=$HCDIR/bin/$HCKIND
105+ echo "HC=$HC" >> "$GITHUB_ENV"
106+ echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
107+ echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
108+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
109+ fi
110+
111+ HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
112+ echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
113+ echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
114+ echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
115+ echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
116+ echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
117+ echo "GHCJSARITH=0" >> "$GITHUB_ENV"
118+ env:
119+ HCKIND: ${{ matrix.compilerKind }}
120+ HCNAME: ${{ matrix.compiler }}
121+ HCVER: ${{ matrix.compilerVersion }}
122+ - name: env
123+ run: |
124+ env
125+ - name: write cabal config
126+ run: |
127+ mkdir -p $CABAL_DIR
128+ cat >> $CABAL_CONFIG <<EOF
129+ remote-build-reporting: anonymous
130+ write-ghc-environment-files: never
131+ remote-repo-cache: $CABAL_DIR/packages
132+ logs-dir: $CABAL_DIR/logs
133+ world-file: $CABAL_DIR/world
134+ extra-prog-path: $CABAL_DIR/bin
135+ symlink-bindir: $CABAL_DIR/bin
136+ installdir: $CABAL_DIR/bin
137+ build-summary: $CABAL_DIR/logs/build.log
138+ store-dir: $CABAL_DIR/store
139+ install-dirs user
140+ prefix: $CABAL_DIR
141+ repository hackage.haskell.org
142+ url: http://hackage.haskell.org/
143+ EOF
144+ cat >> $CABAL_CONFIG <<EOF
145+ program-default-options
146+ ghc-options: $GHCJOBS +RTS -M3G -RTS
147+ EOF
148+ cat $CABAL_CONFIG
149+ - name: versions
150+ run: |
151+ $HC --version || true
152+ $HC --print-project-git-commit-id || true
153+ $CABAL --version || true
154+ - name: update cabal index
155+ run: |
156+ $CABAL v2-update -v
157+ - name: install cabal-plan
158+ run: |
159+ mkdir -p $HOME/.cabal/bin
160+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
161+ echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
162+ xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
163+ rm -f cabal-plan.xz
164+ chmod a+x $HOME/.cabal/bin/cabal-plan
165+ cabal-plan --version
166+ - name: checkout
167+ uses: actions/checkout@v2
168+ with:
169+ path: source
170+ - name: initial cabal.project for sdist
171+ run: |
172+ touch cabal.project
173+ echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
174+ cat cabal.project
175+ - name: sdist
176+ run: |
177+ mkdir -p sdist
178+ $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
179+ - name: unpack
180+ run: |
181+ mkdir -p unpacked
182+ find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
183+ - name: generate cabal.project
184+ run: |
185+ PKGDIR_openapi3="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/openapi3-[0-9.]*')"
186+ echo "PKGDIR_openapi3=${PKGDIR_openapi3}" >> "$GITHUB_ENV"
187+ rm -f cabal.project cabal.project.local
188+ touch cabal.project
189+ touch cabal.project.local
190+ echo "packages: ${PKGDIR_openapi3}" >> cabal.project
191+ echo "package openapi3" >> cabal.project
192+ echo " ghc-options: -Werror=missing-methods" >> cabal.project
193+ cat >> cabal.project <<EOF
194+ allow-newer: http-media:base
195+ EOF
196+ $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(openapi3)$/; }' >> cabal.project.local
197+ cat cabal.project
198+ cat cabal.project.local
199+ - name: dump install plan
200+ run: |
201+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
202+ cabal-plan
203+ - name: cache
204+ uses: actions/cache@v2
205+ with:
206+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
207+ path: ~/.cabal/store
208+ restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
209+ - name: install dependencies
210+ run: |
211+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
212+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
213+ - name: build w/o tests
214+ run: |
215+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
216+ - name: build
217+ run: |
218+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
219+ - name: tests
220+ run: |
221+ $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
222+ - name: cabal check
223+ run: |
224+ cd ${PKGDIR_openapi3} || false
225+ ${CABAL} -vnormal check
226+ - name: haddock
227+ run: |
228+ $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
229+ - name: unconstrained build
230+ run: |
231+ rm -f cabal.project.local
232+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
233+ - name: prepare for constraint sets
234+ run: |
235+ rm -f cabal.project.local
236+ - name: constraint set aeson-2
237+ run: |
238+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson >=2.0' --dependencies-only -j2 all
239+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson >=2.0' all
240+ - name: constraint set aeson-1
241+ run: |
242+ if [ $((HCNUMVER < 90200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson <2.0' --dependencies-only -j2 all ; fi
243+ if [ $((HCNUMVER < 90200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson <2.0' all ; fi
.travis.ymldeleted−149
@@ -1,149 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'openapi3.cabal'
4−#
5−# To regenerate the script (for example after adjusting tested-with) run
6−#
7−# haskell-ci regenerate
8−#
9−# For more information, see https://github.com/haskell-CI/haskell-ci
10−#
11−# version: 0.10.1
12−#
13−version: ~> 1.0
14−language: c
15−os: linux
16−dist: xenial
17−git:
18− # whether to recursively clone submodules
19− submodules: false
20−branches:
21− only:
22− - master
23−cache:
24− directories:
25− - $HOME/.cabal/packages
26− - $HOME/.cabal/store
27− - $HOME/.hlint
28−before_cache:
29− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
30− # remove files that are regenerated by 'cabal update'
31− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
32− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
33− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
34− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
35− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
36− - rm -rfv $CABALHOME/packages/head.hackage
37−jobs:
38− include:
39− - compiler: ghc-8.10.1
40− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}}
41− os: linux
42− - compiler: ghc-8.8.3
43− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}}
44− os: linux
45− - compiler: ghc-8.6.5
46− 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"]}}
47− os: linux
48− - compiler: ghc-8.4.4
49− 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"]}}
50− os: linux
51−before_install:
52− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
53− - WITHCOMPILER="-w $HC"
54− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
55− - HCPKG="$HC-pkg"
56− - unset CC
57− - CABAL=/opt/ghc/bin/cabal
58− - CABALHOME=$HOME/.cabal
59− - export PATH="$CABALHOME/bin:$PATH"
60− - TOP=$(pwd)
61− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
62− - echo $HCNUMVER
63− - CABAL="$CABAL -vnormal+nowrap"
64− - set -o pipefail
65− - TEST=--enable-tests
66− - BENCH=--enable-benchmarks
67− - HEADHACKAGE=false
68− - rm -f $CABALHOME/config
69− - |
70− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
71− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
72− echo "write-ghc-environment-files: always" >> $CABALHOME/config
73− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
74− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
75− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
76− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
77− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
78− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
79− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
80− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
81− echo "install-dirs user" >> $CABALHOME/config
82− echo " prefix: $CABALHOME" >> $CABALHOME/config
83− echo "repository hackage.haskell.org" >> $CABALHOME/config
84− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
85−install:
86− - ${CABAL} --version
87− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
88− - |
89− echo "program-default-options" >> $CABALHOME/config
90− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
91− - cat $CABALHOME/config
92− - rm -fv cabal.project cabal.project.local cabal.project.freeze
93− - travis_retry ${CABAL} v2-update -v
94− # Generate cabal.project
95− - rm -rf cabal.project cabal.project.local cabal.project.freeze
96− - touch cabal.project
97− - |
98− echo "packages: ." >> cabal.project
99− - echo 'package openapi3' >> cabal.project
100− - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project"
101− - |
102− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(openapi3)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
103− - cat cabal.project || true
104− - cat cabal.project.local || true
105− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
106− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
107− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
108− - rm cabal.project.freeze
109− - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all
110− - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all
111−script:
112− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
113− # Packaging...
114− - ${CABAL} v2-sdist all
115− # Unpacking...
116− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
117− - cd ${DISTDIR} || false
118− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
119− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
120− - PKGDIR_openapi3="$(find . -maxdepth 1 -type d -regex '.*/openapi3-[0-9.]*')"
121− # Generate cabal.project
122− - rm -rf cabal.project cabal.project.local cabal.project.freeze
123− - touch cabal.project
124− - |
125− echo "packages: ${PKGDIR_openapi3}" >> cabal.project
126− - echo 'package openapi3' >> cabal.project
127− - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project"
128− - |
129− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(openapi3)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
130− - cat cabal.project || true
131− - cat cabal.project.local || true
132− # Building...
133− # this builds all libraries and executables (without tests/benchmarks)
134− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
135− # Building with tests and benchmarks...
136− # build & run tests, build benchmarks
137− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
138− # Testing...
139− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all
140− # cabal check...
141− - (cd ${PKGDIR_openapi3} && ${CABAL} -vnormal check)
142− # haddock...
143− - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all
144− # Building without installed constraints for packages in global-db...
145− - rm -f cabal.project.local
146− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
147−
148−# REGENDATA ("0.10.1",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","openapi3.cabal"])
149−# EOF
CHANGELOG.md+47
@@ -1,3 +1,50 @@
1+Unreleased
2+----------
3+
4+3.2.2
5+-----
6+
7+- Fix bug with infinite recursion in GToSchema [#37](https://github.com/biocad/openapi3/pull/37).
8+
9+3.2.1
10+-----
11+
12+- Support aeson-2.0.3.
13+- Support GHC-9.2 (doctests still fail).
14+
15+3.2.0
16+-----
17+
18+- Support aeson-2 [#34](https://github.com/biocad/openapi3/pull/34).
19+- Use `SecurityDefinitions` type for `_componentsSecuritySchemes`
20+ [#32](https://github.com/biocad/openapi3/pull/32).
21+
22+3.1.0
23+-----
24+
25+- Use `format: date-time` for `ToParamSchema ZonedTime` instance (see
26+ [#20](https://github.com/biocad/openapi3/pull/20)).
27+- Support generating schema for any polymorphic types via `Typeable` (see
28+ [#19](https://github.com/biocad/openapi3/pull/19)).
29+- Allow `hashable-1.3.1`, prettify doctests (see [#18](https://github.com/biocad/openapi3/pull/18)).
30+
31+3.0.2.0
32+-------
33+
34+- Fix definition for HTTP security scheme (see [#10](https://github.com/biocad/openapi3/pull/10));
35+- Fix error message in `exclusiveMaximum` / `exclusiveMinimum` validation (see
36+ [#15](https://github.com/biocad/openapi3/pull/15));
37+
38+3.0.1.0
39+-------
40+
41+- Support polymorphic types in schema generator.
42+
43+3.0.0
44+-----
45+
46+- Switch to OpenAPI 3.0 specification.
47+
12.6.1
482.6.1
2-----
49-----
3
50
cabal.haskell-cinew file+11
@@ -0,0 +1,11 @@
1+branches: master
2+
3+distribution: focal
4+allow-failures: >=9.2
5+
6+constraint-set aeson-1
7+ constraints: aeson <2.0
8+ ghc: <9.2
9+
10+constraint-set aeson-2
11+ constraints: aeson >=2.0
cabal.project+2
@@ -1,2 +1,4 @@
1packages: .
1packages: .
2tests: true
2tests: true
3+
4+allow-newer: http-media:base
examples/hackage.hs+7−7
@@ -27,7 +27,7 @@ instance ToSchema UserSummary where
27 usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
27 usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
28 useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
28 useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
29 return $ NamedSchema (Just "UserSummary") $ mempty
29 return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ ?~ SwaggerObject
30+ & type_ ?~ OpenApiObject
31 & properties .~
31 & properties .~
32 [ ("summaryUsername", usernameSchema )
32 [ ("summaryUsername", usernameSchema )
33 , ("summaryUserid" , useridSchema )
33 , ("summaryUserid" , useridSchema )
@@ -47,13 +47,13 @@ data UserDetailed = UserDetailed
47newtype Package = Package { packageName :: Text }
47newtype Package = Package { packageName :: Text }
48 deriving (Generic, ToSchema)
48 deriving (Generic, ToSchema)
49
49
50−hackageSwagger :: OpenApi
50+hackageOpenApi :: OpenApi
51−hackageSwagger = spec & components.schemas .~ defs
51+hackageOpenApi = spec & components.schemas .~ defs
52 where
52 where
53− (defs, spec) = runDeclare declareHackageSwagger mempty
53+ (defs, spec) = runDeclare declareHackageOpenApi mempty
54
54
55−declareHackageSwagger :: Declare (Definitions Schema) OpenApi
55+declareHackageOpenApi :: Declare (Definitions Schema) OpenApi
56−declareHackageSwagger = do
56+declareHackageOpenApi = do
57 -- param schemas
57 -- param schemas
58 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
58 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
59
59
@@ -78,5 +78,5 @@ declareHackageSwagger = do
78 ]
78 ]
79
79
80main :: IO ()
80main :: IO ()
81−main = putStrLn . read . show . encode $ hackageSwagger
81+main = putStrLn . read . show . encode $ hackageOpenApi
82
82
openapi3.cabal+20−16
@@ -1,6 +1,6 @@
1cabal-version: >=1.10
1cabal-version: >=1.10
2name: openapi3
2name: openapi3
3−version: 3.0.0
3+version: 3.2.2
4
4
5synopsis: OpenAPI 3.0 data model
5synopsis: OpenAPI 3.0 data model
6category: Web, Swagger, OpenApi
6category: Web, Swagger, OpenApi
@@ -25,8 +25,10 @@ extra-source-files:
25tested-with:
25tested-with:
26 GHC ==8.4.4
26 GHC ==8.4.4
27 || ==8.6.5
27 || ==8.6.5
28− || ==8.8.3
28+ || ==8.8.4
29− || ==8.10.1
29+ || ==8.10.7
30+ || ==9.0.2
31+ || ==9.2.2
30
32
31custom-setup
33custom-setup
32 setup-depends:
34 setup-depends:
@@ -55,34 +57,36 @@ library
55 Data.OpenApi.Internal.AesonUtils
57 Data.OpenApi.Internal.AesonUtils
56 Data.OpenApi.Internal.TypeShape
58 Data.OpenApi.Internal.TypeShape
57
59
60+ Data.OpenApi.Aeson.Compat
61+
58 -- GHC boot libraries
62 -- GHC boot libraries
59 build-depends:
63 build-depends:
60− base >=4.11.1.0 && <4.15
64+ base >=4.11.1.0 && <4.17
61− , bytestring >=0.10.8.2 && <0.11
65+ , bytestring >=0.10.8.2 && <0.12
62 , containers >=0.5.11.0 && <0.7
66 , containers >=0.5.11.0 && <0.7
63− , template-haskell >=2.13.0.0 && <2.17
67+ , template-haskell >=2.13.0.0 && <2.19
64− , time >=1.8.0.2 && <1.10
68+ , time >=1.8.0.2 && <1.14
65 , transformers >=0.5.5.0 && <0.6
69 , transformers >=0.5.5.0 && <0.6
66
70
67 build-depends:
71 build-depends:
68 mtl >=2.2.2 && <2.3
72 mtl >=2.2.2 && <2.3
69− , text >=1.2.3.1 && <1.3
73+ , text >=1.2.3.1 && <2.1
70
74
71 -- other dependencies
75 -- other dependencies
72 build-depends:
76 build-depends:
73− base-compat-batteries >=0.11.1 && <0.12
77+ base-compat-batteries >=0.11.1 && <0.13
74− , aeson >=1.4.2.0 && <1.6
78+ , aeson >=1.4.2.0 && <1.6 || >=2.0.1.0 && < 2.1
75 , aeson-pretty >=0.8.7 && <0.9
79 , aeson-pretty >=0.8.7 && <0.9
76 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
80 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
77 , cookie >=0.4.3 && <0.5
81 , cookie >=0.4.3 && <0.5
78 , generics-sop >=0.5.1.0 && <0.6
82 , generics-sop >=0.5.1.0 && <0.6
79− , hashable >=1.2.7.0 && <1.4
83+ , hashable >=1.2.7.0 && <1.5
80 , http-media >=0.8.0.0 && <0.9
84 , http-media >=0.8.0.0 && <0.9
81 , insert-ordered-containers >=0.2.3 && <0.3
85 , insert-ordered-containers >=0.2.3 && <0.3
82− , lens >=4.16.1 && <4.20
86+ , lens >=4.16.1 && <5.2
83 , network >=2.6.3.5 && <3.2
87 , network >=2.6.3.5 && <3.2
84− , optics-core >=0.2 && <0.4
88+ , optics-core >=0.2 && <0.5
85− , optics-th >=0.2 && <0.4
89+ , optics-th >=0.2 && <0.5
86 , scientific >=0.3.6.2 && <0.4
90 , scientific >=0.3.6.2 && <0.4
87 , unordered-containers >=0.2.9.0 && <0.3
91 , unordered-containers >=0.2.9.0 && <0.3
88 , uuid-types >=1.0.3 && <1.1
92 , uuid-types >=1.0.3 && <1.1
@@ -118,14 +122,14 @@ test-suite spec
118
122
119 -- test-suite only dependencies
123 -- test-suite only dependencies
120 build-depends:
124 build-depends:
121− hspec >=2.5.5 && <2.8
125+ hspec >=2.5.5 && <2.10
122 , HUnit >=1.6.0.0 && <1.7
126 , HUnit >=1.6.0.0 && <1.7
123 , quickcheck-instances >=0.3.19 && <0.14
127 , quickcheck-instances >=0.3.19 && <0.14
124 , utf8-string >=1.0.1.1 && <1.1
128 , utf8-string >=1.0.1.1 && <1.1
125
129
126 -- https://github.com/haskell/cabal/issues/3708
130 -- https://github.com/haskell/cabal/issues/3708
127 build-tool-depends:
131 build-tool-depends:
128− hspec-discover:hspec-discover >=2.5.5 && <2.8
132+ hspec-discover:hspec-discover >=2.5.5 && <2.10
129
133
130 other-modules:
134 other-modules:
131 SpecCommon
135 SpecCommon
src/Data/OpenApi.hs+146−25
@@ -56,7 +56,7 @@ module Data.OpenApi (
56 TagName,
56 TagName,
57
57
58 -- ** Types and formats
58 -- ** Types and formats
59− SwaggerType(..),
59+ OpenApiType(..),
60 Format,
60 Format,
61 Definitions,
61 Definitions,
62 Style(..),
62 Style(..),
@@ -75,7 +75,7 @@ module Data.OpenApi (
75 -- ** Schemas
75 -- ** Schemas
76 Schema(..),
76 Schema(..),
77 NamedSchema(..),
77 NamedSchema(..),
78− SwaggerItems(..),
78+ OpenApiItems(..),
79 Xml(..),
79 Xml(..),
80 Pattern,
80 Pattern,
81 AdditionalProperties(..),
81 AdditionalProperties(..),
@@ -91,6 +91,7 @@ module Data.OpenApi (
91 -- ** Security
91 -- ** Security
92 SecurityScheme(..),
92 SecurityScheme(..),
93 SecuritySchemeType(..),
93 SecuritySchemeType(..),
94+ HttpSchemeType(..),
94 SecurityDefinitions(..),
95 SecurityDefinitions(..),
95 SecurityRequirement(..),
96 SecurityRequirement(..),
96
97
@@ -136,6 +137,7 @@ import Data.OpenApi.Internal
136-- >>> import Data.Proxy
137-- >>> import Data.Proxy
137-- >>> import GHC.Generics
138-- >>> import GHC.Generics
138-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
139-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
140+-- >>> import Data.OpenApi.Internal.Utils
139-- >>> :set -XDeriveGeneric
141-- >>> :set -XDeriveGeneric
140-- >>> :set -XOverloadedStrings
142-- >>> :set -XOverloadedStrings
141-- >>> :set -XOverloadedLists
143-- >>> :set -XOverloadedLists
@@ -152,8 +154,16 @@ import Data.OpenApi.Internal
152--
154--
153-- In this library you can use @'mempty'@ for a default/empty value. For instance:
155-- In this library you can use @'mempty'@ for a default/empty value. For instance:
154--
156--
155−-- >>> BSL.putStrLn $ encode (mempty :: OpenApi)
157+-- >>> BSL.putStrLn $ encodePretty (mempty :: OpenApi)
158+-- {
159+-- "components": {},
160+-- "info": {
161+-- "title": "",
162+-- "version": ""
163+-- },
156−-- {"openapi":"3.0.0","info":{"version":"","title":""},"components":{}}
164+-- "openapi": "3.0.0",
165+-- "paths": {}
166+-- }
157--
167--
158-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty.
168-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty.
159-- That is because these properties are actually required ones.
169-- That is because these properties are actually required ones.
@@ -161,13 +171,20 @@ import Data.OpenApi.Internal
161-- You /should/ always override the default (empty) value for these properties,
171-- You /should/ always override the default (empty) value for these properties,
162-- although it is not strictly necessary:
172-- although it is not strictly necessary:
163--
173--
164−-- >>> BSL.putStrLn $ encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }
174+-- >>> BSL.putStrLn $ encodePretty mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }
175+-- {
176+-- "title": "Todo API",
165−-- {"version":"1.0","title":"Todo API"}
177+-- "version": "1.0"
178+-- }
166--
179--
167-- You can merge two values using @'mappend'@ or its infix version @('<>')@:
180-- You can merge two values using @'mappend'@ or its infix version @('<>')@:
168--
181--
169−-- >>> BSL.putStrLn $ encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }
182+-- >>> BSL.putStrLn $ encodePretty $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }
170−-- {"version":"1.0","title":"Todo API"}
183+-- {
184+-- "title": "Todo API",
185+-- "version": "1.0"
186+-- }
187+
171--
188--
172-- This can be useful for combining specifications of endpoints into a whole API specification:
189-- This can be useful for combining specifications of endpoints into a whole API specification:
173--
190--
@@ -193,14 +210,48 @@ import Data.OpenApi.Internal
193-- make it fairly simple to construct/modify any part of the specification:
210-- make it fairly simple to construct/modify any part of the specification:
194--
211--
195-- >>> :{
212-- >>> :{
196−-- BSL.putStrLn $ encode $ (mempty :: OpenApi)
213+-- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)
197−-- & components . schemas .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
214+-- & components . schemas .~ [ ("User", mempty & type_ ?~ OpenApiString) ]
198-- & paths .~
215-- & paths .~
199-- [ ("/user", mempty & get ?~ (mempty
216-- [ ("/user", mempty & get ?~ (mempty
200-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User")))
217-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User")))
201-- & at 404 ?~ "User info not found")) ]
218-- & at 404 ?~ "User info not found")) ]
202-- :}
219-- :}
203−-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}}
220+-- {
221+-- "components": {
222+-- "schemas": {
223+-- "User": {
224+-- "type": "string"
225+-- }
226+-- }
227+-- },
228+-- "info": {
229+-- "title": "",
230+-- "version": ""
231+-- },
232+-- "openapi": "3.0.0",
233+-- "paths": {
234+-- "/user": {
235+-- "get": {
236+-- "responses": {
237+-- "200": {
238+-- "content": {
239+-- "application/json": {
240+-- "schema": {
241+-- "$ref": "#/components/schemas/User"
242+-- }
243+-- }
244+-- },
245+-- "description": "OK"
246+-- },
247+-- "404": {
248+-- "description": "User info not found"
249+-- }
250+-- }
251+-- }
252+-- }
253+-- }
254+-- }
204--
255--
205-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
256-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
206-- which produces @application/json@ output. It should respond with code @200@ and body specified
257-- which produces @application/json@ output. It should respond with code @200@ and body specified
@@ -212,23 +263,34 @@ import Data.OpenApi.Internal
212-- common field is @'description'@. Many components of a Swagger specification
263-- common field is @'description'@. Many components of a Swagger specification
213-- can have descriptions, and you can use the same name for them:
264-- can have descriptions, and you can use the same name for them:
214--
265--
215−-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & description .~ "No content"
266+-- >>> BSL.putStrLn $ encodePretty $ (mempty :: Response) & description .~ "No content"
267+-- {
216−-- {"description":"No content"}
268+-- "description": "No content"
269+-- }
217-- >>> :{
270-- >>> :{
218−-- BSL.putStrLn $ encode $ (mempty :: Schema)
271+-- BSL.putStrLn $ encodePretty $ (mempty :: Schema)
219−-- & type_ ?~ SwaggerBoolean
272+-- & type_ ?~ OpenApiBoolean
220-- & description ?~ "To be or not to be"
273-- & description ?~ "To be or not to be"
221-- :}
274-- :}
275+-- {
222−-- {"type":"boolean","description":"To be or not to be"}
276+-- "description": "To be or not to be",
277+-- "type": "boolean"
278+-- }
223--
279--
224-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
280-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
225-- have direct access to it via @'at' code@. Example:
281-- have direct access to it via @'at' code@. Example:
226--
282--
227-- >>> :{
283-- >>> :{
228−-- BSL.putStrLn $ encode $ (mempty :: Operation)
284+-- BSL.putStrLn $ encodePretty $ (mempty :: Operation)
229-- & at 404 ?~ "Not found"
285-- & at 404 ?~ "Not found"
230-- :}
286-- :}
287+-- {
288+-- "responses": {
289+-- "404": {
231−-- {"responses":{"404":{"description":"Not found"}}}
290+-- "description": "Not found"
291+-- }
292+-- }
293+-- }
232--
294--
233-- You might've noticed that @'type_'@ has an extra underscore in its name
295-- You might've noticed that @'type_'@ has an extra underscore in its name
234-- compared to, say, @'description'@ field accessor.
296-- compared to, say, @'description'@ field accessor.
@@ -244,7 +306,7 @@ import Data.OpenApi.Internal
244-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification.
306-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification.
245--
307--
246-- @'ParamSchema' t@ specifies all the common properties, available for every data schema.
308-- @'ParamSchema' t@ specifies all the common properties, available for every data schema.
247−-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'SwaggerType'@ and @'SwaggerItems'@).
309+-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'OpenApiType'@ and @'OpenApiItems'@).
248--
310--
249-- @'Schema'@ is used for request and response bodies and allows specifying objects
311-- @'Schema'@ is used for request and response bodies and allows specifying objects
250-- with properties in addition to what @'ParamSchema'@ provides.
312-- with properties in addition to what @'ParamSchema'@ provides.
@@ -275,10 +337,27 @@ import Data.OpenApi.Internal
275-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic
337-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic
276-- >>> instance ToJSON Person
338-- >>> instance ToJSON Person
277-- >>> instance ToSchema Person
339-- >>> instance ToSchema Person
278−-- >>> BSL.putStrLn $ encode (Person "David" 28)
340+-- >>> BSL.putStrLn $ encodePretty (Person "David" 28)
341+-- {
342+-- "age": 28,
279−-- {"age":28,"name":"David"}
343+-- "name": "David"
344+-- }
280−-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person)
345+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Person)
281−-- {"required":["name","age"],"type":"object","properties":{"age":{"type":"integer"},"name":{"type":"string"}}}
346+-- {
347+-- "properties": {
348+-- "age": {
349+-- "type": "integer"
350+-- },
351+-- "name": {
352+-- "type": "string"
353+-- }
354+-- },
355+-- "required": [
356+-- "name",
357+-- "age"
358+-- ],
359+-- "type": "object"
360+-- }
282--
361--
283-- This package implements OpenAPI 3.0 spec, which supports @oneOf@ in schemas, allowing any sum types
362-- This package implements OpenAPI 3.0 spec, which supports @oneOf@ in schemas, allowing any sum types
284-- to be faithfully represented. All sum encodings supported by @aeson@ are supported here as well, with
363-- to be faithfully represented. All sum encodings supported by @aeson@ are supported here as well, with
@@ -289,8 +368,50 @@ import Data.OpenApi.Internal
289-- >>> data Error = ErrorNoUser { userId :: Int } | ErrorAccessDenied { requiredPermission :: String } deriving Generic
368-- >>> data Error = ErrorNoUser { userId :: Int } | ErrorAccessDenied { requiredPermission :: String } deriving Generic
290-- >>> instance ToJSON Error
369-- >>> instance ToJSON Error
291-- >>> instance ToSchema Error
370-- >>> instance ToSchema Error
292−-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Error)
371+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Error)
293−-- {"oneOf":[{"required":["userId","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorNoUser"]},"userId":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}},{"required":["requiredPermission","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorAccessDenied"]},"requiredPermission":{"type":"string"}}}],"type":"object"}
372+-- {
373+-- "oneOf": [
374+-- {
375+-- "properties": {
376+-- "tag": {
377+-- "enum": [
378+-- "ErrorNoUser"
379+-- ],
380+-- "type": "string"
381+-- },
382+-- "userId": {
383+-- "maximum": 9223372036854775807,
384+-- "minimum": -9223372036854775808,
385+-- "type": "integer"
386+-- }
387+-- },
388+-- "required": [
389+-- "userId",
390+-- "tag"
391+-- ],
392+-- "type": "object"
393+-- },
394+-- {
395+-- "properties": {
396+-- "requiredPermission": {
397+-- "type": "string"
398+-- },
399+-- "tag": {
400+-- "enum": [
401+-- "ErrorAccessDenied"
402+-- ],
403+-- "type": "string"
404+-- }
405+-- },
406+-- "required": [
407+-- "requiredPermission",
408+-- "tag"
409+-- ],
410+-- "type": "object"
411+-- }
412+-- ],
413+-- "type": "object"
414+-- }
294
415
295-- $manipulation
416-- $manipulation
296-- Sometimes you have to work with an imported or generated @'Swagger'@.
417-- Sometimes you have to work with an imported or generated @'Swagger'@.
src/Data/OpenApi/Aeson/Compat.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# LANGUAGE CPP #-}
2+
3+module Data.OpenApi.Aeson.Compat where
4+
5+#if MIN_VERSION_aeson(2,0,0)
6+import Data.Aeson (Key)
7+import qualified Data.Aeson.Key as Key
8+import qualified Data.Aeson.KeyMap as KeyMap
9+#else
10+import qualified Data.HashMap.Strict as HM
11+#endif
12+import Data.Bifunctor (first)
13+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
14+import qualified Data.Text as T
15+
16+#if MIN_VERSION_aeson(2,0,0)
17+deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v
18+deleteKey = KeyMap.delete
19+
20+objectToList :: KeyMap.KeyMap v -> [(Key, v)]
21+objectToList = KeyMap.toList
22+
23+objectKeys :: KeyMap.KeyMap v -> [T.Text]
24+objectKeys = map Key.toText . KeyMap.keys
25+
26+stringToKey :: String -> Key
27+stringToKey = Key.fromString
28+
29+keyToString :: Key -> String
30+keyToString = Key.toString
31+
32+keyToText :: Key -> T.Text
33+keyToText = Key.toText
34+
35+toInsOrdHashMap :: KeyMap.KeyMap v -> InsOrdHashMap.InsOrdHashMap T.Text v
36+toInsOrdHashMap = InsOrdHashMap.fromList . fmap (first Key.toText) . KeyMap.toList
37+
38+fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> KeyMap.KeyMap v
39+fromInsOrdHashMap = KeyMap.fromList . fmap (first Key.fromText) . InsOrdHashMap.toList
40+
41+lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v
42+lookupKey = KeyMap.lookup . Key.fromText
43+
44+hasKey :: T.Text -> KeyMap.KeyMap a -> Bool
45+hasKey = KeyMap.member . Key.fromText
46+#else
47+deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v
48+deleteKey = HM.delete
49+
50+objectToList :: HM.HashMap T.Text v -> [(T.Text, v)]
51+objectToList = HM.toList
52+
53+objectKeys :: HM.HashMap T.Text v -> [T.Text]
54+objectKeys = HM.keys
55+
56+stringToKey :: String -> T.Text
57+stringToKey = T.pack
58+
59+keyToString :: T.Text -> String
60+keyToString = T.unpack
61+
62+keyToText :: T.Text -> T.Text
63+keyToText = id
64+
65+toInsOrdHashMap :: HM.HashMap T.Text v -> InsOrdHashMap.InsOrdHashMap T.Text v
66+toInsOrdHashMap = InsOrdHashMap.fromHashMap
67+
68+fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> HM.HashMap T.Text v
69+fromInsOrdHashMap = InsOrdHashMap.toHashMap
70+
71+lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v
72+lookupKey = HM.lookup
73+
74+hasKey :: T.Text -> HM.HashMap T.Text a -> Bool
75+hasKey = HM.member
76+#endif
src/Data/OpenApi/Internal.hs+119−52
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
@@ -21,6 +22,9 @@ import Prelude.Compat
21import Control.Applicative
22import Control.Applicative
22import Control.Lens ((&), (.~), (?~))
23import Control.Lens ((&), (.~), (?~))
23import Data.Aeson hiding (Encoding)
24import Data.Aeson hiding (Encoding)
25+#if MIN_VERSION_aeson(2,0,0)
26+import qualified Data.Aeson.KeyMap as KeyMap
27+#endif
24import qualified Data.Aeson.Types as JSON
28import qualified Data.Aeson.Types as JSON
25import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable,
29import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable,
26 constrIndex, mkConstr, mkDataType)
30 constrIndex, mkConstr, mkDataType)
@@ -45,21 +49,19 @@ import Text.Read (readMaybe)
45import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
49import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
46import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
50import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
47
51
48−import Generics.SOP.TH (deriveGeneric)
52+import Data.OpenApi.Aeson.Compat (deleteKey)
49−import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToJSON
53+import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..),
50− ,sopSwaggerGenericToJSONWithOpts
51− ,sopSwaggerGenericParseJSON
52− ,HasSwaggerAesonOptions(..)
53− ,AesonDefaultValue(..)
54− ,mkSwaggerAesonOptions
54+ mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject,
55− ,saoAdditionalPairs
55+ sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding,
56− ,saoSubObject)
56+ sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts)
57import Data.OpenApi.Internal.Utils
57import Data.OpenApi.Internal.Utils
58−import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding)
58+import Generics.SOP.TH (deriveGeneric)
59
59
60-- $setup
60-- $setup
61-- >>> :seti -XDataKinds
61-- >>> :seti -XDataKinds
62-- >>> import Data.Aeson
62-- >>> import Data.Aeson
63+-- >>> import Data.ByteString.Lazy.Char8 as BSL
64+-- >>> import Data.OpenApi.Internal.Utils
63
65
64-- | A list of definitions that can be used in references.
66-- | A list of definitions that can be used in references.
65type Definitions = InsOrdHashMap Text
67type Definitions = InsOrdHashMap Text
@@ -194,7 +196,7 @@ data Components = Components
194 , _componentsExamples :: Definitions Example
196 , _componentsExamples :: Definitions Example
195 , _componentsRequestBodies :: Definitions RequestBody
197 , _componentsRequestBodies :: Definitions RequestBody
196 , _componentsHeaders :: Definitions Header
198 , _componentsHeaders :: Definitions Header
197− , _componentsSecuritySchemes :: Definitions SecurityScheme
199+ , _componentsSecuritySchemes :: SecurityDefinitions
198 , _componentsLinks :: Definitions Link
200 , _componentsLinks :: Definitions Link
199 , _componentsCallbacks :: Definitions Callback
201 , _componentsCallbacks :: Definitions Callback
200 } deriving (Eq, Show, Generic, Data, Typeable)
202 } deriving (Eq, Show, Generic, Data, Typeable)
@@ -335,7 +337,7 @@ data RequestBody = RequestBody
335 -- | The content of the request body.
337 -- | The content of the request body.
336 -- The key is a media type or media type range and the value describes it.
338 -- The key is a media type or media type range and the value describes it.
337 -- For requests that match multiple keys, only the most specific key is applicable.
339 -- For requests that match multiple keys, only the most specific key is applicable.
338− -- e.g. @text/plain@ overrides @text/*@
340+ -- e.g. @text/plain@ overrides @text/\*@
339 , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject
341 , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject
340
342
341 -- | Determines if the request body is required in the request.
343 -- | Determines if the request body is required in the request.
@@ -392,7 +394,7 @@ data Encoding = Encoding
392 -- for other primitive types – @text/plain@; for object - @application/json@;
394 -- for other primitive types – @text/plain@; for object - @application/json@;
393 -- for array – the default is defined based on the inner type.
395 -- for array – the default is defined based on the inner type.
394 -- The value can be a specific media type (e.g. @application/json@),
396 -- The value can be a specific media type (e.g. @application/json@),
395− -- a wildcard media type (e.g. @image/*@), or a comma-separated list of the two types.
397+ -- a wildcard media type (e.g. @image/\*@), or a comma-separated list of the two types.
396 _encodingContentType :: Maybe MediaType
398 _encodingContentType :: Maybe MediaType
397
399
398 -- | A map allowing additional information to be provided as headers,
400 -- | A map allowing additional information to be provided as headers,
@@ -571,27 +573,27 @@ data Link = Link
571 , _linkServer :: Maybe Server
573 , _linkServer :: Maybe Server
572 } deriving (Eq, Show, Generic, Typeable, Data)
574 } deriving (Eq, Show, Generic, Typeable, Data)
573
575
574−-- | Items for @'SwaggerArray'@ schemas.
576+-- | Items for @'OpenApiArray'@ schemas.
575--
577--
576-- __Warning__: OpenAPI 3.0 does not support tuple arrays. However, OpenAPI 3.1 will, as
578-- __Warning__: OpenAPI 3.0 does not support tuple arrays. However, OpenAPI 3.1 will, as
577-- it will incorporate Json Schema mostly verbatim.
579-- it will incorporate Json Schema mostly verbatim.
578--
580--
579−-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s.
581+-- @'OpenApiItemsObject'@ should be used to specify homogenous array @'Schema'@s.
580--
582--
581−-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
583+-- @'OpenApiItemsArray'@ should be used to specify tuple @'Schema'@s.
582−data SwaggerItems where
584+data OpenApiItems where
583− SwaggerItemsObject :: Referenced Schema -> SwaggerItems
585+ OpenApiItemsObject :: Referenced Schema -> OpenApiItems
584− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems
586+ OpenApiItemsArray :: [Referenced Schema] -> OpenApiItems
585 deriving (Eq, Show, Typeable, Data)
587 deriving (Eq, Show, Typeable, Data)
586
588
587−data SwaggerType where
589+data OpenApiType where
588− SwaggerString :: SwaggerType
590+ OpenApiString :: OpenApiType
589− SwaggerNumber :: SwaggerType
591+ OpenApiNumber :: OpenApiType
590− SwaggerInteger :: SwaggerType
592+ OpenApiInteger :: OpenApiType
591− SwaggerBoolean :: SwaggerType
593+ OpenApiBoolean :: OpenApiType
592− SwaggerArray :: SwaggerType
594+ OpenApiArray :: OpenApiType
593− SwaggerNull :: SwaggerType
595+ OpenApiNull :: OpenApiType
594− SwaggerObject :: SwaggerType
596+ OpenApiObject :: OpenApiType
595 deriving (Eq, Show, Typeable, Generic, Data)
597 deriving (Eq, Show, Typeable, Generic, Data)
596
598
597data ParamLocation
599data ParamLocation
@@ -643,9 +645,9 @@ data Schema = Schema
643 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
645 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
644 _schemaDefault :: Maybe Value
646 _schemaDefault :: Maybe Value
645
647
646− , _schemaType :: Maybe SwaggerType
648+ , _schemaType :: Maybe OpenApiType
647 , _schemaFormat :: Maybe Format
649 , _schemaFormat :: Maybe Format
648− , _schemaItems :: Maybe SwaggerItems
650+ , _schemaItems :: Maybe OpenApiItems
649 , _schemaMaximum :: Maybe Scientific
651 , _schemaMaximum :: Maybe Scientific
650 , _schemaExclusiveMaximum :: Maybe Bool
652 , _schemaExclusiveMaximum :: Maybe Bool
651 , _schemaMinimum :: Maybe Scientific
653 , _schemaMinimum :: Maybe Scientific
@@ -680,7 +682,7 @@ data NamedSchema = NamedSchema
680
682
681data Xml = Xml
683data Xml = Xml
682 { -- | Replaces the name of the element/attribute used for the described schema property.
684 { -- | Replaces the name of the element/attribute used for the described schema property.
683− -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
685+ -- When defined within the @'OpenApiItems'@ (items), it will affect the name of the individual XML elements within the list.
684 -- When defined alongside type being array (outside the items),
686 -- When defined alongside type being array (outside the items),
685 -- it will affect the wrapping element and only if wrapped is true.
687 -- it will affect the wrapping element and only if wrapped is true.
686 -- If wrapped is false, it will be ignored.
688 -- If wrapped is false, it will be ignored.
@@ -732,7 +734,7 @@ data Response = Response
732 -- | A map containing descriptions of potential response payloads.
734 -- | A map containing descriptions of potential response payloads.
733 -- The key is a media type or media type range and the value describes it.
735 -- The key is a media type or media type range and the value describes it.
734 -- For responses that match multiple keys, only the most specific key is applicable.
736 -- For responses that match multiple keys, only the most specific key is applicable.
735− -- e.g. @text/plain@ overrides @text/*@.
737+ -- e.g. @text/plain@ overrides @text/\*@.
736 , _responseContent :: InsOrdHashMap MediaType MediaTypeObject
738 , _responseContent :: InsOrdHashMap MediaType MediaTypeObject
737
739
738 -- | Maps a header name to its definition.
740 -- | Maps a header name to its definition.
@@ -838,8 +840,50 @@ data OAuth2Flows = OAuth2Flows
838 , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow)
840 , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow)
839 } deriving (Eq, Show, Generic, Data, Typeable)
841 } deriving (Eq, Show, Generic, Data, Typeable)
840
842
843+type BearerFormat = Text
844+
845+data HttpSchemeType
846+ = HttpSchemeBearer (Maybe BearerFormat)
847+ | HttpSchemeBasic
848+ | HttpSchemeCustom Text
849+ deriving (Eq, Show, Generic, Data, Typeable)
850+
851+-- |
852+--
853+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer Nothing))
854+-- {
855+-- "scheme": "bearer",
856+-- "type": "http"
857+-- }
858+--
859+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer (Just "jwt")))
860+-- {
861+-- "bearerFormat": "jwt",
862+-- "scheme": "bearer",
863+-- "type": "http"
864+-- }
865+--
866+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp HttpSchemeBasic)
867+-- {
868+-- "scheme": "basic",
869+-- "type": "http"
870+-- }
871+--
872+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeCustom "CANARY"))
873+-- {
874+-- "scheme": "CANARY",
875+-- "type": "http"
876+-- }
877+--
878+-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie))
879+-- {
880+-- "in": "cookie",
881+-- "name": "id",
882+-- "type": "apiKey"
883+-- }
884+--
841data SecuritySchemeType
885data SecuritySchemeType
842− = SecuritySchemeHttp
886+ = SecuritySchemeHttp HttpSchemeType
843 | SecuritySchemeApiKey ApiKeyParams
887 | SecuritySchemeApiKey ApiKeyParams
844 | SecuritySchemeOAuth2 OAuth2Flows
888 | SecuritySchemeOAuth2 OAuth2Flows
845 | SecuritySchemeOpenIdConnect URL
889 | SecuritySchemeOpenIdConnect URL
@@ -1081,12 +1125,13 @@ instance SwaggerMonoid Response
1081instance SwaggerMonoid ExternalDocs
1125instance SwaggerMonoid ExternalDocs
1082instance SwaggerMonoid Operation
1126instance SwaggerMonoid Operation
1083instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
1127instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
1128+instance SwaggerMonoid SecurityDefinitions
1084
1129
1085instance SwaggerMonoid MimeList
1130instance SwaggerMonoid MimeList
1086deriving instance SwaggerMonoid URL
1131deriving instance SwaggerMonoid URL
1087
1132
1088−instance SwaggerMonoid SwaggerType where
1133+instance SwaggerMonoid OpenApiType where
1089− swaggerMempty = SwaggerString
1134+ swaggerMempty = OpenApiString
1090 swaggerMappend _ y = y
1135 swaggerMappend _ y = y
1091
1136
1092instance SwaggerMonoid ParamLocation where
1137instance SwaggerMonoid ParamLocation where
@@ -1109,7 +1154,7 @@ instance Monoid a => SwaggerMonoid (Referenced a) where
1109instance ToJSON Style where
1154instance ToJSON Style where
1110 toJSON = genericToJSON (jsonPrefix "Style")
1155 toJSON = genericToJSON (jsonPrefix "Style")
1111
1156
1112−instance ToJSON SwaggerType where
1157+instance ToJSON OpenApiType where
1113 toJSON = genericToJSON (jsonPrefix "Swagger")
1158 toJSON = genericToJSON (jsonPrefix "Swagger")
1114
1159
1115instance ToJSON ParamLocation where
1160instance ToJSON ParamLocation where
@@ -1164,7 +1209,7 @@ instance ToJSON OAuth2AuthorizationCodeFlow where
1164instance FromJSON Style where
1209instance FromJSON Style where
1165 parseJSON = genericParseJSON (jsonPrefix "Style")
1210 parseJSON = genericParseJSON (jsonPrefix "Style")
1166
1211
1167−instance FromJSON SwaggerType where
1212+instance FromJSON OpenApiType where
1168 parseJSON = genericParseJSON (jsonPrefix "Swagger")
1213 parseJSON = genericParseJSON (jsonPrefix "Swagger")
1169
1214
1170instance FromJSON ParamLocation where
1215instance FromJSON ParamLocation where
@@ -1229,8 +1274,19 @@ instance ToJSON OAuth2Flows where
1229 toEncoding = sopSwaggerGenericToEncoding
1274 toEncoding = sopSwaggerGenericToEncoding
1230
1275
1231instance ToJSON SecuritySchemeType where
1276instance ToJSON SecuritySchemeType where
1232− toJSON SecuritySchemeHttp
1277+ toJSON (SecuritySchemeHttp ty) = case ty of
1278+ HttpSchemeBearer mFmt ->
1279+ object $ [ "type" .= ("http" :: Text)
1280+ , "scheme" .= ("bearer" :: Text)
1281+ ] <> maybe [] (\t -> ["bearerFormat" .= t]) mFmt
1282+ HttpSchemeBasic ->
1283+ object [ "type" .= ("http" :: Text)
1284+ , "scheme" .= ("basic" :: Text)
1285+ ]
1286+ HttpSchemeCustom t ->
1233− = object [ "type" .= ("http" :: Text) ]
1287+ object [ "type" .= ("http" :: Text)
1288+ , "scheme" .= t
1289+ ]
1234 toJSON (SecuritySchemeApiKey params)
1290 toJSON (SecuritySchemeApiKey params)
1235 = toJSON params
1291 = toJSON params
1236 <+> object [ "type" .= ("apiKey" :: Text) ]
1292 <+> object [ "type" .= ("apiKey" :: Text) ]
@@ -1269,17 +1325,21 @@ instance ToJSON Header where
1269-- | As for nullary schema for 0-arity type constructors, see
1325-- | As for nullary schema for 0-arity type constructors, see
1270-- <https://github.com/GetShopTV/swagger2/issues/167>.
1326-- <https://github.com/GetShopTV/swagger2/issues/167>.
1271--
1327--
1272−-- >>> encode (SwaggerItemsArray [])
1328+-- >>> BSL.putStrLn $ encodePretty (OpenApiItemsArray [])
1329+-- {
1330+-- "example": [],
1331+-- "items": {},
1273−-- "{\"example\":[],\"items\":{},\"maxItems\":0}"
1332+-- "maxItems": 0
1333+-- }
1274--
1334--
1275−instance ToJSON SwaggerItems where
1335+instance ToJSON OpenApiItems where
1276− toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1336+ toJSON (OpenApiItemsObject x) = object [ "items" .= x ]
1277− toJSON (SwaggerItemsArray []) = object
1337+ toJSON (OpenApiItemsArray []) = object
1278 [ "items" .= object []
1338 [ "items" .= object []
1279 , "maxItems" .= (0 :: Int)
1339 , "maxItems" .= (0 :: Int)
1280 , "example" .= Array mempty
1340 , "example" .= Array mempty
1281 ]
1341 ]
1282− toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
1342+ toJSON (OpenApiItemsArray x) = object [ "items" .= x ]
1283
1343
1284instance ToJSON Components where
1344instance ToJSON Components where
1285 toJSON = sopSwaggerGenericToJSON
1345 toJSON = sopSwaggerGenericToJSON
@@ -1379,7 +1439,12 @@ instance FromJSON SecuritySchemeType where
1379 parseJSON js@(Object o) = do
1439 parseJSON js@(Object o) = do
1380 (t :: Text) <- o .: "type"
1440 (t :: Text) <- o .: "type"
1381 case t of
1441 case t of
1442+ "http" -> do
1443+ scheme <- o .: "scheme"
1382− "http" -> pure SecuritySchemeHttp
1444+ SecuritySchemeHttp <$> case scheme of
1445+ "bearer" -> HttpSchemeBearer <$> (o .:! "bearerFormat")
1446+ "basic" -> pure HttpSchemeBasic
1447+ t -> pure $ HttpSchemeCustom t
1383 "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1448 "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1384 "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows")
1449 "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows")
1385 "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl")
1450 "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl")
@@ -1399,7 +1464,7 @@ instance FromJSON Schema where
1399 parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1464 parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1400 where nullaryCleanup :: Schema -> Schema
1465 where nullaryCleanup :: Schema -> Schema
1401 nullaryCleanup s =
1466 nullaryCleanup s =
1402− if _schemaItems s == Just (SwaggerItemsArray [])
1467+ if _schemaItems s == Just (OpenApiItemsArray [])
1403 then s { _schemaExample = Nothing
1468 then s { _schemaExample = Nothing
1404 , _schemaMaxItems = Nothing
1469 , _schemaMaxItems = Nothing
1405 }
1470 }
@@ -1408,11 +1473,11 @@ instance FromJSON Schema where
1408instance FromJSON Header where
1473instance FromJSON Header where
1409 parseJSON = sopSwaggerGenericParseJSON
1474 parseJSON = sopSwaggerGenericParseJSON
1410
1475
1411−instance FromJSON SwaggerItems where
1476+instance FromJSON OpenApiItems where
1412 parseJSON js@(Object obj)
1477 parseJSON js@(Object obj)
1413− | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1478+ | null obj = pure $ OpenApiItemsArray [] -- Nullary schema.
1414− | otherwise = SwaggerItemsObject <$> parseJSON js
1479+ | otherwise = OpenApiItemsObject <$> parseJSON js
1415− parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1480+ parseJSON js@(Array _) = OpenApiItemsArray <$> parseJSON js
1416 parseJSON _ = empty
1481 parseJSON _ = empty
1417
1482
1418instance FromJSON Components where
1483instance FromJSON Components where
@@ -1427,7 +1492,7 @@ instance FromJSON Param where
1427instance FromJSON Responses where
1492instance FromJSON Responses where
1428 parseJSON (Object o) = Responses
1493 parseJSON (Object o) = Responses
1429 <$> o .:? "default"
1494 <$> o .:? "default"
1430− <*> parseJSON (Object (HashMap.delete "default" o))
1495+ <*> parseJSON (Object (deleteKey "default" o))
1431 parseJSON _ = empty
1496 parseJSON _ = empty
1432
1497
1433instance FromJSON Example where
1498instance FromJSON Example where
@@ -1545,8 +1610,10 @@ instance AesonDefaultValue OAuth2AuthorizationCodeFlow
1545instance AesonDefaultValue p => AesonDefaultValue (OAuth2Flow p)
1610instance AesonDefaultValue p => AesonDefaultValue (OAuth2Flow p)
1546instance AesonDefaultValue Responses
1611instance AesonDefaultValue Responses
1547instance AesonDefaultValue SecuritySchemeType
1612instance AesonDefaultValue SecuritySchemeType
1548−instance AesonDefaultValue SwaggerType
1613+instance AesonDefaultValue OpenApiType
1549instance AesonDefaultValue MimeList where defaultValue = Just mempty
1614instance AesonDefaultValue MimeList where defaultValue = Just mempty
1550instance AesonDefaultValue Info
1615instance AesonDefaultValue Info
1551instance AesonDefaultValue ParamLocation
1616instance AesonDefaultValue ParamLocation
1552instance AesonDefaultValue Link
1617instance AesonDefaultValue Link
1618+instance AesonDefaultValue SecurityDefinitions where
1619+ defaultValue = Just mempty
src/Data/OpenApi/Internal/AesonUtils.hs+11−10
@@ -36,18 +36,19 @@ import Data.Text (Text)
36import Generics.SOP
36import Generics.SOP
37
37
38import qualified Data.Text as T
38import qualified Data.Text as T
39−import qualified Data.HashMap.Strict as HM
40import qualified Data.Set as Set
39import qualified Data.Set as Set
41import qualified Data.HashMap.Strict.InsOrd as InsOrd
40import qualified Data.HashMap.Strict.InsOrd as InsOrd
42import qualified Data.HashSet.InsOrd as InsOrdHS
41import qualified Data.HashSet.InsOrd as InsOrdHS
43
42
43+import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey)
44+
44-------------------------------------------------------------------------------
45-------------------------------------------------------------------------------
45-- SwaggerAesonOptions
46-- SwaggerAesonOptions
46-------------------------------------------------------------------------------
47-------------------------------------------------------------------------------
47
48
48data SwaggerAesonOptions = SwaggerAesonOptions
49data SwaggerAesonOptions = SwaggerAesonOptions
49 { _saoPrefix :: String
50 { _saoPrefix :: String
50− , _saoAdditionalPairs :: [(Text, Value)]
51+ , _saoAdditionalPairs :: [Pair]
51 , _saoSubObject :: Maybe String
52 , _saoSubObject :: Maybe String
52 }
53 }
53
54
@@ -154,14 +155,14 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
154 go Nil Nil Nil = []
155 go Nil Nil Nil = []
155 go (I x :* xs) (FieldInfo name :* names) (def :* defs)
156 go (I x :* xs) (FieldInfo name :* names) (def :* defs)
156 | Just name' == sub = case json of
157 | Just name' == sub = case json of
157− Object m -> HM.toList m ++ rest
158+ Object m -> objectToList m ++ rest
158 Null -> rest
159 Null -> rest
159 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
160 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
160 -- If default value: omit it.
161 -- If default value: omit it.
161 | Just x == def =
162 | Just x == def =
162 rest
163 rest
163 | otherwise =
164 | otherwise =
164− (T.pack name', json) : rest
165+ (stringToKey name', json) : rest
165 where
166 where
166 json = toJSON x
167 json = toJSON x
167 name' = fieldNameModifier name
168 name' = fieldNameModifier name
@@ -195,11 +196,11 @@ sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
195 proxy = Proxy :: Proxy a
196 proxy = Proxy :: Proxy a
196 opts = swaggerAesonOptions proxy
197 opts = swaggerAesonOptions proxy
197
198
198− parseAdditionalField :: Object -> (Text, Value) -> Parser ()
199+ parseAdditionalField :: Object -> Pair -> Parser ()
199 parseAdditionalField obj (k, v) = do
200 parseAdditionalField obj (k, v) = do
200 v' <- obj .: k
201 v' <- obj .: k
201 unless (v == v') $ fail $
202 unless (v == v') $ fail $
202− "Additonal field don't match for key " ++ T.unpack k
203+ "Additonal field don't match for key " ++ keyToString k
203 ++ ": " ++ show v
204 ++ ": " ++ show v
204 ++ " /= " ++ show v'
205 ++ " /= " ++ show v'
205
206
@@ -230,8 +231,8 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
230 -- Note: we might strip fields of outer structure.
231 -- Note: we might strip fields of outer structure.
231 cons <$> (withDef $ parseJSON $ Object obj) <*> rest
232 cons <$> (withDef $ parseJSON $ Object obj) <*> rest
232 | otherwise = case def of
233 | otherwise = case def of
233− Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest
234+ Just def' -> cons <$> obj .:? stringToKey name' .!= def' <*> rest
234− Nothing -> cons <$> obj .: T.pack name' <*> rest
235+ Nothing -> cons <$> obj .: stringToKey name' <*> rest
235 where
236 where
236 cons h t = I h :* t
237 cons h t = I h :* t
237 name' = fieldNameModifier name
238 name' = fieldNameModifier name
@@ -294,14 +295,14 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
294 go Nil Nil Nil = mempty
295 go Nil Nil Nil = mempty
295 go (I x :* xs) (FieldInfo name :* names) (def :* defs)
296 go (I x :* xs) (FieldInfo name :* names) (def :* defs)
296 | Just name' == sub = case toJSON x of
297 | Just name' == sub = case toJSON x of
297− Object m -> pairsToSeries (HM.toList m) <> rest
298+ Object m -> pairsToSeries (objectToList m) <> rest
298 Null -> rest
299 Null -> rest
299 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
300 _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
300 -- If default value: omit it.
301 -- If default value: omit it.
301 | Just x == def =
302 | Just x == def =
302 rest
303 rest
303 | otherwise =
304 | otherwise =
304− (T.pack name' .= x) <> rest
305+ (stringToKey name' .= x) <> rest
305 where
306 where
306 name' = fieldNameModifier name
307 name' = fieldNameModifier name
307 rest = go xs names defs
308 rest = go xs names defs
src/Data/OpenApi/Internal/ParamSchema.hs+51−33
@@ -46,26 +46,26 @@ import Data.OpenApi.Lens
46import Data.OpenApi.SchemaOptions
46import Data.OpenApi.SchemaOptions
47
47
48import qualified Data.ByteString as BS
48import qualified Data.ByteString as BS
49−import qualified Data.ByteString.Lazy as BSL
49+import qualified Data.ByteString.Lazy.Char8 as BSL
50import GHC.TypeLits (TypeError, ErrorMessage(..))
50import GHC.TypeLits (TypeError, ErrorMessage(..))
51
51
52-- | Default schema for binary data (any sequence of octets).
52-- | Default schema for binary data (any sequence of octets).
53binarySchema :: Schema
53binarySchema :: Schema
54binarySchema = mempty
54binarySchema = mempty
55− & type_ ?~ SwaggerString
55+ & type_ ?~ OpenApiString
56 & format ?~ "binary"
56 & format ?~ "binary"
57
57
58-- | Default schema for binary data (base64 encoded).
58-- | Default schema for binary data (base64 encoded).
59byteSchema :: Schema
59byteSchema :: Schema
60byteSchema = mempty
60byteSchema = mempty
61− & type_ ?~ SwaggerString
61+ & type_ ?~ OpenApiString
62 & format ?~ "byte"
62 & format ?~ "byte"
63
63
64-- | Default schema for password string.
64-- | Default schema for password string.
65-- @"password"@ format is used to hint UIs the input needs to be obscured.
65-- @"password"@ format is used to hint UIs the input needs to be obscured.
66passwordSchema :: Schema
66passwordSchema :: Schema
67passwordSchema = mempty
67passwordSchema = mempty
68− & type_ ?~ SwaggerString
68+ & type_ ?~ OpenApiString
69 & format ?~ "password"
69 & format ?~ "password"
70
70
71-- | Convert a type into a plain @'Schema'@.
71-- | Convert a type into a plain @'Schema'@.
@@ -87,7 +87,7 @@ passwordSchema = mempty
87--
87--
88-- instance ToParamSchema Direction where
88-- instance ToParamSchema Direction where
89-- toParamSchema _ = mempty
89-- toParamSchema _ = mempty
90−-- & type_ ?~ SwaggerString
90+-- & type_ ?~ OpenApiString
91-- & enum_ ?~ [ \"Up\", \"Down\" ]
91-- & enum_ ?~ [ \"Up\", \"Down\" ]
92-- @
92-- @
93--
93--
@@ -112,24 +112,26 @@ passwordSchema = mempty
112class ToParamSchema a where
112class ToParamSchema a where
113 -- | Convert a type into a plain parameter schema.
113 -- | Convert a type into a plain parameter schema.
114 --
114 --
115− -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
115+ -- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy Integer)
116+ -- {
116− -- "{\"type\":\"integer\"}"
117+ -- "type": "integer"
118+ -- }
117 toParamSchema :: Proxy a -> Schema
119 toParamSchema :: Proxy a -> Schema
118 default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema
120 default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema
119 toParamSchema = genericToParamSchema defaultSchemaOptions
121 toParamSchema = genericToParamSchema defaultSchemaOptions
120
122
121instance {-# OVERLAPPING #-} ToParamSchema String where
123instance {-# OVERLAPPING #-} ToParamSchema String where
122− toParamSchema _ = mempty & type_ ?~ SwaggerString
124+ toParamSchema _ = mempty & type_ ?~ OpenApiString
123
125
124instance ToParamSchema Bool where
126instance ToParamSchema Bool where
125− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
127+ toParamSchema _ = mempty & type_ ?~ OpenApiBoolean
126
128
127instance ToParamSchema Integer where
129instance ToParamSchema Integer where
128− toParamSchema _ = mempty & type_ ?~ SwaggerInteger
130+ toParamSchema _ = mempty & type_ ?~ OpenApiInteger
129
131
130instance ToParamSchema Natural where
132instance ToParamSchema Natural where
131 toParamSchema _ = mempty
133 toParamSchema _ = mempty
132− & type_ ?~ SwaggerInteger
134+ & type_ ?~ OpenApiInteger
133 & minimum_ ?~ 0
135 & minimum_ ?~ 0
134 & exclusiveMinimum ?~ False
136 & exclusiveMinimum ?~ False
135
137
@@ -155,41 +157,45 @@ instance ToParamSchema Word64 where
155
157
156-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
158-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
157--
159--
158−-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
160+-- >>> BSL.putStrLn $ encodePretty $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
161+-- {
162+-- "maximum": 127,
163+-- "minimum": -128,
159−-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
164+-- "type": "integer"
165+-- }
160toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema
166toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema
161toParamSchemaBoundedIntegral _ = mempty
167toParamSchemaBoundedIntegral _ = mempty
162− & type_ ?~ SwaggerInteger
168+ & type_ ?~ OpenApiInteger
163 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
169 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
164 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
170 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
165
171
166instance ToParamSchema Char where
172instance ToParamSchema Char where
167 toParamSchema _ = mempty
173 toParamSchema _ = mempty
168− & type_ ?~ SwaggerString
174+ & type_ ?~ OpenApiString
169 & maxLength ?~ 1
175 & maxLength ?~ 1
170 & minLength ?~ 1
176 & minLength ?~ 1
171
177
172instance ToParamSchema Scientific where
178instance ToParamSchema Scientific where
173− toParamSchema _ = mempty & type_ ?~ SwaggerNumber
179+ toParamSchema _ = mempty & type_ ?~ OpenApiNumber
174
180
175instance HasResolution a => ToParamSchema (Fixed a) where
181instance HasResolution a => ToParamSchema (Fixed a) where
176 toParamSchema _ = mempty
182 toParamSchema _ = mempty
177− & type_ ?~ SwaggerNumber
183+ & type_ ?~ OpenApiNumber
178 & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
184 & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
179
185
180instance ToParamSchema Double where
186instance ToParamSchema Double where
181 toParamSchema _ = mempty
187 toParamSchema _ = mempty
182− & type_ ?~ SwaggerNumber
188+ & type_ ?~ OpenApiNumber
183 & format ?~ "double"
189 & format ?~ "double"
184
190
185instance ToParamSchema Float where
191instance ToParamSchema Float where
186 toParamSchema _ = mempty
192 toParamSchema _ = mempty
187− & type_ ?~ SwaggerNumber
193+ & type_ ?~ OpenApiNumber
188 & format ?~ "float"
194 & format ?~ "float"
189
195
190timeParamSchema :: String -> Schema
196timeParamSchema :: String -> Schema
191timeParamSchema fmt = mempty
197timeParamSchema fmt = mempty
192− & type_ ?~ SwaggerString
198+ & type_ ?~ OpenApiString
193 & format ?~ T.pack fmt
199 & format ?~ T.pack fmt
194
200
195-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
201-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -210,9 +216,9 @@ instance ToParamSchema LocalTime where
210
216
211-- |
217-- |
212-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
218-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
213−-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
219+-- Just "date-time"
214instance ToParamSchema ZonedTime where
220instance ToParamSchema ZonedTime where
215− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
221+ toParamSchema _ = timeParamSchema "date-time"
216
222
217-- |
223-- |
218-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
224-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
@@ -231,12 +237,12 @@ instance ToParamSchema TL.Text where
231
237
232instance ToParamSchema Version where
238instance ToParamSchema Version where
233 toParamSchema _ = mempty
239 toParamSchema _ = mempty
234− & type_ ?~ SwaggerString
240+ & type_ ?~ OpenApiString
235 & pattern ?~ "^\\d+(\\.\\d+)*$"
241 & pattern ?~ "^\\d+(\\.\\d+)*$"
236
242
237instance ToParamSchema SetCookie where
243instance ToParamSchema SetCookie where
238 toParamSchema _ = mempty
244 toParamSchema _ = mempty
239− & type_ ?~ SwaggerString
245+ & type_ ?~ OpenApiString
240
246
241type family ToParamSchemaByteStringError bs where
247type family ToParamSchemaByteStringError bs where
242 ToParamSchemaByteStringError bs = TypeError
248 ToParamSchemaByteStringError bs = TypeError
@@ -259,8 +265,8 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t
259
265
260instance ToParamSchema a => ToParamSchema [a] where
266instance ToParamSchema a => ToParamSchema [a] where
261 toParamSchema _ = mempty
267 toParamSchema _ = mempty
262− & type_ ?~ SwaggerArray
268+ & type_ ?~ OpenApiArray
263− & items ?~ SwaggerItemsObject (Inline $ toParamSchema (Proxy :: Proxy a))
269+ & items ?~ OpenApiItemsObject (Inline $ toParamSchema (Proxy :: Proxy a))
264
270
265instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
271instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
266instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
272instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -275,24 +281,35 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
275 toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
281 toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
276
282
277-- |
283-- |
278−-- >>> encode $ toParamSchema (Proxy :: Proxy ())
284+-- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy ())
285+-- {
279−-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
286+-- "enum": [
287+-- "_"
288+-- ],
289+-- "type": "string"
290+-- }
280instance ToParamSchema () where
291instance ToParamSchema () where
281 toParamSchema _ = mempty
292 toParamSchema _ = mempty
282− & type_ ?~ SwaggerString
293+ & type_ ?~ OpenApiString
283 & enum_ ?~ ["_"]
294 & enum_ ?~ ["_"]
284
295
285instance ToParamSchema UUID where
296instance ToParamSchema UUID where
286 toParamSchema _ = mempty
297 toParamSchema _ = mempty
287− & type_ ?~ SwaggerString
298+ & type_ ?~ OpenApiString
288 & format ?~ "uuid"
299 & format ?~ "uuid"
289
300
290-- | A configurable generic @'Schema'@ creator.
301-- | A configurable generic @'Schema'@ creator.
291--
302--
292-- >>> :set -XDeriveGeneric
303-- >>> :set -XDeriveGeneric
293-- >>> data Color = Red | Blue deriving Generic
304-- >>> data Color = Red | Blue deriving Generic
294−-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
305+-- >>> BSL.putStrLn $ encodePretty $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
295−-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
306+-- {
307+-- "enum": [
308+-- "Red",
309+-- "Blue"
310+-- ],
311+-- "type": "string"
312+-- }
296genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema
313genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema
297genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
314genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
298
315
@@ -322,7 +339,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g)
322
339
323instance Constructor c => GEnumParamSchema (C1 c U1) where
340instance Constructor c => GEnumParamSchema (C1 c U1) where
324 genumParamSchema opts _ s = s
341 genumParamSchema opts _ s = s
325− & type_ ?~ SwaggerString
342+ & type_ ?~ OpenApiString
326 & enum_ %~ addEnumValue tag
343 & enum_ %~ addEnumValue tag
327 where
344 where
328 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
345 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -334,3 +351,4 @@ data Proxy3 a b c = Proxy3
334
351
335-- $setup
352-- $setup
336-- >>> import Data.Aeson (encode)
353-- >>> import Data.Aeson (encode)
354+-- >>> import Data.OpenApi.Internal.Utils
src/Data/OpenApi/Internal/Schema.hs+378−116
@@ -1,15 +1,17 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE OverloadedLists #-}
8{-# LANGUAGE OverloadedLists #-}
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PackageImports #-}
10{-# LANGUAGE PackageImports #-}
10{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TupleSections #-}
13{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE TypeSynonymInstances #-}
17{-# LANGUAGE TypeSynonymInstances #-}
@@ -40,6 +42,7 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
40import Data.Int
42import Data.Int
41import Data.IntSet (IntSet)
43import Data.IntSet (IntSet)
42import Data.IntMap (IntMap)
44import Data.IntMap (IntMap)
45+import Data.List (sort)
43import Data.List.NonEmpty.Compat (NonEmpty)
46import Data.List.NonEmpty.Compat (NonEmpty)
44import Data.Map (Map)
47import Data.Map (Map)
45import Data.Maybe (fromMaybe)
48import Data.Maybe (fromMaybe)
@@ -59,14 +62,16 @@ import Numeric.Natural.Compat (Natural)
59import Data.Word
62import Data.Word
60import GHC.Generics
63import GHC.Generics
61import qualified Data.UUID.Types as UUID
64import qualified Data.UUID.Types as UUID
65+import Type.Reflection (Typeable, typeRep)
62
66
67+import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)
63−import Data.OpenApi.Declare
68+import Data.OpenApi.Declare
64−import Data.OpenApi.Internal
69+import Data.OpenApi.Internal
65−import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))
70+import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
71+import Data.OpenApi.Internal.TypeShape
66−import Data.OpenApi.Lens hiding (name, schema)
72+import Data.OpenApi.Lens hiding (name, schema)
67−import qualified Data.OpenApi.Lens as Swagger
73+import qualified Data.OpenApi.Lens as Swagger
68−import Data.OpenApi.SchemaOptions
74+import Data.OpenApi.SchemaOptions
69−import Data.OpenApi.Internal.TypeShape
70
75
71import qualified Data.ByteString as BS
76import qualified Data.ByteString as BS
72import qualified Data.ByteString.Lazy.Char8 as BSL
77import qualified Data.ByteString.Lazy.Char8 as BSL
@@ -105,7 +110,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
105-- declareNamedSchema _ = do
110-- declareNamedSchema _ = do
106-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
111-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
107-- return $ NamedSchema (Just \"Coord\") $ mempty
112-- return $ NamedSchema (Just \"Coord\") $ mempty
108−-- & type_ ?~ SwaggerObject
113+-- & type_ ?~ OpenApiObject
109-- & properties .~
114-- & properties .~
110-- [ (\"x\", doubleSchema)
115-- [ (\"x\", doubleSchema)
111-- , (\"y\", doubleSchema)
116-- , (\"y\", doubleSchema)
@@ -131,7 +136,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
131--
136--
132-- instance ToSchema Coord
137-- instance ToSchema Coord
133-- @
138-- @
134−class ToSchema a where
139+class Typeable a => ToSchema a where
135 -- | Convert a type into an optionally named schema
140 -- | Convert a type into an optionally named schema
136 -- together with all used definitions.
141 -- together with all used definitions.
137 -- Note that the schema itself is included in definitions
142 -- Note that the schema itself is included in definitions
@@ -153,13 +158,19 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
153--
158--
154-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
159-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
155-- Nothing
160-- Nothing
156−-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
161+-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy String) ^. schema)
162+-- {
157−-- {"type":"string"}
163+-- "type": "string"
164+-- }
158--
165--
159-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
166-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
160-- Just "Day"
167-- Just "Day"
161−-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168+-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy Day) ^. schema)
169+-- {
162−-- {"example":"2016-07-22","format":"date","type":"string"}
170+-- "example": "2016-07-22",
171+-- "format": "date",
172+-- "type": "string"
173+-- }
163toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
174toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
164toNamedSchema = undeclare . declareNamedSchema
175toNamedSchema = undeclare . declareNamedSchema
165
176
@@ -175,22 +186,35 @@ schemaName = _namedSchemaName . toNamedSchema
175
186
176-- | Convert a type into a schema.
187-- | Convert a type into a schema.
177--
188--
178−-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Int8)
189+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Int8)
190+-- {
191+-- "maximum": 127,
192+-- "minimum": -128,
179−-- {"maximum":127,"minimum":-128,"type":"integer"}
193+-- "type": "integer"
194+-- }
180--
195--
181−-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy [Day])
196+-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy [Day])
197+-- {
198+-- "items": {
182−-- {"items":{"$ref":"#/components/schemas/Day"},"type":"array"}
199+-- "$ref": "#/components/schemas/Day"
200+-- },
201+-- "type": "array"
202+-- }
183toSchema :: ToSchema a => Proxy a -> Schema
203toSchema :: ToSchema a => Proxy a -> Schema
184toSchema = _namedSchemaSchema . toNamedSchema
204toSchema = _namedSchemaSchema . toNamedSchema
185
205
186-- | Convert a type into a referenced schema if possible.
206-- | Convert a type into a referenced schema if possible.
187-- Only named schemas can be referenced, nameless schemas are inlined.
207-- Only named schemas can be referenced, nameless schemas are inlined.
188--
208--
189−-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Integer)
209+-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Integer)
210+-- {
190−-- {"type":"integer"}
211+-- "type": "integer"
212+-- }
191--
213--
192−-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Day)
214+-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Day)
215+-- {
193−-- {"$ref":"#/components/schemas/Day"}
216+-- "$ref": "#/components/schemas/Day"
217+-- }
194toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
218toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
195toSchemaRef = undeclare . declareSchemaRef
219toSchemaRef = undeclare . declareSchemaRef
196
220
@@ -258,8 +282,15 @@ inlineAllSchemas = inlineSchemasWhen (const True)
258
282
259-- | Convert a type into a schema without references.
283-- | Convert a type into a schema without references.
260--
284--
261−-- >>> BSL.putStrLn $ encode $ toInlinedSchema (Proxy :: Proxy [Day])
285+-- >>> BSL.putStrLn $ encodePretty $ toInlinedSchema (Proxy :: Proxy [Day])
286+-- {
287+-- "items": {
262−-- {"items":{"example":"2016-07-22","format":"date","type":"string"},"type":"array"}
288+-- "example": "2016-07-22",
289+-- "format": "date",
290+-- "type": "string"
291+-- },
292+-- "type": "array"
293+-- }
263--
294--
264-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
295-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
265-- when inlining recursive schemas.
296-- when inlining recursive schemas.
@@ -292,19 +323,64 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
292-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
323-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
293-- Produced schema can be used for further refinement.
324-- Produced schema can be used for further refinement.
294--
325--
295−-- >>> BSL.putStrLn $ encode $ sketchSchema "hello"
326+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema "hello"
327+-- {
296−-- {"example":"hello","type":"string"}
328+-- "example": "hello",
329+-- "type": "string"
330+-- }
297--
331--
298−-- >>> BSL.putStrLn $ encode $ sketchSchema (1, 2, 3)
332+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (1, 2, 3)
333+-- {
334+-- "example": [
335+-- 1,
336+-- 2,
337+-- 3
338+-- ],
339+-- "items": {
299−-- {"example":[1,2,3],"items":{"type":"number"},"type":"array"}
340+-- "type": "number"
341+-- },
342+-- "type": "array"
343+-- }
300--
344--
301−-- >>> BSL.putStrLn $ encode $ sketchSchema ("Jack", 25)
345+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema ("Jack", 25)
302−-- {"example":["Jack",25],"items":[{"type":"string"},{"type":"number"}],"type":"array"}
346+-- {
347+-- "example": [
348+-- "Jack",
349+-- 25
350+-- ],
351+-- "items": [
352+-- {
353+-- "type": "string"
354+-- },
355+-- {
356+-- "type": "number"
357+-- }
358+-- ],
359+-- "type": "array"
360+-- }
303--
361--
304-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
362-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
305-- >>> instance ToJSON Person
363-- >>> instance ToJSON Person
306−-- >>> BSL.putStrLn $ encode $ sketchSchema (Person "Jack" 25)
364+-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (Person "Jack" 25)
307−-- {"example":{"age":25,"name":"Jack"},"required":["age","name"],"type":"object","properties":{"age":{"type":"number"},"name":{"type":"string"}}}
365+-- {
366+-- "example": {
367+-- "age": 25,
368+-- "name": "Jack"
369+-- },
370+-- "properties": {
371+-- "age": {
372+-- "type": "number"
373+-- },
374+-- "name": {
375+-- "type": "string"
376+-- }
377+-- },
378+-- "required": [
379+-- "age",
380+-- "name"
381+-- ],
382+-- "type": "object"
383+-- }
308sketchSchema :: ToJSON a => a -> Schema
384sketchSchema :: ToJSON a => a -> Schema
309sketchSchema = sketch . toJSON
385sketchSchema = sketch . toJSON
310 where
386 where
@@ -312,15 +388,15 @@ sketchSchema = sketch . toJSON
312 sketch js@(Bool _) = go js
388 sketch js@(Bool _) = go js
313 sketch js = go js & example ?~ js
389 sketch js = go js & example ?~ js
314
390
315− go Null = mempty & type_ ?~ SwaggerNull
391+ go Null = mempty & type_ ?~ OpenApiNull
316− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
392+ go (Bool _) = mempty & type_ ?~ OpenApiBoolean
317− go (String _) = mempty & type_ ?~ SwaggerString
393+ go (String _) = mempty & type_ ?~ OpenApiString
318− go (Number _) = mempty & type_ ?~ SwaggerNumber
394+ go (Number _) = mempty & type_ ?~ OpenApiNumber
319 go (Array xs) = mempty
395 go (Array xs) = mempty
320− & type_ ?~ SwaggerArray
396+ & type_ ?~ OpenApiArray
321 & items ?~ case ischema of
397 & items ?~ case ischema of
322− Just s -> SwaggerItemsObject (Inline s)
398+ Just s -> OpenApiItemsObject (Inline s)
323− _ -> SwaggerItemsArray (map Inline ys)
399+ _ -> OpenApiItemsArray (map Inline ys)
324 where
400 where
325 ys = map go (V.toList xs)
401 ys = map go (V.toList xs)
326 allSame = and ((zipWith (==)) ys (tail ys))
402 allSame = and ((zipWith (==)) ys (tail ys))
@@ -329,64 +405,178 @@ sketchSchema = sketch . toJSON
329 (z:_) | allSame -> Just z
405 (z:_) | allSame -> Just z
330 _ -> Nothing
406 _ -> Nothing
331 go (Object o) = mempty
407 go (Object o) = mempty
332− & type_ ?~ SwaggerObject
408+ & type_ ?~ OpenApiObject
333− & required .~ HashMap.keys o
409+ & required .~ sort (objectKeys o)
334− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
335
411
336-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
412-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
337-- Produced schema uses as much constraints as possible.
413-- Produced schema uses as much constraints as possible.
338--
414--
339−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema "hello"
415+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema "hello"
340−-- {"maxLength":5,"pattern":"hello","minLength":5,"type":"string","enum":["hello"]}
416+-- {
417+-- "enum": [
418+-- "hello"
419+-- ],
420+-- "maxLength": 5,
421+-- "minLength": 5,
422+-- "pattern": "hello",
423+-- "type": "string"
424+-- }
341--
425--
342−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (1, 2, 3)
426+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (1, 2, 3)
343−-- {"minItems":3,"uniqueItems":true,"items":[{"maximum":1,"minimum":1,"multipleOf":1,"type":"number","enum":[1]},{"maximum":2,"minimum":2,"multipleOf":2,"type":"number","enum":[2]},{"maximum":3,"minimum":3,"multipleOf":3,"type":"number","enum":[3]}],"maxItems":3,"type":"array","enum":[[1,2,3]]}
427+-- {
428+-- "enum": [
429+-- [
430+-- 1,
431+-- 2,
432+-- 3
433+-- ]
434+-- ],
435+-- "items": [
436+-- {
437+-- "enum": [
438+-- 1
439+-- ],
440+-- "maximum": 1,
441+-- "minimum": 1,
442+-- "multipleOf": 1,
443+-- "type": "number"
444+-- },
445+-- {
446+-- "enum": [
447+-- 2
448+-- ],
449+-- "maximum": 2,
450+-- "minimum": 2,
451+-- "multipleOf": 2,
452+-- "type": "number"
453+-- },
454+-- {
455+-- "enum": [
456+-- 3
457+-- ],
458+-- "maximum": 3,
459+-- "minimum": 3,
460+-- "multipleOf": 3,
461+-- "type": "number"
462+-- }
463+-- ],
464+-- "maxItems": 3,
465+-- "minItems": 3,
466+-- "type": "array",
467+-- "uniqueItems": true
468+-- }
344--
469--
345−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema ("Jack", 25)
470+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema ("Jack", 25)
346−-- {"minItems":2,"uniqueItems":true,"items":[{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]},{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]}],"maxItems":2,"type":"array","enum":[["Jack",25]]}
471+-- {
472+-- "enum": [
473+-- [
474+-- "Jack",
475+-- 25
476+-- ]
477+-- ],
478+-- "items": [
479+-- {
480+-- "enum": [
481+-- "Jack"
482+-- ],
483+-- "maxLength": 4,
484+-- "minLength": 4,
485+-- "pattern": "Jack",
486+-- "type": "string"
487+-- },
488+-- {
489+-- "enum": [
490+-- 25
491+-- ],
492+-- "maximum": 25,
493+-- "minimum": 25,
494+-- "multipleOf": 25,
495+-- "type": "number"
496+-- }
497+-- ],
498+-- "maxItems": 2,
499+-- "minItems": 2,
500+-- "type": "array",
501+-- "uniqueItems": true
502+-- }
347--
503--
348-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
504-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
349-- >>> instance ToJSON Person
505-- >>> instance ToJSON Person
350−-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (Person "Jack" 25)
506+-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (Person "Jack" 25)
351−-- {"minProperties":2,"required":["age","name"],"maxProperties":2,"type":"object","enum":[{"age":25,"name":"Jack"}],"properties":{"age":{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]},"name":{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]}}}
507+-- {
508+-- "enum": [
509+-- {
510+-- "age": 25,
511+-- "name": "Jack"
512+-- }
513+-- ],
514+-- "maxProperties": 2,
515+-- "minProperties": 2,
516+-- "properties": {
517+-- "age": {
518+-- "enum": [
519+-- 25
520+-- ],
521+-- "maximum": 25,
522+-- "minimum": 25,
523+-- "multipleOf": 25,
524+-- "type": "number"
525+-- },
526+-- "name": {
527+-- "enum": [
528+-- "Jack"
529+-- ],
530+-- "maxLength": 4,
531+-- "minLength": 4,
532+-- "pattern": "Jack",
533+-- "type": "string"
534+-- }
535+-- },
536+-- "required": [
537+-- "age",
538+-- "name"
539+-- ],
540+-- "type": "object"
541+-- }
352sketchStrictSchema :: ToJSON a => a -> Schema
542sketchStrictSchema :: ToJSON a => a -> Schema
353sketchStrictSchema = go . toJSON
543sketchStrictSchema = go . toJSON
354 where
544 where
355− go Null = mempty & type_ ?~ SwaggerNull
545+ go Null = mempty & type_ ?~ OpenApiNull
356 go js@(Bool _) = mempty
546 go js@(Bool _) = mempty
357− & type_ ?~ SwaggerBoolean
547+ & type_ ?~ OpenApiBoolean
358 & enum_ ?~ [js]
548 & enum_ ?~ [js]
359 go js@(String s) = mempty
549 go js@(String s) = mempty
360− & type_ ?~ SwaggerString
550+ & type_ ?~ OpenApiString
361 & maxLength ?~ fromIntegral (T.length s)
551 & maxLength ?~ fromIntegral (T.length s)
362 & minLength ?~ fromIntegral (T.length s)
552 & minLength ?~ fromIntegral (T.length s)
363 & pattern ?~ s
553 & pattern ?~ s
364 & enum_ ?~ [js]
554 & enum_ ?~ [js]
365 go js@(Number n) = mempty
555 go js@(Number n) = mempty
366− & type_ ?~ SwaggerNumber
556+ & type_ ?~ OpenApiNumber
367 & maximum_ ?~ n
557 & maximum_ ?~ n
368 & minimum_ ?~ n
558 & minimum_ ?~ n
369 & multipleOf ?~ n
559 & multipleOf ?~ n
370 & enum_ ?~ [js]
560 & enum_ ?~ [js]
371 go js@(Array xs) = mempty
561 go js@(Array xs) = mempty
372− & type_ ?~ SwaggerArray
562+ & type_ ?~ OpenApiArray
373 & maxItems ?~ fromIntegral sz
563 & maxItems ?~ fromIntegral sz
374 & minItems ?~ fromIntegral sz
564 & minItems ?~ fromIntegral sz
375− & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
565+ & items ?~ OpenApiItemsArray (map (Inline . go) (V.toList xs))
376 & uniqueItems ?~ allUnique
566 & uniqueItems ?~ allUnique
377 & enum_ ?~ [js]
567 & enum_ ?~ [js]
378 where
568 where
379 sz = length xs
569 sz = length xs
380 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
570 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
381 go js@(Object o) = mempty
571 go js@(Object o) = mempty
382− & type_ ?~ SwaggerObject
572+ & type_ ?~ OpenApiObject
383− & required .~ names
573+ & required .~ sort names
384− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
574+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
385 & maxProperties ?~ fromIntegral (length names)
575 & maxProperties ?~ fromIntegral (length names)
386 & minProperties ?~ fromIntegral (length names)
576 & minProperties ?~ fromIntegral (length names)
387 & enum_ ?~ [js]
577 & enum_ ?~ [js]
388 where
578 where
389− names = HashMap.keys o
579+ names = objectKeys o
390
580
391class GToSchema (f :: * -> *) where
581class GToSchema (f :: * -> *) where
392 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
582 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
@@ -395,8 +585,8 @@ instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
395 declareNamedSchema _ = do
585 declareNamedSchema _ = do
396 ref <- declareSchemaRef (Proxy :: Proxy a)
586 ref <- declareSchemaRef (Proxy :: Proxy a)
397 return $ unnamed $ mempty
587 return $ unnamed $ mempty
398− & type_ ?~ SwaggerArray
588+ & type_ ?~ OpenApiArray
399− & items ?~ SwaggerItemsObject ref
589+ & items ?~ OpenApiItemsObject ref
400
590
401instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
591instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
402instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
592instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
@@ -421,7 +611,7 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
421instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
611instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
422instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
612instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
423
613
424−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
614+instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
425
615
426instance ToSchema a => ToSchema (Maybe a) where
616instance ToSchema a => ToSchema (Maybe a) where
427 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
617 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
@@ -438,16 +628,22 @@ instance ToSchema UUID.UUID where
438 declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
628 declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
439 & example ?~ toJSON (UUID.toText UUID.nil)
629 & example ?~ toJSON (UUID.toText UUID.nil)
440
630
441−instance (ToSchema a, ToSchema b) => ToSchema (a, b)
631+instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
632+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
442−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
633+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
634+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
443−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
635+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
636+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
444−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
637+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
638+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
445−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
639+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
640+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
446−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
641+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
642+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
447
643
448timeSchema :: T.Text -> Schema
644timeSchema :: T.Text -> Schema
449timeSchema fmt = mempty
645timeSchema fmt = mempty
450− & type_ ?~ SwaggerString
646+ & type_ ?~ OpenApiString
451 & format ?~ fmt
647 & format ?~ fmt
452
648
453-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
649-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -462,7 +658,7 @@ instance ToSchema LocalTime where
462 declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
658 declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
463 & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
659 & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
464
660
465−-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
661+-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
466instance ToSchema ZonedTime where
662instance ToSchema ZonedTime where
467 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
663 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
468 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
664 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
@@ -494,7 +690,7 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where
494instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
690instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
495
691
496-- | NOTE: This schema does not account for the uniqueness of keys.
692-- | NOTE: This schema does not account for the uniqueness of keys.
497−instance ToSchema a => ToSchema (IntMap a) where
693+instance (ToSchema a) => ToSchema (IntMap a) where
498 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
694 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
499
695
500instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
696instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
@@ -505,7 +701,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
505 declareObjectMapSchema = do
701 declareObjectMapSchema = do
506 schema <- declareSchemaRef (Proxy :: Proxy v)
702 schema <- declareSchemaRef (Proxy :: Proxy v)
507 return $ unnamed $ mempty
703 return $ unnamed $ mempty
508− & type_ ?~ SwaggerObject
704+ & type_ ?~ OpenApiObject
509 & additionalProperties ?~ AdditionalPropertiesSchema schema
705 & additionalProperties ?~ AdditionalPropertiesSchema schema
510
706
511instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
707instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
@@ -513,7 +709,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
513
709
514instance {-# OVERLAPPING #-} ToSchema Object where
710instance {-# OVERLAPPING #-} ToSchema Object where
515 declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
711 declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
516− & type_ ?~ SwaggerObject
712+ & type_ ?~ OpenApiObject
517 & description ?~ "Arbitrary JSON object."
713 & description ?~ "Arbitrary JSON object."
518 & additionalProperties ?~ AdditionalPropertiesAllowed True
714 & additionalProperties ?~ AdditionalPropertiesAllowed True
519
715
@@ -550,11 +746,15 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar
550
746
551-- | Default schema for @'Bounded'@, @'Integral'@ types.
747-- | Default schema for @'Bounded'@, @'Integral'@ types.
552--
748--
553−-- >>> BSL.putStrLn $ encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
749+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
750+-- {
554−-- {"maximum":32767,"minimum":-32768,"type":"integer"}
751+-- "maximum": 32767,
752+-- "minimum": -32768,
753+-- "type": "integer"
754+-- }
555toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
755toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
556toSchemaBoundedIntegral _ = mempty
756toSchemaBoundedIntegral _ = mempty
557− & type_ ?~ SwaggerInteger
757+ & type_ ?~ OpenApiInteger
558 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
758 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
559 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
759 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
560
760
@@ -583,8 +783,27 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$>
583-- >>> instance ToSchema ButtonState
783-- >>> instance ToSchema ButtonState
584-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
784-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
585-- >>> type ImageUrl = T.Text
785-- >>> type ImageUrl = T.Text
586−-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
786+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
587−-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}
787+-- {
788+-- "properties": {
789+-- "Active": {
790+-- "type": "string"
791+-- },
792+-- "Disabled": {
793+-- "type": "string"
794+-- },
795+-- "Focus": {
796+-- "type": "string"
797+-- },
798+-- "Hover": {
799+-- "type": "string"
800+-- },
801+-- "Neutral": {
802+-- "type": "string"
803+-- }
804+-- },
805+-- "type": "object"
806+-- }
588--
807--
589-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
808-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
590-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
809-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
@@ -592,15 +811,15 @@ declareSchemaBoundedEnumKeyMapping :: forall map key value.
592 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
811 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
593 => Proxy (map key value) -> Declare (Definitions Schema) Schema
812 => Proxy (map key value) -> Declare (Definitions Schema) Schema
594declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
813declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
595− ToJSONKeyText keyToText _ -> objectSchema keyToText
814+ ToJSONKeyText getKey _ -> objectSchema getKey
596 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
815 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
597 where
816 where
598− objectSchema keyToText = do
817+ objectSchema getKey = do
599 valueRef <- declareSchemaRef (Proxy :: Proxy value)
818 valueRef <- declareSchemaRef (Proxy :: Proxy value)
600 let allKeys = [minBound..maxBound :: key]
819 let allKeys = [minBound..maxBound :: key]
601− mkPair k = (keyToText k, valueRef)
820+ mkPair k = (keyToText $ getKey k, valueRef)
602 return $ mempty
821 return $ mempty
603− & type_ ?~ SwaggerObject
822+ & type_ ?~ OpenApiObject
604 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
823 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
605
824
606-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
825-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
@@ -611,8 +830,27 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
611-- >>> instance ToSchema ButtonState
830-- >>> instance ToSchema ButtonState
612-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
831-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
613-- >>> type ImageUrl = T.Text
832-- >>> type ImageUrl = T.Text
614−-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
833+-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
615−-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}}
834+-- {
835+-- "properties": {
836+-- "Active": {
837+-- "type": "string"
838+-- },
839+-- "Disabled": {
840+-- "type": "string"
841+-- },
842+-- "Focus": {
843+-- "type": "string"
844+-- },
845+-- "Hover": {
846+-- "type": "string"
847+-- },
848+-- "Neutral": {
849+-- "type": "string"
850+-- }
851+-- },
852+-- "type": "object"
853+-- }
616--
854--
617-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
855-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
618-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
856-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
@@ -622,7 +860,7 @@ toSchemaBoundedEnumKeyMapping :: forall map key value.
622toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
860toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
623
861
624-- | A configurable generic @'Schema'@ creator.
862-- | A configurable generic @'Schema'@ creator.
625−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) =>
863+genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
626 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
864 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
627genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
865genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
628
866
@@ -630,9 +868,24 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche
630-- This function applied to @'defaultSchemaOptions'@
868-- This function applied to @'defaultSchemaOptions'@
631-- is used as the default for @'declareNamedSchema'@
869-- is used as the default for @'declareNamedSchema'@
632-- when the type is an instance of @'Generic'@.
870-- when the type is an instance of @'Generic'@.
871+--
872+-- Default implementation will use the name from 'Typeable' instance, including concrete
873+-- instantioations of type variables.
874+--
875+-- For example:
876+--
877+-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
878+-- Just "Either_Int_Bool"
633−genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>
879+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
634 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
880 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
881+genericDeclareNamedSchema opts _ =
635−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
882+ rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
883+ where
884+ unspace ' ' = '_'
885+ unspace x = x
886+ orig = fmap unspace $ show $ typeRep @a
887+ name = datatypeNameModifier opts orig
888+
636
889
637-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
890-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
638genericNameSchema :: forall a d f.
891genericNameSchema :: forall a d f.
@@ -659,8 +912,8 @@ paramSchemaToSchema = toParamSchema
659
912
660nullarySchema :: Schema
913nullarySchema :: Schema
661nullarySchema = mempty
914nullarySchema = mempty
662− & type_ ?~ SwaggerArray
915+ & type_ ?~ OpenApiArray
663− & items ?~ SwaggerItemsArray []
916+ & items ?~ OpenApiItemsArray []
664
917
665gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
918gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
666gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
919gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
@@ -690,12 +943,15 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
690 | unwrapUnaryRecords opts = fieldSchema
943 | unwrapUnaryRecords opts = fieldSchema
691 | otherwise =
944 | otherwise =
692 case schema ^. items of
945 case schema ^. items of
693− Just (SwaggerItemsArray [_]) -> fieldSchema
946+ Just (OpenApiItemsArray [_]) -> fieldSchema
694 _ -> do
947 _ -> do
695− declare defs
948+ -- We have to run recordSchema instead of just using its defs,
949+ -- since those can be recursive and will lead to infinite loop,
950+ -- see https://github.com/biocad/openapi3/pull/37
951+ NamedSchema _ schema' <- recordSchema
696− return (unnamed schema)
952+ return (unnamed schema')
697 where
953 where
698− (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
954+ (_, NamedSchema _ schema) = runDeclare recordSchema mempty
699 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
955 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
700 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
956 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
701
957
@@ -718,10 +974,10 @@ gdeclareSchemaRef opts proxy = do
718 return $ Ref (Reference name)
974 return $ Ref (Reference name)
719 _ -> Inline <$> gdeclareSchema opts proxy
975 _ -> Inline <$> gdeclareSchema opts proxy
720
976
721−appendItem :: Referenced Schema -> Maybe SwaggerItems -> Maybe SwaggerItems
977+appendItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems
722−appendItem x Nothing = Just (SwaggerItemsArray [x])
978+appendItem x Nothing = Just (OpenApiItemsArray [x])
723−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
979+appendItem x (Just (OpenApiItemsArray xs)) = Just (OpenApiItemsArray (xs ++ [x]))
724−appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
980+appendItem _ _ = error "GToSchema.appendItem: cannot append to OpenApiItemsObject"
725
981
726withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
982withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
727 SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
983 SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
@@ -730,12 +986,12 @@ withFieldSchema opts _ isRequiredField schema = do
730 return $
986 return $
731 if T.null fname
987 if T.null fname
732 then schema
988 then schema
733− & type_ ?~ SwaggerArray
989+ & type_ ?~ OpenApiArray
734 & items %~ appendItem ref
990 & items %~ appendItem ref
735 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
991 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
736 & minItems %~ Just . maybe 1 (+1) -- increment minItems
992 & minItems %~ Just . maybe 1 (+1) -- increment minItems
737 else schema
993 else schema
738− & type_ ?~ SwaggerObject
994+ & type_ ?~ OpenApiObject
739 & properties . at fname ?~ ref
995 & properties . at fname ?~ ref
740 & if isRequiredField
996 & if isRequiredField
741 then required %~ (++ [fname])
997 then required %~ (++ [fname])
@@ -770,14 +1026,14 @@ gdeclareNamedSumSchema opts proxy _
770 | otherwise = do
1026 | otherwise = do
771 (schemas, _) <- runWriterT declareSumSchema
1027 (schemas, _) <- runWriterT declareSumSchema
772 return $ unnamed $ mempty
1028 return $ unnamed $ mempty
773− & type_ ?~ SwaggerObject
1029+ & type_ ?~ OpenApiObject
774 & oneOf ?~ (snd <$> schemas)
1030 & oneOf ?~ (snd <$> schemas)
775 where
1031 where
776 declareSumSchema = gsumToSchema opts proxy
1032 declareSumSchema = gsumToSchema opts proxy
777 (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)
1033 (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)
778
1034
779 toStringTag schemas = mempty
1035 toStringTag schemas = mempty
780− & type_ ?~ SwaggerString
1036+ & type_ ?~ OpenApiString
781 & enum_ ?~ map (String . fst) sumSchemas
1037 & enum_ ?~ map (String . fst) sumSchemas
782
1038
783type AllNullary = All
1039type AllNullary = All
@@ -799,15 +1055,15 @@ gsumConToSchemaWith ref opts _ = (tag, schema)
799 case ref of
1055 case ref of
800 -- If subschema is an object and constructor is a record, we add tag directly
1056 -- If subschema is an object and constructor is a record, we add tag directly
801 -- to the record, as Aeson does it.
1057 -- to the record, as Aeson does it.
802− Just (Inline sub) | sub ^. type_ == Just SwaggerObject && isRecord -> Inline $ sub
1058+ Just (Inline sub) | sub ^. type_ == Just OpenApiObject && isRecord -> Inline $ sub
803 & required <>~ [T.pack tagField]
1059 & required <>~ [T.pack tagField]
804− & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])
1060+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
805
1061
806 -- If it is not a record, we need to put subschema into "contents" field.
1062 -- If it is not a record, we need to put subschema into "contents" field.
807 _ | not isRecord -> Inline $ mempty
1063 _ | not isRecord -> Inline $ mempty
808− & type_ ?~ SwaggerObject
1064+ & type_ ?~ OpenApiObject
809 & required .~ [T.pack tagField]
1065 & required .~ [T.pack tagField]
810− & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])
1066+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
811 -- If constructor is nullary, there is no content.
1067 -- If constructor is nullary, there is no content.
812 & case ref of
1068 & case ref of
813 Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField])
1069 Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField])
@@ -815,17 +1071,17 @@ gsumConToSchemaWith ref opts _ = (tag, schema)
815
1071
816 -- In the remaining cases we combine "tag" object and "contents" object using allOf.
1072 -- In the remaining cases we combine "tag" object and "contents" object using allOf.
817 _ -> Inline $ mempty
1073 _ -> Inline $ mempty
818− & type_ ?~ SwaggerObject
1074+ & type_ ?~ OpenApiObject
819 & allOf ?~ [Inline $ mempty
1075 & allOf ?~ [Inline $ mempty
820− & type_ ?~ SwaggerObject
1076+ & type_ ?~ OpenApiObject
821 & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])
1077 & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])
822− & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])]
1078+ & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])]
823 & if isRecord
1079 & if isRecord
824 then allOf . _Just <>~ [refOrNullary]
1080 then allOf . _Just <>~ [refOrNullary]
825− else allOf . _Just <>~ [Inline $ mempty & type_ ?~ SwaggerObject & properties . at (T.pack contentsField) ?~ refOrNullary]
1081+ else allOf . _Just <>~ [Inline $ mempty & type_ ?~ OpenApiObject & properties . at (T.pack contentsField) ?~ refOrNullary]
826 UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.
1082 UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.
827 ObjectWithSingleField -> Inline $ mempty
1083 ObjectWithSingleField -> Inline $ mempty
828− & type_ ?~ SwaggerObject
1084+ & type_ ?~ OpenApiObject
829 & required .~ [tag]
1085 & required .~ [tag]
830 & properties . at tag ?~ refOrNullary
1086 & properties . at tag ?~ refOrNullary
831 TwoElemArray -> error "unrepresentable in OpenAPI 3"
1087 TwoElemArray -> error "unrepresentable in OpenAPI 3"
@@ -833,7 +1089,7 @@ gsumConToSchemaWith ref opts _ = (tag, schema)
833 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
1089 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
834 isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)
1090 isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)
835 refOrNullary = fromMaybe (Inline nullarySchema) ref
1091 refOrNullary = fromMaybe (Inline nullarySchema) ref
836− refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) ref
1092+ refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) ref
837
1093
838gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
1094gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
839 SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)]
1095 SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)]
@@ -858,7 +1114,13 @@ data Proxy2 a b = Proxy2
858
1114
859data Proxy3 a b c = Proxy3
1115data Proxy3 a b c = Proxy3
860
1116
861−-- $setup
1117+{- $setup
862−-- >>> import Data.OpenApi
1118+>>> import Data.OpenApi
863−-- >>> import Data.Aeson (encode)
1119+>>> import Data.Aeson (encode)
864−-- >>> import Data.Aeson.Types (toJSONKeyText)
1120+>>> import Data.Aeson.Types (toJSONKeyText)
1121+>>> import Data.OpenApi.Internal.Utils
1122+>>> :set -XScopedTypeVariables
1123+>>> :set -XDeriveAnyClass
1124+>>> :set -XStandaloneDeriving
1125+>>> :set -XTypeApplications
1126+-}
src/Data/OpenApi/Internal/Schema/Validation.hs+72−60
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
@@ -31,11 +32,14 @@ import Control.Lens hiding (allOf)
31import Control.Monad (forM, forM_, when)
32import Control.Monad (forM, forM_, when)
32
33
33import Data.Aeson hiding (Result)
34import Data.Aeson hiding (Result)
34−import Data.Aeson.Encode.Pretty (encodePretty)
35+#if MIN_VERSION_aeson(2,0,0)
36+import qualified Data.Aeson.KeyMap as KeyMap
37+#endif
35import Data.Foldable (for_, sequenceA_,
38import Data.Foldable (for_, sequenceA_,
36 traverse_)
39 traverse_)
40+#if !MIN_VERSION_aeson(2,0,0)
37import Data.HashMap.Strict (HashMap)
41import Data.HashMap.Strict (HashMap)
38−import qualified Data.HashMap.Strict as HashMap
42+#endif
39import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
43import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
40import qualified "unordered-containers" Data.HashSet as HashSet
44import qualified "unordered-containers" Data.HashSet as HashSet
41import Data.Maybe (fromMaybe)
45import Data.Maybe (fromMaybe)
@@ -48,10 +52,12 @@ import qualified Data.Text.Lazy.Encoding as TL
48import Data.Vector (Vector)
52import Data.Vector (Vector)
49import qualified Data.Vector as Vector
53import qualified Data.Vector as Vector
50
54
55+import Data.OpenApi.Aeson.Compat (hasKey, keyToText, lookupKey, objectToList)
51−import Data.OpenApi.Declare
56+import Data.OpenApi.Declare
52−import Data.OpenApi.Internal
57+import Data.OpenApi.Internal
53−import Data.OpenApi.Internal.Schema
58+import Data.OpenApi.Internal.Schema
59+import Data.OpenApi.Internal.Utils
54−import Data.OpenApi.Lens
60+import Data.OpenApi.Lens
55
61
56-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
62-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
57-- This can be used with QuickCheck to ensure those instances are coherent:
63-- This can be used with QuickCheck to ensure those instances are coherent:
@@ -103,33 +109,33 @@ validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checke
103-- <BLANKLINE>
109-- <BLANKLINE>
104-- Swagger Schema:
110-- Swagger Schema:
105-- {
111-- {
106−-- "required": [
107−-- "name",
108−-- "phone"
109−-- ],
110−-- "type": "object",
111-- "properties": {
112-- "properties": {
112−-- "phone": {
113−-- "$ref": "#/components/schemas/Phone"
114−-- },
115-- "name": {
113-- "name": {
116-- "type": "string"
114-- "type": "string"
115+-- },
116+-- "phone": {
117+-- "$ref": "#/components/schemas/Phone"
117-- }
118-- }
118−-- }
119+-- },
120+-- "required": [
121+-- "name",
122+-- "phone"
123+-- ],
124+-- "type": "object"
119-- }
125-- }
120-- <BLANKLINE>
126-- <BLANKLINE>
121-- Swagger Description Context:
127-- Swagger Description Context:
122-- {
128-- {
123-- "Phone": {
129-- "Phone": {
124−-- "required": [
125−-- "value"
126−-- ],
127−-- "type": "object",
128-- "properties": {
130-- "properties": {
129-- "value": {
131-- "value": {
130-- "type": "string"
132-- "type": "string"
131-- }
133-- }
132−-- }
134+-- },
135+-- "required": [
136+-- "value"
137+-- ],
138+-- "type": "object"
133-- }
139-- }
134-- }
140-- }
135-- <BLANKLINE>
141-- <BLANKLINE>
@@ -315,11 +321,11 @@ validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do
315
321
316 check maximum_ $ \m ->
322 check maximum_ $ \m ->
317 when (if exMax then (n >= m) else (n > m)) $
323 when (if exMax then (n >= m) else (n > m)) $
318− invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")
324+ invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ (if exMax then "<" else "<=") ++ show m ++ ")")
319
325
320 check minimum_ $ \m ->
326 check minimum_ $ \m ->
321 when (if exMin then (n <= m) else (n < m)) $
327 when (if exMin then (n <= m) else (n < m)) $
322− invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")
328+ invalid ("value " ++ show n ++ " falls below minimum (should be " ++ (if exMin then ">" else ">=") ++ show m ++ ")")
323
329
324 check multipleOf $ \k ->
330 check multipleOf $ \k ->
325 when (not (isInteger (n / k))) $
331 when (not (isInteger (n / k))) $
@@ -353,8 +359,8 @@ validateArray xs = do
353 invalid ("array is too short (size should be >=" ++ show n ++ ")")
359 invalid ("array is too short (size should be >=" ++ show n ++ ")")
354
360
355 check items $ \case
361 check items $ \case
356− SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
362+ OpenApiItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
357− SwaggerItemsArray itemSchemas -> do
363+ OpenApiItemsArray itemSchemas -> do
358 when (len /= length itemSchemas) $
364 when (len /= length itemSchemas) $
359 invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")
365 invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")
360 sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
366 sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
@@ -366,10 +372,16 @@ validateArray xs = do
366 len = Vector.length xs
372 len = Vector.length xs
367 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
373 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
368
374
375+validateObject ::
376+#if MIN_VERSION_aeson(2,0,0)
377+ KeyMap.KeyMap Value
378+#else
369−validateObject :: HashMap Text Value -> Validation Schema ()
379+ HashMap Text Value
380+#endif
381+ -> Validation Schema ()
370validateObject o = withSchema $ \sch ->
382validateObject o = withSchema $ \sch ->
371 case sch ^. discriminator of
383 case sch ^. discriminator of
372− Just (Discriminator pname types) -> case fromJSON <$> HashMap.lookup pname o of
384+ Just (Discriminator pname types) -> case fromJSON <$> lookupKey pname o of
373 Just (Success pvalue) ->
385 Just (Success pvalue) ->
374 let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types
386 let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types
375 -- TODO ref may be name or reference
387 -- TODO ref may be name or reference
@@ -388,15 +400,15 @@ validateObject o = withSchema $ \sch ->
388 validateRequired
400 validateRequired
389 validateProps
401 validateProps
390 where
402 where
391− size = fromIntegral (HashMap.size o)
403+ size = fromIntegral (length o)
392
404
393 validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
405 validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
394 validateReq n =
406 validateReq n =
395− when (not (HashMap.member n o)) $
407+ when (not (hasKey n o)) $
396 invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
408 invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
397
409
398 validateProps = withSchema $ \sch -> do
410 validateProps = withSchema $ \sch -> do
399− for_ (HashMap.toList o) $ \(k, v) ->
411+ for_ (objectToList o) $ \(keyToText -> k, v) ->
400 case v of
412 case v of
401 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
413 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
402 _ ->
414 _ ->
@@ -423,10 +435,10 @@ validateEnum val = do
423-- This is like 'inferParamSchemaTypes', but also works for objects:
435-- This is like 'inferParamSchemaTypes', but also works for objects:
424--
436--
425-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
437-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
426−-- Just [SwaggerObject]
438+-- Just [OpenApiObject]
427−inferSchemaTypes :: Schema -> [SwaggerType]
439+inferSchemaTypes :: Schema -> [OpenApiType]
428inferSchemaTypes sch = inferParamSchemaTypes sch ++
440inferSchemaTypes sch = inferParamSchemaTypes sch ++
429− [ SwaggerObject | any ($ sch)
441+ [ OpenApiObject | any ($ sch)
430 [ has (additionalProperties._Just)
442 [ has (additionalProperties._Just)
431 , has (maxProperties._Just)
443 , has (maxProperties._Just)
432 , has (minProperties._Just)
444 , has (minProperties._Just)
@@ -436,30 +448,30 @@ inferSchemaTypes sch = inferParamSchemaTypes sch ++
436-- | Infer schema type based on used properties.
448-- | Infer schema type based on used properties.
437--
449--
438-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
450-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
439−-- Just [SwaggerString]
451+-- Just [OpenApiString]
440--
452--
441-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
453-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
442−-- Just [SwaggerArray]
454+-- Just [OpenApiArray]
443--
455--
444−-- From numeric properties 'SwaggerInteger' type is inferred.
456+-- From numeric properties 'OpenApiInteger' type is inferred.
445−-- If you want 'SwaggerNumber' instead, you must specify it explicitly.
457+-- If you want 'OpenApiNumber' instead, you must specify it explicitly.
446--
458--
447-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
459-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
448−-- Just [SwaggerInteger]
460+-- Just [OpenApiInteger]
449−inferParamSchemaTypes :: Schema -> [SwaggerType]
461+inferParamSchemaTypes :: Schema -> [OpenApiType]
450inferParamSchemaTypes sch = concat
462inferParamSchemaTypes sch = concat
451− [ [ SwaggerArray | any ($ sch)
463+ [ [ OpenApiArray | any ($ sch)
452 [ has (items._Just)
464 [ has (items._Just)
453 , has (maxItems._Just)
465 , has (maxItems._Just)
454 , has (minItems._Just)
466 , has (minItems._Just)
455 , has (uniqueItems._Just) ] ]
467 , has (uniqueItems._Just) ] ]
456− , [ SwaggerInteger | any ($ sch)
468+ , [ OpenApiInteger | any ($ sch)
457 [ has (exclusiveMaximum._Just)
469 [ has (exclusiveMaximum._Just)
458 , has (exclusiveMinimum._Just)
470 , has (exclusiveMinimum._Just)
459 , has (maximum_._Just)
471 , has (maximum_._Just)
460 , has (minimum_._Just)
472 , has (minimum_._Just)
461 , has (multipleOf._Just) ] ]
473 , has (multipleOf._Just) ] ]
462− , [ SwaggerString | any ($ sch)
474+ , [ OpenApiString | any ($ sch)
463 [ has (maxLength._Just)
475 [ has (maxLength._Just)
464 , has (minLength._Just)
476 , has (minLength._Just)
465 , has (pattern._Just) ] ]
477 , has (pattern._Just) ] ]
@@ -483,13 +495,13 @@ validateSchemaType val = withSchema $ \sch ->
483
495
484 _ ->
496 _ ->
485 case (sch ^. type_, val) of
497 case (sch ^. type_, val) of
486− (Just SwaggerNull, Null) -> valid
498+ (Just OpenApiNull, Null) -> valid
487− (Just SwaggerBoolean, Bool _) -> valid
499+ (Just OpenApiBoolean, Bool _) -> valid
488− (Just SwaggerInteger, Number n) -> validateInteger n
500+ (Just OpenApiInteger, Number n) -> validateInteger n
489− (Just SwaggerNumber, Number n) -> validateNumber n
501+ (Just OpenApiNumber, Number n) -> validateNumber n
490− (Just SwaggerString, String s) -> validateString s
502+ (Just OpenApiString, String s) -> validateString s
491− (Just SwaggerArray, Array xs) -> validateArray xs
503+ (Just OpenApiArray, Array xs) -> validateArray xs
492− (Just SwaggerObject, Object o) -> validateObject o
504+ (Just OpenApiObject, Object o) -> validateObject o
493 (Nothing, Null) -> valid
505 (Nothing, Null) -> valid
494 (Nothing, Bool _) -> valid
506 (Nothing, Bool _) -> valid
495 -- Number by default
507 -- Number by default
@@ -502,11 +514,11 @@ validateSchemaType val = withSchema $ \sch ->
502validateParamSchemaType :: Value -> Validation Schema ()
514validateParamSchemaType :: Value -> Validation Schema ()
503validateParamSchemaType val = withSchema $ \sch ->
515validateParamSchemaType val = withSchema $ \sch ->
504 case (sch ^. type_, val) of
516 case (sch ^. type_, val) of
505− (Just SwaggerBoolean, Bool _) -> valid
517+ (Just OpenApiBoolean, Bool _) -> valid
506− (Just SwaggerInteger, Number n) -> validateInteger n
518+ (Just OpenApiInteger, Number n) -> validateInteger n
507− (Just SwaggerNumber, Number n) -> validateNumber n
519+ (Just OpenApiNumber, Number n) -> validateNumber n
508− (Just SwaggerString, String s) -> validateString s
520+ (Just OpenApiString, String s) -> validateString s
509− (Just SwaggerArray, Array xs) -> validateArray xs
521+ (Just OpenApiArray, Array xs) -> validateArray xs
510 (Nothing, Bool _) -> valid
522 (Nothing, Bool _) -> valid
511 -- Number by default
523 -- Number by default
512 (Nothing, Number n) -> validateNumber n
524 (Nothing, Number n) -> validateNumber n
@@ -514,11 +526,11 @@ validateParamSchemaType val = withSchema $ \sch ->
514 (Nothing, Array xs) -> validateArray xs
526 (Nothing, Array xs) -> validateArray xs
515 bad -> invalid $ "expected JSON value of type " ++ showType bad
527 bad -> invalid $ "expected JSON value of type " ++ showType bad
516
528
517−showType :: (Maybe SwaggerType, Value) -> String
529+showType :: (Maybe OpenApiType, Value) -> String
518showType (Just ty, _) = show ty
530showType (Just ty, _) = show ty
519−showType (Nothing, Null) = "SwaggerNull"
531+showType (Nothing, Null) = "OpenApiNull"
520−showType (Nothing, Bool _) = "SwaggerBoolean"
532+showType (Nothing, Bool _) = "OpenApiBoolean"
521−showType (Nothing, Number _) = "SwaggerNumber"
533+showType (Nothing, Number _) = "OpenApiNumber"
522−showType (Nothing, String _) = "SwaggerString"
534+showType (Nothing, String _) = "OpenApiString"
523−showType (Nothing, Array _) = "SwaggerArray"
535+showType (Nothing, Array _) = "OpenApiArray"
524−showType (Nothing, Object _) = "SwaggerObject"
536+showType (Nothing, Object _) = "OpenApiObject"
src/Data/OpenApi/Internal/Utils.hs+5
@@ -13,6 +13,8 @@ import Control.Lens ((&), (%~))
13import Control.Lens.TH
13import Control.Lens.TH
14import Data.Aeson
14import Data.Aeson
15import Data.Aeson.Types
15import Data.Aeson.Types
16+import qualified Data.Aeson.Encode.Pretty as P
17+import qualified Data.ByteString.Lazy as BSL
16import Data.Char
18import Data.Char
17import Data.Data
19import Data.Data
18import Data.Hashable (Hashable)
20import Data.Hashable (Hashable)
@@ -132,3 +134,6 @@ instance SwaggerMonoid (Maybe a) where
132 swaggerMempty = Nothing
134 swaggerMempty = Nothing
133 swaggerMappend x Nothing = x
135 swaggerMappend x Nothing = x
134 swaggerMappend _ y = y
136 swaggerMappend _ y = y
137+
138+encodePretty :: ToJSON a => a -> BSL.ByteString
139+encodePretty = P.encodePretty' $ P.defConfig { P.confCompare = P.compare }
src/Data/OpenApi/Lens.hs+15−15
@@ -64,24 +64,24 @@ makePrisms ''SecuritySchemeType
64-- ** 'Referenced' prisms
64-- ** 'Referenced' prisms
65makePrisms ''Referenced
65makePrisms ''Referenced
66
66
67−-- ** 'SwaggerItems' prisms
67+-- ** 'OpenApiItems' prisms
68
68
69−_SwaggerItemsArray :: Review SwaggerItems [Referenced Schema]
69+_OpenApiItemsArray :: Review OpenApiItems [Referenced Schema]
70−_SwaggerItemsArray
70+_OpenApiItemsArray
71− = unto (\x -> SwaggerItemsArray x)
71+ = unto (\x -> OpenApiItemsArray x)
72{- \x -> case x of
72{- \x -> case x of
73− SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
73+ OpenApiItemsPrimitive c p -> Left (OpenApiItemsPrimitive c p)
74− SwaggerItemsObject o -> Left (SwaggerItemsObject o)
74+ OpenApiItemsObject o -> Left (OpenApiItemsObject o)
75− SwaggerItemsArray a -> Right a
75+ OpenApiItemsArray a -> Right a
76-}
76-}
77
77
78−_SwaggerItemsObject :: Review SwaggerItems (Referenced Schema)
78+_OpenApiItemsObject :: Review OpenApiItems (Referenced Schema)
79−_SwaggerItemsObject
79+_OpenApiItemsObject
80− = unto (\x -> SwaggerItemsObject x)
80+ = unto (\x -> OpenApiItemsObject x)
81{- \x -> case x of
81{- \x -> case x of
82− SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
82+ OpenApiItemsPrimitive c p -> Left (OpenApiItemsPrimitive c p)
83− SwaggerItemsObject o -> Right o
83+ OpenApiItemsObject o -> Right o
84− SwaggerItemsArray a -> Left (SwaggerItemsArray a)
84+ OpenApiItemsArray a -> Left (OpenApiItemsArray a)
85-}
85-}
86
86
87-- =============================================================
87-- =============================================================
@@ -99,7 +99,7 @@ instance At Responses where at n = responses . at n
99instance Ixed Operation where ix n = responses . ix n
99instance Ixed Operation where ix n = responses . ix n
100instance At Operation where at n = responses . at n
100instance At Operation where at n = responses . at n
101
101
102−instance HasType NamedSchema (Maybe SwaggerType) where type_ = schema.type_
102+instance HasType NamedSchema (Maybe OpenApiType) where type_ = schema.type_
103
103
104-- OVERLAPPABLE instances
104-- OVERLAPPABLE instances
105
105
@@ -112,7 +112,7 @@ instance
112instance
112instance
113 {-# OVERLAPPABLE #-}
113 {-# OVERLAPPABLE #-}
114 HasSchema s Schema
114 HasSchema s Schema
115− => HasItems s (Maybe SwaggerItems) where
115+ => HasItems s (Maybe OpenApiItems) where
116 items = schema.items
116 items = schema.items
117
117
118instance
118instance
src/Data/OpenApi/Operation.hs+117−10
@@ -55,13 +55,16 @@ import qualified Data.HashSet.InsOrd as InsOrdHS
55-- >>> import Data.Proxy
55-- >>> import Data.Proxy
56-- >>> import Data.Time
56-- >>> import Data.Time
57-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
57-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
58+-- >>> import Data.OpenApi.Internal.Utils
58
59
59-- | Prepend path piece to all operations of the spec.
60-- | Prepend path piece to all operations of the spec.
60-- Leading and trailing slashes are trimmed/added automatically.
61-- Leading and trailing slashes are trimmed/added automatically.
61--
62--
62-- >>> let api = (mempty :: OpenApi) & paths .~ [("/info", mempty)]
63-- >>> let api = (mempty :: OpenApi) & paths .~ [("/info", mempty)]
63−-- >>> BSL.putStrLn $ encode $ prependPath "user/{user_id}" api ^. paths
64+-- >>> BSL.putStrLn $ encodePretty $ prependPath "user/{user_id}" api ^. paths
65+-- {
64−-- {"/user/{user_id}/info":{}}
66+-- "/user/{user_id}/info": {}
67+-- }
65prependPath :: FilePath -> OpenApi -> OpenApi
68prependPath :: FilePath -> OpenApi -> OpenApi
66prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
69prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
67 where
70 where
@@ -82,10 +85,63 @@ allOperations = paths.traverse.template
82-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
85-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
83-- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
86-- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
84-- >>> let sub = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)]
87-- >>> let sub = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)]
85−-- >>> BSL.putStrLn $ encode api
88+-- >>> BSL.putStrLn $ encodePretty api
86−-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}}
89+-- {
90+-- "components": {},
91+-- "info": {
92+-- "title": "",
93+-- "version": ""
94+-- },
95+-- "openapi": "3.0.0",
96+-- "paths": {
97+-- "/user": {
98+-- "get": {
99+-- "responses": {
100+-- "200": {
101+-- "description": "OK"
102+-- }
103+-- }
104+-- },
105+-- "post": {
106+-- "responses": {
107+-- "200": {
108+-- "description": "OK"
109+-- }
110+-- }
111+-- }
112+-- }
113+-- }
114+-- }
87−-- >>> BSL.putStrLn $ encode $ api & operationsOf sub . at 404 ?~ "Not found"
115+-- >>> BSL.putStrLn $ encodePretty $ api & operationsOf sub . at 404 ?~ "Not found"
88−-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"Not found"},"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}}
116+-- {
117+-- "components": {},
118+-- "info": {
119+-- "title": "",
120+-- "version": ""
121+-- },
122+-- "openapi": "3.0.0",
123+-- "paths": {
124+-- "/user": {
125+-- "get": {
126+-- "responses": {
127+-- "200": {
128+-- "description": "OK"
129+-- },
130+-- "404": {
131+-- "description": "Not found"
132+-- }
133+-- }
134+-- },
135+-- "post": {
136+-- "responses": {
137+-- "200": {
138+-- "description": "OK"
139+-- }
140+-- }
141+-- }
142+-- }
143+-- }
144+-- }
89operationsOf :: OpenApi -> Traversal' OpenApi Operation
145operationsOf :: OpenApi -> Traversal' OpenApi Operation
90operationsOf sub = paths.itraversed.withIndex.subops
146operationsOf sub = paths.itraversed.withIndex.subops
91 where
147 where
@@ -123,8 +179,26 @@ applyTagsFor ops ts swag = swag
123--
179--
124-- FIXME doc
180-- FIXME doc
125--
181--
126−-- >>> BSL.putStrLn $ encode $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty
182+-- >>> BSL.putStrLn $ encodePretty $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty
127−-- [{"Day":{"example":"2016-07-22","format":"date","type":"string"}},{"description":"","content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}}}]
183+-- [
184+-- {
185+-- "Day": {
186+-- "example": "2016-07-22",
187+-- "format": "date",
188+-- "type": "string"
189+-- }
190+-- },
191+-- {
192+-- "content": {
193+-- "application/json": {
194+-- "schema": {
195+-- "$ref": "#/components/schemas/Day"
196+-- }
197+-- }
198+-- },
199+-- "description": ""
200+-- }
201+-- ]
128declareResponse :: ToSchema a => MediaType -> Proxy a -> Declare (Definitions Schema) Response
202declareResponse :: ToSchema a => MediaType -> Proxy a -> Declare (Definitions Schema) Response
129declareResponse cType proxy = do
203declareResponse cType proxy = do
130 s <- declareSchemaRef proxy
204 s <- declareSchemaRef proxy
@@ -143,8 +217,41 @@ declareResponse cType proxy = do
143--
217--
144-- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)]
218-- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)]
145-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day)
219-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day)
146−-- >>> BSL.putStrLn $ encode $ api & setResponse 200 res
220+-- >>> BSL.putStrLn $ encodePretty $ api & setResponse 200 res
147−-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}},"description":""}}}}},"components":{"schemas":{"Day":{"example":"2016-07-22","format":"date","type":"string"}}}}
221+-- {
222+-- "components": {
223+-- "schemas": {
224+-- "Day": {
225+-- "example": "2016-07-22",
226+-- "format": "date",
227+-- "type": "string"
228+-- }
229+-- }
230+-- },
231+-- "info": {
232+-- "title": "",
233+-- "version": ""
234+-- },
235+-- "openapi": "3.0.0",
236+-- "paths": {
237+-- "/user": {
238+-- "get": {
239+-- "responses": {
240+-- "200": {
241+-- "content": {
242+-- "application/json": {
243+-- "schema": {
244+-- "$ref": "#/components/schemas/Day"
245+-- }
246+-- }
247+-- },
248+-- "description": ""
249+-- }
250+-- }
251+-- }
252+-- }
253+-- }
254+-- }
148--
255--
149-- See also @'setResponseWith'@.
256-- See also @'setResponseWith'@.
150setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
257setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
src/Data/OpenApi/Optics.hs+69−24
@@ -22,43 +22,88 @@
22-- Example from the "Data.OpenApi" module using @optics@:
22-- Example from the "Data.OpenApi" module using @optics@:
23--
23--
24-- >>> :{
24-- >>> :{
25−-- BSL.putStrLn $ encode $ (mempty :: OpenApi)
25+-- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)
26−-- & #components % #schemas .~ [ ("User", mempty & #type ?~ SwaggerString) ]
26+-- & #components % #schemas .~ [ ("User", mempty & #type ?~ OpenApiString) ]
27-- & #paths .~
27-- & #paths .~
28-- [ ("/user", mempty & #get ?~ (mempty
28-- [ ("/user", mempty & #get ?~ (mempty
29-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User")))
29-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User")))
30-- & at 404 ?~ "User info not found")) ]
30-- & at 404 ?~ "User info not found")) ]
31-- :}
31-- :}
32−-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}}
32+-- {
33+-- "components": {
34+-- "schemas": {
35+-- "User": {
36+-- "type": "string"
37+-- }
38+-- }
39+-- },
40+-- "info": {
41+-- "title": "",
42+-- "version": ""
43+-- },
44+-- "openapi": "3.0.0",
45+-- "paths": {
46+-- "/user": {
47+-- "get": {
48+-- "responses": {
49+-- "200": {
50+-- "content": {
51+-- "application/json": {
52+-- "schema": {
53+-- "$ref": "#/components/schemas/User"
54+-- }
55+-- }
56+-- },
57+-- "description": "OK"
58+-- },
59+-- "404": {
60+-- "description": "User info not found"
61+-- }
62+-- }
63+-- }
64+-- }
65+-- }
66+-- }
33--
67--
34-- For convenience optics are defined as /labels/. It means that field accessor
68-- For convenience optics are defined as /labels/. It means that field accessor
35-- names can be overloaded for different types. One such common field is
69-- names can be overloaded for different types. One such common field is
36-- @#description@. Many components of a Swagger specification can have
70-- @#description@. Many components of a Swagger specification can have
37-- descriptions, and you can use the same name for them:
71-- descriptions, and you can use the same name for them:
38--
72--
39−-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & #description .~ "No content"
73+-- >>> BSL.putStrLn $ encodePretty $ (mempty :: Response) & #description .~ "No content"
74+-- {
40−-- {"description":"No content"}
75+-- "description": "No content"
76+-- }
41-- >>> :{
77-- >>> :{
42−-- BSL.putStrLn $ encode $ (mempty :: Schema)
78+-- BSL.putStrLn $ encodePretty $ (mempty :: Schema)
43−-- & #type ?~ SwaggerBoolean
79+-- & #type ?~ OpenApiBoolean
44-- & #description ?~ "To be or not to be"
80-- & #description ?~ "To be or not to be"
45-- :}
81-- :}
82+-- {
46−-- {"type":"boolean","description":"To be or not to be"}
83+-- "description": "To be or not to be",
84+-- "type": "boolean"
85+-- }
47--
86--
48-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
87-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
49-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
88-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
50--
89--
51-- >>> :{
90-- >>> :{
52−-- BSL.putStrLn $ encode $ (mempty :: Operation)
91+-- BSL.putStrLn $ encodePretty $ (mempty :: Operation)
53-- & at 404 ?~ "Not found"
92-- & at 404 ?~ "Not found"
54-- :}
93-- :}
94+-- {
95+-- "responses": {
96+-- "404": {
55−-- {"responses":{"404":{"description":"Not found"}}}
97+-- "description": "Not found"
98+-- }
99+-- }
56−--
100+-- }
57module Data.OpenApi.Optics () where
101module Data.OpenApi.Optics () where
58
102
59import Data.Aeson (Value)
103import Data.Aeson (Value)
60import Data.Scientific (Scientific)
104import Data.Scientific (Scientific)
61import Data.OpenApi.Internal
105import Data.OpenApi.Internal
106+import Data.OpenApi.Internal.Utils
62import Data.Text (Text)
107import Data.Text (Text)
63import Optics.Core
108import Optics.Core
64import Optics.TH
109import Optics.TH
@@ -103,30 +148,30 @@ makeFieldLabels ''Link
103makePrismLabels ''SecuritySchemeType
148makePrismLabels ''SecuritySchemeType
104makePrismLabels ''Referenced
149makePrismLabels ''Referenced
105
150
106−-- SwaggerItems prisms
151+-- OpenApiItems prisms
107
152
108instance
153instance
109 ( a ~ [Referenced Schema]
154 ( a ~ [Referenced Schema]
110 , b ~ [Referenced Schema]
155 , b ~ [Referenced Schema]
111− ) => LabelOptic "_SwaggerItemsArray"
156+ ) => LabelOptic "_OpenApiItemsArray"
112 A_Review
157 A_Review
113− SwaggerItems
158+ OpenApiItems
114− SwaggerItems
159+ OpenApiItems
115 a
160 a
116 b where
161 b where
117− labelOptic = unto (\x -> SwaggerItemsArray x)
162+ labelOptic = unto (\x -> OpenApiItemsArray x)
118 {-# INLINE labelOptic #-}
163 {-# INLINE labelOptic #-}
119
164
120instance
165instance
121 ( a ~ Referenced Schema
166 ( a ~ Referenced Schema
122 , b ~ Referenced Schema
167 , b ~ Referenced Schema
123− ) => LabelOptic "_SwaggerItemsObject"
168+ ) => LabelOptic "_OpenApiItemsObject"
124 A_Review
169 A_Review
125− SwaggerItems
170+ OpenApiItems
126− SwaggerItems
171+ OpenApiItems
127 a
172 a
128 b where
173 b where
129− labelOptic = unto (\x -> SwaggerItemsObject x)
174+ labelOptic = unto (\x -> OpenApiItemsObject x)
130 {-# INLINE labelOptic #-}
175 {-# INLINE labelOptic #-}
131
176
132-- =============================================================
177-- =============================================================
@@ -155,8 +200,8 @@ instance At Operation where
155-- #type
200-- #type
156
201
157instance
202instance
158− ( a ~ Maybe SwaggerType
203+ ( a ~ Maybe OpenApiType
159− , b ~ Maybe SwaggerType
204+ , b ~ Maybe OpenApiType
160 ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
205 ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
161 labelOptic = #schema % #type
206 labelOptic = #schema % #type
162 {-# INLINE labelOptic #-}
207 {-# INLINE labelOptic #-}
@@ -180,8 +225,8 @@ instance
180-- #items
225-- #items
181
226
182instance
227instance
183− ( a ~ Maybe SwaggerItems
228+ ( a ~ Maybe OpenApiItems
184− , b ~ Maybe SwaggerItems
229+ , b ~ Maybe OpenApiItems
185 ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
230 ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
186 labelOptic = #schema % #items
231 labelOptic = #schema % #items
187 {-# INLINE labelOptic #-}
232 {-# INLINE labelOptic #-}
src/Data/OpenApi/Schema/Generator.hs+12−10
@@ -25,6 +25,8 @@ import Test.QuickCheck (arbitrary)
25import Test.QuickCheck.Gen
25import Test.QuickCheck.Gen
26import Test.QuickCheck.Property
26import Test.QuickCheck.Property
27
27
28+import Data.OpenApi.Aeson.Compat (fromInsOrdHashMap)
29+
28-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30-- | Note: 'schemaGen' may 'error', if schema type is not specified,
29-- and cannot be inferred.
31-- and cannot be inferred.
30schemaGen :: Definitions Schema -> Schema -> Gen Value
32schemaGen :: Definitions Schema -> Schema -> Gen Value
@@ -39,25 +41,25 @@ schemaGen defns schema =
39 [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
41 [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
40 -- Gen is not MonadFail
42 -- Gen is not MonadFail
41 _ -> error "unable to infer schema type"
43 _ -> error "unable to infer schema type"
42− Just SwaggerBoolean -> Bool <$> elements [True, False]
44+ Just OpenApiBoolean -> Bool <$> elements [True, False]
43− Just SwaggerNull -> pure Null
45+ Just OpenApiNull -> pure Null
44− Just SwaggerNumber
46+ Just OpenApiNumber
45 | Just min <- schema ^. minimum_
47 | Just min <- schema ^. minimum_
46 , Just max <- schema ^. maximum_ ->
48 , Just max <- schema ^. maximum_ ->
47 Number . fromFloatDigits <$>
49 Number . fromFloatDigits <$>
48 choose (toRealFloat min, toRealFloat max :: Double)
50 choose (toRealFloat min, toRealFloat max :: Double)
49 | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
51 | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
50− Just SwaggerInteger
52+ Just OpenApiInteger
51 | Just min <- schema ^. minimum_
53 | Just min <- schema ^. minimum_
52 , Just max <- schema ^. maximum_ ->
54 , Just max <- schema ^. maximum_ ->
53 Number . fromInteger <$>
55 Number . fromInteger <$>
54 choose (truncate min, truncate max)
56 choose (truncate min, truncate max)
55 | otherwise -> Number . fromInteger <$> arbitrary
57 | otherwise -> Number . fromInteger <$> arbitrary
56− Just SwaggerArray
58+ Just OpenApiArray
57 | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
59 | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
58 | Just items <- schema ^. items ->
60 | Just items <- schema ^. items ->
59 case items of
61 case items of
60− SwaggerItemsObject ref -> do
62+ OpenApiItemsObject ref -> do
61 size <- getSize
63 size <- getSize
62 let itemSchema = dereference defns ref
64 let itemSchema = dereference defns ref
63 minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
65 minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
@@ -65,17 +67,17 @@ schemaGen defns schema =
65 arrayLength <- choose (minLength', max minLength' maxLength')
67 arrayLength <- choose (minLength', max minLength' maxLength')
66 generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
68 generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
67 return . Array $ V.fromList generatedArray
69 return . Array $ V.fromList generatedArray
68− SwaggerItemsArray refs ->
70+ OpenApiItemsArray refs ->
69 let itemGens = schemaGen defns . dereference defns <$> refs
71 let itemGens = schemaGen defns . dereference defns <$> refs
70 in fmap (Array . V.fromList) $ sequence itemGens
72 in fmap (Array . V.fromList) $ sequence itemGens
71− Just SwaggerString -> do
73+ Just OpenApiString -> do
72 size <- getSize
74 size <- getSize
73 let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
75 let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
74 let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
76 let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
75 length <- choose (minLength', max minLength' maxLength')
77 length <- choose (minLength', max minLength' maxLength')
76 str <- vectorOf length arbitrary
78 str <- vectorOf length arbitrary
77 return . String $ T.pack str
79 return . String $ T.pack str
78− Just SwaggerObject -> do
80+ Just OpenApiObject -> do
79 size <- getSize
81 size <- getSize
80 let props = dereference defns <$> schema ^. properties
82 let props = dereference defns <$> schema ^. properties
81 reqKeys = S.fromList $ schema ^. required
83 reqKeys = S.fromList $ schema ^. required
@@ -95,7 +97,7 @@ schemaGen defns schema =
95 return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
97 return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
96 _ -> return []
98 _ -> return []
97 x <- sequence $ gens <> additionalGens
99 x <- sequence $ gens <> additionalGens
98− return . Object $ M.toHashMap x
100+ return . Object $ fromInsOrdHashMap x
99
101
100dereference :: Definitions a -> Referenced a -> a
102dereference :: Definitions a -> Referenced a -> a
101dereference _ (Inline a) = a
103dereference _ (Inline a) = a
src/Data/OpenApi/Schema/Validation.hs+3−3
@@ -71,11 +71,11 @@ import Data.OpenApi.Internal.Schema.Validation
71-- generally fails for @null@ JSON:
71-- generally fails for @null@ JSON:
72--
72--
73-- >>> validateToJSON (Nothing :: Maybe String)
73-- >>> validateToJSON (Nothing :: Maybe String)
74−-- ["expected JSON value of type SwaggerString"]
74+-- ["expected JSON value of type OpenApiString"]
75-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
75-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
76−-- ["expected JSON value of type SwaggerString"]
76+-- ["expected JSON value of type OpenApiString"]
77-- >>> validateToJSON (123, Nothing :: Maybe String)
77-- >>> validateToJSON (123, Nothing :: Maybe String)
78−-- ["expected JSON value of type SwaggerString"]
78+-- ["expected JSON value of type OpenApiString"]
79--
79--
80-- However, when @'Maybe' a@ is a type of a record field,
80-- However, when @'Maybe' a@ is a type of a record field,
81-- validation takes @'required'@ property of the @'Schema'@
81-- validation takes @'required'@ property of the @'Schema'@
stack.yaml+1−1
@@ -1,4 +1,4 @@
1−resolver: lts-16.8
1+resolver: lts-16.31
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-deps:
test/Data/OpenApi/CommonTestTypes.hs+123
@@ -863,6 +863,129 @@ singleMaybeFieldSchemaJSON = [aesonQQ|
863}
863}
864|]
864|]
865
865
866+-- ========================================================================
867+-- Natural Language (single field data with recursive fields)
868+-- ========================================================================
869+
870+data Predicate
871+ = PredicateNoun Noun
872+ | PredicateOmitted Omitted
873+ deriving (Eq, Ord, Read, Show, Generic)
874+instance ToJSON Predicate
875+instance ToSchema Predicate
876+
877+data Noun
878+ = Noun
879+ { nounSurf :: LangWord
880+ , nounModify :: [Modifier]
881+ }
882+ deriving (Eq, Ord, Read, Show, Generic)
883+instance ToJSON Noun
884+instance ToSchema Noun
885+
886+data LangWord
887+ = LangWord
888+ { langWordSurf :: String
889+ , langWordBase :: String
890+ }
891+ deriving (Eq, Ord, Read, Show, Generic)
892+instance ToJSON LangWord
893+instance ToSchema LangWord
894+
895+data Modifier
896+ = ModifierNoun Noun
897+ | ModifierOmitted Omitted
898+ deriving (Eq, Ord, Read, Show, Generic)
899+instance ToJSON Modifier
900+instance ToSchema Modifier
901+
902+newtype Omitted
903+ = Omitted
904+ { omittedModify :: [Modifier]
905+ }
906+ deriving (Eq, Ord, Read, Show, Generic)
907+instance ToJSON Omitted
908+instance ToSchema Omitted
909+
910+predicateSchemaDeclareJSON :: Value
911+predicateSchemaDeclareJSON = [aesonQQ|
912+[
913+ {
914+ "Predicate": {
915+ "oneOf": [
916+ {
917+ "properties": {
918+ "contents": { "$ref": "#/components/schemas/Noun" },
919+ "tag": { "enum": ["PredicateNoun"], "type": "string" }
920+ },
921+ "required": ["tag", "contents"],
922+ "type": "object"
923+ },
924+ {
925+ "properties": {
926+ "contents": { "$ref": "#/components/schemas/Omitted" },
927+ "tag": { "enum": ["PredicateOmitted"], "type": "string" }
928+ },
929+ "required": ["tag", "contents"],
930+ "type": "object"
931+ }
932+ ],
933+ "type": "object"
934+ },
935+ "Noun": {
936+ "properties": {
937+ "nounModify": {
938+ "items": { "$ref": "#/components/schemas/Modifier" },
939+ "type": "array"
940+ },
941+ "nounSurf": { "$ref": "#/components/schemas/LangWord" }
942+ },
943+ "required": ["nounSurf", "nounModify"],
944+ "type": "object"
945+ },
946+ "LangWord": {
947+ "properties": {
948+ "langWordBase": { "type": "string" },
949+ "langWordSurf": { "type": "string" }
950+ },
951+ "required": ["langWordSurf", "langWordBase"],
952+ "type": "object"
953+ },
954+ "Modifier": {
955+ "oneOf": [
956+ {
957+ "properties": {
958+ "contents": { "$ref": "#/components/schemas/Noun" },
959+ "tag": { "enum": ["ModifierNoun"], "type": "string" }
960+ },
961+ "required": ["tag", "contents"],
962+ "type": "object"
963+ },
964+ {
965+ "properties": {
966+ "contents": { "$ref": "#/components/schemas/Omitted" },
967+ "tag": { "enum": ["ModifierOmitted"], "type": "string" }
968+ },
969+ "required": ["tag", "contents"],
970+ "type": "object"
971+ }
972+ ],
973+ "type": "object"
974+ },
975+ "Omitted": {
976+ "properties": {
977+ "omittedModify": {
978+ "items": { "$ref": "#/components/schemas/Modifier" },
979+ "type": "array"
980+ }
981+ },
982+ "required": ["omittedModify"],
983+ "type": "object"
984+ }
985+ },
986+ { "$ref": "#/components/schemas/Predicate" }
987+]
988+|]
866
989
867-- ========================================================================
990-- ========================================================================
868-- TimeOfDay
991-- TimeOfDay
test/Data/OpenApi/Schema/GeneratorSpec.hs+4−4
@@ -103,7 +103,7 @@ instance FromJSON WrongType where
103instance ToSchema WrongType where
103instance ToSchema WrongType where
104 declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
104 declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105 mempty
105 mempty
106− & type_ ?~ SwaggerObject
106+ & type_ ?~ OpenApiObject
107
107
108
108
109data MissingRequired = MissingRequired
109data MissingRequired = MissingRequired
@@ -123,7 +123,7 @@ instance ToSchema MissingRequired where
123 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
123 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124 return . NamedSchema (Just "MissingRequired") $
124 return . NamedSchema (Just "MissingRequired") $
125 mempty
125 mempty
126− & type_ ?~ SwaggerObject
126+ & type_ ?~ OpenApiObject
127 & properties .~ [("propA", stringSchema)
127 & properties .~ [("propA", stringSchema)
128 ,("propB", boolSchema)
128 ,("propB", boolSchema)
129 ]
129 ]
@@ -145,7 +145,7 @@ instance ToSchema MissingProperty where
145 stringSchema <- declareSchemaRef (Proxy :: Proxy String)
145 stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146 return . NamedSchema (Just "MissingProperty") $
146 return . NamedSchema (Just "MissingProperty") $
147 mempty
147 mempty
148− & type_ ?~ SwaggerObject
148+ & type_ ?~ OpenApiObject
149 & properties .~ [("propC", stringSchema)]
149 & properties .~ [("propC", stringSchema)]
150 & required .~ ["propC"]
150 & required .~ ["propC"]
151
151
@@ -163,6 +163,6 @@ instance ToSchema WrongPropType where
163 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
163 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164 return . NamedSchema (Just "WrongPropType") $
164 return . NamedSchema (Just "WrongPropType") $
165 mempty
165 mempty
166− & type_ ?~ SwaggerObject
166+ & type_ ?~ OpenApiObject
167 & properties .~ [("propE", boolSchema)]
167 & properties .~ [("propE", boolSchema)]
168 & required .~ ["propE"]
168 & required .~ ["propE"]
test/Data/OpenApi/Schema/ValidationSpec.hs+21−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE PackageImports #-}
3{-# LANGUAGE PackageImports #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE RecordWildCards #-}
@@ -8,6 +9,10 @@ module Data.OpenApi.Schema.ValidationSpec where
8import Control.Applicative
9import Control.Applicative
9import Control.Lens ((&), (.~), (?~))
10import Control.Lens ((&), (.~), (?~))
10import Data.Aeson
11import Data.Aeson
12+#if MIN_VERSION_aeson(2,0,0)
13+import qualified Data.Aeson.Key as Key
14+import qualified Data.Aeson.KeyMap as KeyMap
15+#endif
11import Data.Aeson.Types
16import Data.Aeson.Types
12import Data.Hashable (Hashable)
17import Data.Hashable (Hashable)
13import Data.HashMap.Strict (HashMap)
18import Data.HashMap.Strict (HashMap)
@@ -30,6 +35,7 @@ import GHC.Generics
30
35
31import Data.OpenApi
36import Data.OpenApi
32import Data.OpenApi.Declare
37import Data.OpenApi.Declare
38+import Data.OpenApi.Aeson.Compat (stringToKey)
33
39
34import Test.Hspec
40import Test.Hspec
35import Test.Hspec.QuickCheck
41import Test.Hspec.QuickCheck
@@ -124,9 +130,9 @@ instance Arbitrary Person where
124
130
125invalidPersonToJSON :: Person -> Value
131invalidPersonToJSON :: Person -> Value
126invalidPersonToJSON Person{..} = object
132invalidPersonToJSON Person{..} = object
127− [ T.pack "personName" .= toJSON name
133+ [ stringToKey "personName" .= toJSON name
128− , T.pack "personPhone" .= toJSON phone
134+ , stringToKey "personPhone" .= toJSON phone
129− , T.pack "personEmail" .= toJSON email
135+ , stringToKey "personEmail" .= toJSON email
130 ]
136 ]
131
137
132-- ========================================================================
138-- ========================================================================
@@ -277,7 +283,7 @@ instance ToJSON FreeForm where
277
283
278instance ToSchema FreeForm where
284instance ToSchema FreeForm where
279 declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
285 declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
280− & type_ ?~ SwaggerObject
286+ & type_ ?~ OpenApiObject
281 & additionalProperties ?~ AdditionalPropertiesAllowed True
287 & additionalProperties ?~ AdditionalPropertiesAllowed True
282
288
283instance Arbitrary FreeForm where
289instance Arbitrary FreeForm where
@@ -295,6 +301,8 @@ instance Eq ZonedTime where
295-- Arbitrary instance for Data.Aeson.Value
301-- Arbitrary instance for Data.Aeson.Value
296-- ========================================================================
302-- ========================================================================
297
303
304+-- These instances were introduces in aeson upstream in 2.0.3
305+#if !MIN_VERSION_aeson(2,0,3)
298instance Arbitrary Value where
306instance Arbitrary Value where
299 -- Weights are almost random
307 -- Weights are almost random
300 -- Uniform oneof tends not to build complex objects cause of recursive call.
308 -- Uniform oneof tends not to build complex objects cause of recursive call.
@@ -305,3 +313,12 @@ instance Arbitrary Value where
305 , (3, Number <$> arbitrary)
313 , (3, Number <$> arbitrary)
306 , (3, Bool <$> arbitrary)
314 , (3, Bool <$> arbitrary)
307 , (1, return Null) ]
315 , (1, return Null) ]
316+
317+#if MIN_VERSION_aeson(2,0,0)
318+instance Arbitrary v => Arbitrary (KeyMap.KeyMap v) where
319+ arbitrary = KeyMap.fromList <$> arbitrary
320+
321+instance Arbitrary Key.Key where
322+ arbitrary = Key.fromText <$> arbitrary
323+#endif
324+#endif
test/Data/OpenApi/SchemaSpec.hs+4
@@ -59,6 +59,9 @@ checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
59 where
59 where
60 (defs, s) = runDeclare (declareSchema proxy) mempty
60 (defs, s) = runDeclare (declareSchema proxy) mempty
61
61
62+checkToSchemaDeclare :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec
63+checkToSchemaDeclare proxy js = runDeclare (declareSchemaRef proxy) mempty <=> js
64+
62spec :: Spec
65spec :: Spec
63spec = do
66spec = do
64 describe "Generic ToSchema" $ do
67 describe "Generic ToSchema" $ do
@@ -78,6 +81,7 @@ spec = do
78 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
81 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
79 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
82 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80 context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
83 context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
84+ context "Natural Language (single field data with recursive fields)" $ checkToSchemaDeclare (Proxy :: Proxy Predicate) predicateSchemaDeclareJSON
81 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
85 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
82 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
86 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83 context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
87 context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
test/Data/OpenApiSpec.hs+45−29
@@ -45,6 +45,10 @@ spec = do
45 fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False)
45 fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False)
46 it "roundtrips: fmap toJSON . fromJSON" $ do
46 it "roundtrips: fmap toJSON . fromJSON" $ do
47 (toJSON :: OpenApi -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON
47 (toJSON :: OpenApi -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON
48+ context "Security schemes" $ do
49+ it "merged correctly" $ do
50+ let merged = oAuth2SecurityDefinitionsReadOpenApi <> oAuth2SecurityDefinitionsWriteOpenApi
51+ merged `shouldBe` oAuth2SecurityDefinitionsOpenApi
48
52
49main :: IO ()
53main :: IO ()
50main = hspec spec
54main = hspec spec
@@ -132,15 +136,15 @@ operationExample = mempty
132 & description ?~ "ID of pet that needs to be updated"
136 & description ?~ "ID of pet that needs to be updated"
133 & required ?~ True
137 & required ?~ True
134 & in_ .~ ParamPath
138 & in_ .~ ParamPath
135− & schema ?~ Inline (mempty & type_ ?~ SwaggerString))]
139+ & schema ?~ Inline (mempty & type_ ?~ OpenApiString))]
136 & requestBody ?~ Inline (
140 & requestBody ?~ Inline (
137 mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ (Inline (mempty
141 mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ (Inline (mempty
138 & properties . at "petId" ?~ Inline (mempty
142 & properties . at "petId" ?~ Inline (mempty
139 & description ?~ "Updated name of the pet"
143 & description ?~ "Updated name of the pet"
140− & type_ ?~ SwaggerString)
144+ & type_ ?~ OpenApiString)
141 & properties . at "status" ?~ Inline (mempty
145 & properties . at "status" ?~ Inline (mempty
142 & description ?~ "Updated status of the pet"
146 & description ?~ "Updated status of the pet"
143− & type_ ?~ SwaggerString)))))
147+ & type_ ?~ OpenApiString)))))
144 & at 200 ?~ "Pet updated."
148 & at 200 ?~ "Pet updated."
145 & at 405 ?~ "Invalid input"
149 & at 405 ?~ "Invalid input"
146 & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
150 & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
@@ -208,7 +212,7 @@ operationExampleJSON = [aesonQQ|
208
212
209schemaPrimitiveExample :: Schema
213schemaPrimitiveExample :: Schema
210schemaPrimitiveExample = mempty
214schemaPrimitiveExample = mempty
211− & type_ ?~ SwaggerString
215+ & type_ ?~ OpenApiString
212 & format ?~ "email"
216 & format ?~ "email"
213
217
214schemaPrimitiveExampleJSON :: Value
218schemaPrimitiveExampleJSON :: Value
@@ -221,14 +225,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
221
225
222schemaSimpleModelExample :: Schema
226schemaSimpleModelExample :: Schema
223schemaSimpleModelExample = mempty
227schemaSimpleModelExample = mempty
224− & type_ ?~ SwaggerObject
228+ & type_ ?~ OpenApiObject
225 & required .~ [ "name" ]
229 & required .~ [ "name" ]
226 & properties .~
230 & properties .~
227− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
231+ [ ("name", Inline (mempty & type_ ?~ OpenApiString))
228 , ("address", Ref (Reference "Address"))
232 , ("address", Ref (Reference "Address"))
229 , ("age", Inline $ mempty
233 , ("age", Inline $ mempty
230 & minimum_ ?~ 0
234 & minimum_ ?~ 0
231− & type_ ?~ SwaggerInteger
235+ & type_ ?~ OpenApiInteger
232 & format ?~ "int32" ) ]
236 & format ?~ "int32" ) ]
233
237
234schemaSimpleModelExampleJSON :: Value
238schemaSimpleModelExampleJSON :: Value
@@ -253,8 +257,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
253
257
254schemaModelDictExample :: Schema
258schemaModelDictExample :: Schema
255schemaModelDictExample = mempty
259schemaModelDictExample = mempty
256− & type_ ?~ SwaggerObject
260+ & type_ ?~ OpenApiObject
257− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
261+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ OpenApiString))
258
262
259schemaModelDictExampleJSON :: Value
263schemaModelDictExampleJSON :: Value
260schemaModelDictExampleJSON = [aesonQQ|
264schemaModelDictExampleJSON = [aesonQQ|
@@ -268,7 +272,7 @@ schemaModelDictExampleJSON = [aesonQQ|
268
272
269schemaAdditionalExample :: Schema
273schemaAdditionalExample :: Schema
270schemaAdditionalExample = mempty
274schemaAdditionalExample = mempty
271− & type_ ?~ SwaggerObject
275+ & type_ ?~ OpenApiObject
272 & additionalProperties ?~ AdditionalPropertiesAllowed True
276 & additionalProperties ?~ AdditionalPropertiesAllowed True
273
277
274schemaAdditionalExampleJSON :: Value
278schemaAdditionalExampleJSON :: Value
@@ -281,13 +285,13 @@ schemaAdditionalExampleJSON = [aesonQQ|
281
285
282schemaWithExampleExample :: Schema
286schemaWithExampleExample :: Schema
283schemaWithExampleExample = mempty
287schemaWithExampleExample = mempty
284− & type_ ?~ SwaggerObject
288+ & type_ ?~ OpenApiObject
285 & properties .~
289 & properties .~
286 [ ("id", Inline $ mempty
290 [ ("id", Inline $ mempty
287− & type_ ?~ SwaggerInteger
291+ & type_ ?~ OpenApiInteger
288 & format ?~ "int64" )
292 & format ?~ "int64" )
289 , ("name", Inline $ mempty
293 , ("name", Inline $ mempty
290− & type_ ?~ SwaggerString) ]
294+ & type_ ?~ OpenApiString) ]
291 & required .~ [ "name" ]
295 & required .~ [ "name" ]
292 & example ?~ [aesonQQ|
296 & example ?~ [aesonQQ|
293 {
297 {
@@ -326,19 +330,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
326definitionsExample :: HashMap Text Schema
330definitionsExample :: HashMap Text Schema
327definitionsExample =
331definitionsExample =
328 [ ("Category", mempty
332 [ ("Category", mempty
329− & type_ ?~ SwaggerObject
333+ & type_ ?~ OpenApiObject
330 & properties .~
334 & properties .~
331 [ ("id", Inline $ mempty
335 [ ("id", Inline $ mempty
332− & type_ ?~ SwaggerInteger
336+ & type_ ?~ OpenApiInteger
333 & format ?~ "int64")
337 & format ?~ "int64")
334− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
338+ , ("name", Inline (mempty & type_ ?~ OpenApiString)) ] )
335 , ("Tag", mempty
339 , ("Tag", mempty
336− & type_ ?~ SwaggerObject
340+ & type_ ?~ OpenApiObject
337 & properties .~
341 & properties .~
338 [ ("id", Inline $ mempty
342 [ ("id", Inline $ mempty
339− & type_ ?~ SwaggerInteger
343+ & type_ ?~ OpenApiInteger
340 & format ?~ "int64")
344 & format ?~ "int64")
341− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
345+ , ("name", Inline (mempty & type_ ?~ OpenApiString)) ] ) ]
342
346
343definitionsExampleJSON :: Value
347definitionsExampleJSON :: Value
344definitionsExampleJSON = [aesonQQ|
348definitionsExampleJSON = [aesonQQ|
@@ -382,7 +386,7 @@ paramsDefinitionExample =
382 & required ?~ True
386 & required ?~ True
383 & in_ .~ ParamQuery
387 & in_ .~ ParamQuery
384 & schema ?~ Inline (mempty
388 & schema ?~ Inline (mempty
385− & type_ ?~ SwaggerInteger
389+ & type_ ?~ OpenApiInteger
386 & format ?~ "int32" ))
390 & format ?~ "int32" ))
387 , ("limitParam", mempty
391 , ("limitParam", mempty
388 & name .~ "limit"
392 & name .~ "limit"
@@ -390,7 +394,7 @@ paramsDefinitionExample =
390 & required ?~ True
394 & required ?~ True
391 & in_ .~ ParamQuery
395 & in_ .~ ParamQuery
392 & schema ?~ Inline (mempty
396 & schema ?~ Inline (mempty
393− & type_ ?~ SwaggerInteger
397+ & type_ ?~ OpenApiInteger
394 & format ?~ "int32" )) ]
398 & format ?~ "int32" )) ]
395
399
396paramsDefinitionExampleJSON :: Value
400paramsDefinitionExampleJSON :: Value
@@ -441,7 +445,7 @@ responsesDefinitionExampleJSON = [aesonQQ|
441|]
445|]
442
446
443-- =======================================================================
447-- =======================================================================
444−-- Responses Definition object
448+-- Security Definition object
445-- =======================================================================
449-- =======================================================================
446
450
447securityDefinitionsExample :: SecurityDefinitions
451securityDefinitionsExample :: SecurityDefinitions
@@ -527,6 +531,18 @@ oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|
527}
531}
528|]
532|]
529
533
534+oAuth2SecurityDefinitionsReadOpenApi :: OpenApi
535+oAuth2SecurityDefinitionsReadOpenApi =
536+ mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsReadExample
537+
538+oAuth2SecurityDefinitionsWriteOpenApi :: OpenApi
539+oAuth2SecurityDefinitionsWriteOpenApi =
540+ mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsWriteExample
541+
542+oAuth2SecurityDefinitionsOpenApi :: OpenApi
543+oAuth2SecurityDefinitionsOpenApi =
544+ mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsExample
545+
530-- =======================================================================
546-- =======================================================================
531-- Swagger object
547-- Swagger object
532-- =======================================================================
548-- =======================================================================
@@ -559,7 +575,7 @@ swaggerExample = mempty
559 & description .~ "OK"
575 & description .~ "OK"
560 & content . at "application/json" ?~ (mempty
576 & content . at "application/json" ?~ (mempty
561 & schema ?~ Inline (mempty
577 & schema ?~ Inline (mempty
562− & type_ ?~ SwaggerObject
578+ & type_ ?~ OpenApiObject
563 & example ?~ [aesonQQ|
579 & example ?~ [aesonQQ|
564 {
580 {
565 "created": 100,
581 "created": 100,
@@ -568,9 +584,9 @@ swaggerExample = mempty
568 & description ?~ "This is some real Todo right here"
584 & description ?~ "This is some real Todo right here"
569 & properties .~
585 & properties .~
570 [ ("created", Inline $ mempty
586 [ ("created", Inline $ mempty
571− & type_ ?~ SwaggerInteger
587+ & type_ ?~ OpenApiInteger
572 & format ?~ "int32")
588 & format ?~ "int32")
573− , ("description", Inline (mempty & type_ ?~ SwaggerString))])))
589+ , ("description", Inline (mempty & type_ ?~ OpenApiString))])))
574 & parameters .~
590 & parameters .~
575 [ Inline $ mempty
591 [ Inline $ mempty
576 & required ?~ True
592 & required ?~ True
@@ -578,7 +594,7 @@ swaggerExample = mempty
578 & description ?~ "TodoId param"
594 & description ?~ "TodoId param"
579 & in_ .~ ParamPath
595 & in_ .~ ParamPath
580 & schema ?~ Inline (mempty
596 & schema ?~ Inline (mempty
581− & type_ ?~ SwaggerString ) ]
597+ & type_ ?~ OpenApiString ) ]
582 & tags .~ InsOrdHS.fromList [ "todo" ] ))
598 & tags .~ InsOrdHS.fromList [ "todo" ] ))
583
599
584swaggerExampleJSON :: Value
600swaggerExampleJSON :: Value
@@ -917,14 +933,14 @@ petstoreExampleJSON = [aesonQQ|
917
933
918compositionSchemaExample :: Schema
934compositionSchemaExample :: Schema
919compositionSchemaExample = mempty
935compositionSchemaExample = mempty
920− & type_ ?~ SwaggerObject
936+ & type_ ?~ OpenApiObject
921 & Data.OpenApi.allOf ?~ [
937 & Data.OpenApi.allOf ?~ [
922 Ref (Reference "Other")
938 Ref (Reference "Other")
923 , Inline (mempty
939 , Inline (mempty
924− & type_ ?~ SwaggerObject
940+ & type_ ?~ OpenApiObject
925 & properties .~
941 & properties .~
926 [ ("greet", Inline $ mempty
942 [ ("greet", Inline $ mempty
927− & type_ ?~ SwaggerString) ])
943+ & type_ ?~ OpenApiString) ])
928 ]
944 ]
929
945
930compositionSchemaExampleJSON :: Value
946compositionSchemaExampleJSON :: Value
test/SpecCommon.hs−8
@@ -8,14 +8,6 @@ import qualified Data.Vector as Vector
8
8
9import Test.Hspec
9import Test.Hspec
10
10
11−isSubJSON :: Value -> Value -> Bool
12−isSubJSON Null _ = True
13−isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i
14− where
15− i = HashMap.intersectionWith isSubJSON x y
16−isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)
17−isSubJSON x y = x == y
18−
19(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec
11(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec
20x <=> js = do
12x <=> js = do
21 it "encodes correctly" $ do
13 it "encodes correctly" $ do