├── .gitignore ├── .gitmodules ├── .travis.yml ├── CODE_OF_CONDUCT.md ├── LICENSE ├── README.rst ├── benchmark.lisp ├── json-schema.asd ├── src ├── formats.lisp ├── json-schema.lisp ├── parse.lisp ├── reference.lisp ├── types.lisp ├── utils.lisp └── validators.lisp └── t ├── draft2019-09.lisp ├── draft4.lisp ├── draft6.lisp ├── draft7.lisp ├── jso-printer.lisp ├── json-schema-test-case-helper.lisp ├── json-schema.lisp ├── reference.lisp └── utils.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "JSON-Schema-Test-Suite"] 2 | path = JSON-Schema-Test-Suite 3 | url = https://github.com/json-schema-org/JSON-Schema-Test-Suite 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | os: linux 3 | 4 | notifications: 5 | email: false 6 | 7 | addons: 8 | apt: 9 | packages: 10 | - libc6-i386 11 | - openjdk-8-jre 12 | 13 | env: 14 | global: 15 | - PATH=$HOME/.roswell/bin:$PATH 16 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 17 | - COVERAGE_EXCLUDE=t 18 | 19 | cache: 20 | directories: 21 | - $HOME/.roswell 22 | - $HOME/.config/common-lisp 23 | 24 | # This gets the environment overridden to set the lisp implementation to test 25 | test-job: &test 26 | stage: test 27 | install: 28 | # Install Roswell 29 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh 30 | - ros install fukamachi/rove 31 | - pip install Flask 32 | before_script: 33 | - echo "JSON-Schema-Test-Suite" 34 | - git submodule status JSON-Schema-Test-Suite/ 35 | - ros --version 36 | - ros config 37 | - ros -s json-schema -e '(print "precompiled json-schema")' 38 | - cd JSON-Schema-Test-Suite/bin && ./jsonschema_suite serve & 39 | script: 40 | - ros dynamic-space-size=4096 exec rove json-schema.asd 41 | 42 | jobs: 43 | fast_finish: true 44 | allow_failures: 45 | - env: LISP=clisp 46 | - env: LISP=abcl 47 | - env: LISP=ecl 48 | include: 49 | # - <<: *test 50 | # env: 51 | # - LISP=sbcl-bin COVERALLS=true 52 | - <<: *test 53 | env: 54 | - LISP=ccl-bin 55 | # - <<: *test 56 | # env: 57 | # - LISP=ecl 58 | # - <<: *test 59 | # env: 60 | # - LISP=allegro 61 | # - <<: *test 62 | # env: 63 | # - LISP=abcl 64 | - name: update docs 65 | stage: deploy 66 | before_script: 67 | - docker pull quay.io/fisxoj/coo:master 68 | script: 69 | - docker run --rm -it -v $PWD:/work:Z quay.io/fisxoj/coo:master 70 | deploy: 71 | provider: pages:git 72 | edge: true 73 | local_dir: docs 74 | if: type = push AND branch = master 75 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as 6 | contributors and maintainers pledge to making participation in our project and 7 | our community a harassment-free experience for everyone, regardless of age, body 8 | size, disability, ethnicity, sex characteristics, gender identity and expression, 9 | level of experience, education, socio-economic status, nationality, personal 10 | appearance, race, religion, or sexual identity and orientation. 11 | 12 | ## Our Standards 13 | 14 | Examples of behavior that contributes to creating a positive environment 15 | include: 16 | 17 | * Using welcoming and inclusive language 18 | * Being respectful of differing viewpoints and experiences 19 | * Gracefully accepting constructive criticism 20 | * Focusing on what is best for the community 21 | * Showing empathy towards other community members 22 | 23 | Examples of unacceptable behavior by participants include: 24 | 25 | * The use of sexualized language or imagery and unwelcome sexual attention or 26 | advances 27 | * Trolling, insulting/derogatory comments, and personal or political attacks 28 | * Public or private harassment 29 | * Publishing others' private information, such as a physical or electronic 30 | address, without explicit permission 31 | * Other conduct which could reasonably be considered inappropriate in a 32 | professional setting 33 | 34 | ## Our Responsibilities 35 | 36 | Project maintainers are responsible for clarifying the standards of acceptable 37 | behavior and are expected to take appropriate and fair corrective action in 38 | response to any instances of unacceptable behavior. 39 | 40 | Project maintainers have the right and responsibility to remove, edit, or 41 | reject comments, commits, code, wiki edits, issues, and other contributions 42 | that are not aligned to this Code of Conduct, or to ban temporarily or 43 | permanently any contributor for other behaviors that they deem inappropriate, 44 | threatening, offensive, or harmful. 45 | 46 | ## Scope 47 | 48 | This Code of Conduct applies both within project spaces and in public spaces 49 | when an individual is representing the project or its community. Examples of 50 | representing a project or community include using an official project e-mail 51 | address, posting via an official social media account, or acting as an appointed 52 | representative at an online or offline event. Representation of a project may be 53 | further defined and clarified by project maintainers. 54 | 55 | ## Enforcement 56 | 57 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 58 | reported by contacting the project team at fisxoj@gmail.com. All 59 | complaints will be reviewed and investigated and will result in a response that 60 | is deemed necessary and appropriate to the circumstances. The project team is 61 | obligated to maintain confidentiality with regard to the reporter of an incident. 62 | Further details of specific enforcement policies may be posted separately. 63 | 64 | Project maintainers who do not follow or enforce the Code of Conduct in good 65 | faith may face temporary or permanent repercussions as determined by other 66 | members of the project's leadership. 67 | 68 | ## Attribution 69 | 70 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, 71 | available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html 72 | 73 | [homepage]: https://www.contributor-covenant.org 74 | 75 | For answers to common questions about this code of conduct, see 76 | https://www.contributor-covenant.org/faq 77 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 2.1, February 1999 3 | 4 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | [This is the first released version of the Lesser GPL. It also counts 10 | as the successor of the GNU Library Public License, version 2, hence 11 | the version number 2.1.] 12 | 13 | Preamble 14 | 15 | The licenses for most software are designed to take away your 16 | freedom to share and change it. By contrast, the GNU General Public 17 | Licenses are intended to guarantee your freedom to share and change 18 | free software--to make sure the software is free for all its users. 19 | 20 | This license, the Lesser General Public License, applies to some 21 | specially designated software packages--typically libraries--of the 22 | Free Software Foundation and other authors who decide to use it. You 23 | can use it too, but we suggest you first think carefully about whether 24 | this license or the ordinary General Public License is the better 25 | strategy to use in any particular case, based on the explanations below. 26 | 27 | When we speak of free software, we are referring to freedom of use, 28 | not price. Our General Public Licenses are designed to make sure that 29 | you have the freedom to distribute copies of free software (and charge 30 | for this service if you wish); that you receive source code or can get 31 | it if you want it; that you can change the software and use pieces of 32 | it in new free programs; and that you are informed that you can do 33 | these things. 34 | 35 | To protect your rights, we need to make restrictions that forbid 36 | distributors to deny you these rights or to ask you to surrender these 37 | rights. These restrictions translate to certain responsibilities for 38 | you if you distribute copies of the library or if you modify it. 39 | 40 | For example, if you distribute copies of the library, whether gratis 41 | or for a fee, you must give the recipients all the rights that we gave 42 | you. You must make sure that they, too, receive or can get the source 43 | code. If you link other code with the library, you must provide 44 | complete object files to the recipients, so that they can relink them 45 | with the library after making changes to the library and recompiling 46 | it. And you must show them these terms so they know their rights. 47 | 48 | We protect your rights with a two-step method: (1) we copyright the 49 | library, and (2) we offer you this license, which gives you legal 50 | permission to copy, distribute and/or modify the library. 51 | 52 | To protect each distributor, we want to make it very clear that 53 | there is no warranty for the free library. Also, if the library is 54 | modified by someone else and passed on, the recipients should know 55 | that what they have is not the original version, so that the original 56 | author's reputation will not be affected by problems that might be 57 | introduced by others. 58 | 59 | Finally, software patents pose a constant threat to the existence of 60 | any free program. We wish to make sure that a company cannot 61 | effectively restrict the users of a free program by obtaining a 62 | restrictive license from a patent holder. Therefore, we insist that 63 | any patent license obtained for a version of the library must be 64 | consistent with the full freedom of use specified in this license. 65 | 66 | Most GNU software, including some libraries, is covered by the 67 | ordinary GNU General Public License. This license, the GNU Lesser 68 | General Public License, applies to certain designated libraries, and 69 | is quite different from the ordinary General Public License. We use 70 | this license for certain libraries in order to permit linking those 71 | libraries into non-free programs. 72 | 73 | When a program is linked with a library, whether statically or using 74 | a shared library, the combination of the two is legally speaking a 75 | combined work, a derivative of the original library. The ordinary 76 | General Public License therefore permits such linking only if the 77 | entire combination fits its criteria of freedom. The Lesser General 78 | Public License permits more lax criteria for linking other code with 79 | the library. 80 | 81 | We call this license the "Lesser" General Public License because it 82 | does Less to protect the user's freedom than the ordinary General 83 | Public License. It also provides other free software developers Less 84 | of an advantage over competing non-free programs. These disadvantages 85 | are the reason we use the ordinary General Public License for many 86 | libraries. However, the Lesser license provides advantages in certain 87 | special circumstances. 88 | 89 | For example, on rare occasions, there may be a special need to 90 | encourage the widest possible use of a certain library, so that it becomes 91 | a de-facto standard. To achieve this, non-free programs must be 92 | allowed to use the library. A more frequent case is that a free 93 | library does the same job as widely used non-free libraries. In this 94 | case, there is little to gain by limiting the free library to free 95 | software only, so we use the Lesser General Public License. 96 | 97 | In other cases, permission to use a particular library in non-free 98 | programs enables a greater number of people to use a large body of 99 | free software. For example, permission to use the GNU C Library in 100 | non-free programs enables many more people to use the whole GNU 101 | operating system, as well as its variant, the GNU/Linux operating 102 | system. 103 | 104 | Although the Lesser General Public License is Less protective of the 105 | users' freedom, it does ensure that the user of a program that is 106 | linked with the Library has the freedom and the wherewithal to run 107 | that program using a modified version of the Library. 108 | 109 | The precise terms and conditions for copying, distribution and 110 | modification follow. Pay close attention to the difference between a 111 | "work based on the library" and a "work that uses the library". The 112 | former contains code derived from the library, whereas the latter must 113 | be combined with the library in order to run. 114 | 115 | GNU LESSER GENERAL PUBLIC LICENSE 116 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 117 | 118 | 0. This License Agreement applies to any software library or other 119 | program which contains a notice placed by the copyright holder or 120 | other authorized party saying it may be distributed under the terms of 121 | this Lesser General Public License (also called "this License"). 122 | Each licensee is addressed as "you". 123 | 124 | A "library" means a collection of software functions and/or data 125 | prepared so as to be conveniently linked with application programs 126 | (which use some of those functions and data) to form executables. 127 | 128 | The "Library", below, refers to any such software library or work 129 | which has been distributed under these terms. A "work based on the 130 | Library" means either the Library or any derivative work under 131 | copyright law: that is to say, a work containing the Library or a 132 | portion of it, either verbatim or with modifications and/or translated 133 | straightforwardly into another language. (Hereinafter, translation is 134 | included without limitation in the term "modification".) 135 | 136 | "Source code" for a work means the preferred form of the work for 137 | making modifications to it. For a library, complete source code means 138 | all the source code for all modules it contains, plus any associated 139 | interface definition files, plus the scripts used to control compilation 140 | and installation of the library. 141 | 142 | Activities other than copying, distribution and modification are not 143 | covered by this License; they are outside its scope. The act of 144 | running a program using the Library is not restricted, and output from 145 | such a program is covered only if its contents constitute a work based 146 | on the Library (independent of the use of the Library in a tool for 147 | writing it). Whether that is true depends on what the Library does 148 | and what the program that uses the Library does. 149 | 150 | 1. You may copy and distribute verbatim copies of the Library's 151 | complete source code as you receive it, in any medium, provided that 152 | you conspicuously and appropriately publish on each copy an 153 | appropriate copyright notice and disclaimer of warranty; keep intact 154 | all the notices that refer to this License and to the absence of any 155 | warranty; and distribute a copy of this License along with the 156 | Library. 157 | 158 | You may charge a fee for the physical act of transferring a copy, 159 | and you may at your option offer warranty protection in exchange for a 160 | fee. 161 | 162 | 2. You may modify your copy or copies of the Library or any portion 163 | of it, thus forming a work based on the Library, and copy and 164 | distribute such modifications or work under the terms of Section 1 165 | above, provided that you also meet all of these conditions: 166 | 167 | a) The modified work must itself be a software library. 168 | 169 | b) You must cause the files modified to carry prominent notices 170 | stating that you changed the files and the date of any change. 171 | 172 | c) You must cause the whole of the work to be licensed at no 173 | charge to all third parties under the terms of this License. 174 | 175 | d) If a facility in the modified Library refers to a function or a 176 | table of data to be supplied by an application program that uses 177 | the facility, other than as an argument passed when the facility 178 | is invoked, then you must make a good faith effort to ensure that, 179 | in the event an application does not supply such function or 180 | table, the facility still operates, and performs whatever part of 181 | its purpose remains meaningful. 182 | 183 | (For example, a function in a library to compute square roots has 184 | a purpose that is entirely well-defined independent of the 185 | application. Therefore, Subsection 2d requires that any 186 | application-supplied function or table used by this function must 187 | be optional: if the application does not supply it, the square 188 | root function must still compute square roots.) 189 | 190 | These requirements apply to the modified work as a whole. If 191 | identifiable sections of that work are not derived from the Library, 192 | and can be reasonably considered independent and separate works in 193 | themselves, then this License, and its terms, do not apply to those 194 | sections when you distribute them as separate works. But when you 195 | distribute the same sections as part of a whole which is a work based 196 | on the Library, the distribution of the whole must be on the terms of 197 | this License, whose permissions for other licensees extend to the 198 | entire whole, and thus to each and every part regardless of who wrote 199 | it. 200 | 201 | Thus, it is not the intent of this section to claim rights or contest 202 | your rights to work written entirely by you; rather, the intent is to 203 | exercise the right to control the distribution of derivative or 204 | collective works based on the Library. 205 | 206 | In addition, mere aggregation of another work not based on the Library 207 | with the Library (or with a work based on the Library) on a volume of 208 | a storage or distribution medium does not bring the other work under 209 | the scope of this License. 210 | 211 | 3. You may opt to apply the terms of the ordinary GNU General Public 212 | License instead of this License to a given copy of the Library. To do 213 | this, you must alter all the notices that refer to this License, so 214 | that they refer to the ordinary GNU General Public License, version 2, 215 | instead of to this License. (If a newer version than version 2 of the 216 | ordinary GNU General Public License has appeared, then you can specify 217 | that version instead if you wish.) Do not make any other change in 218 | these notices. 219 | 220 | Once this change is made in a given copy, it is irreversible for 221 | that copy, so the ordinary GNU General Public License applies to all 222 | subsequent copies and derivative works made from that copy. 223 | 224 | This option is useful when you wish to copy part of the code of 225 | the Library into a program that is not a library. 226 | 227 | 4. You may copy and distribute the Library (or a portion or 228 | derivative of it, under Section 2) in object code or executable form 229 | under the terms of Sections 1 and 2 above provided that you accompany 230 | it with the complete corresponding machine-readable source code, which 231 | must be distributed under the terms of Sections 1 and 2 above on a 232 | medium customarily used for software interchange. 233 | 234 | If distribution of object code is made by offering access to copy 235 | from a designated place, then offering equivalent access to copy the 236 | source code from the same place satisfies the requirement to 237 | distribute the source code, even though third parties are not 238 | compelled to copy the source along with the object code. 239 | 240 | 5. A program that contains no derivative of any portion of the 241 | Library, but is designed to work with the Library by being compiled or 242 | linked with it, is called a "work that uses the Library". Such a 243 | work, in isolation, is not a derivative work of the Library, and 244 | therefore falls outside the scope of this License. 245 | 246 | However, linking a "work that uses the Library" with the Library 247 | creates an executable that is a derivative of the Library (because it 248 | contains portions of the Library), rather than a "work that uses the 249 | library". The executable is therefore covered by this License. 250 | Section 6 states terms for distribution of such executables. 251 | 252 | When a "work that uses the Library" uses material from a header file 253 | that is part of the Library, the object code for the work may be a 254 | derivative work of the Library even though the source code is not. 255 | Whether this is true is especially significant if the work can be 256 | linked without the Library, or if the work is itself a library. The 257 | threshold for this to be true is not precisely defined by law. 258 | 259 | If such an object file uses only numerical parameters, data 260 | structure layouts and accessors, and small macros and small inline 261 | functions (ten lines or less in length), then the use of the object 262 | file is unrestricted, regardless of whether it is legally a derivative 263 | work. (Executables containing this object code plus portions of the 264 | Library will still fall under Section 6.) 265 | 266 | Otherwise, if the work is a derivative of the Library, you may 267 | distribute the object code for the work under the terms of Section 6. 268 | Any executables containing that work also fall under Section 6, 269 | whether or not they are linked directly with the Library itself. 270 | 271 | 6. As an exception to the Sections above, you may also combine or 272 | link a "work that uses the Library" with the Library to produce a 273 | work containing portions of the Library, and distribute that work 274 | under terms of your choice, provided that the terms permit 275 | modification of the work for the customer's own use and reverse 276 | engineering for debugging such modifications. 277 | 278 | You must give prominent notice with each copy of the work that the 279 | Library is used in it and that the Library and its use are covered by 280 | this License. You must supply a copy of this License. If the work 281 | during execution displays copyright notices, you must include the 282 | copyright notice for the Library among them, as well as a reference 283 | directing the user to the copy of this License. Also, you must do one 284 | of these things: 285 | 286 | a) Accompany the work with the complete corresponding 287 | machine-readable source code for the Library including whatever 288 | changes were used in the work (which must be distributed under 289 | Sections 1 and 2 above); and, if the work is an executable linked 290 | with the Library, with the complete machine-readable "work that 291 | uses the Library", as object code and/or source code, so that the 292 | user can modify the Library and then relink to produce a modified 293 | executable containing the modified Library. (It is understood 294 | that the user who changes the contents of definitions files in the 295 | Library will not necessarily be able to recompile the application 296 | to use the modified definitions.) 297 | 298 | b) Use a suitable shared library mechanism for linking with the 299 | Library. A suitable mechanism is one that (1) uses at run time a 300 | copy of the library already present on the user's computer system, 301 | rather than copying library functions into the executable, and (2) 302 | will operate properly with a modified version of the library, if 303 | the user installs one, as long as the modified version is 304 | interface-compatible with the version that the work was made with. 305 | 306 | c) Accompany the work with a written offer, valid for at 307 | least three years, to give the same user the materials 308 | specified in Subsection 6a, above, for a charge no more 309 | than the cost of performing this distribution. 310 | 311 | d) If distribution of the work is made by offering access to copy 312 | from a designated place, offer equivalent access to copy the above 313 | specified materials from the same place. 314 | 315 | e) Verify that the user has already received a copy of these 316 | materials or that you have already sent this user a copy. 317 | 318 | For an executable, the required form of the "work that uses the 319 | Library" must include any data and utility programs needed for 320 | reproducing the executable from it. However, as a special exception, 321 | the materials to be distributed need not include anything that is 322 | normally distributed (in either source or binary form) with the major 323 | components (compiler, kernel, and so on) of the operating system on 324 | which the executable runs, unless that component itself accompanies 325 | the executable. 326 | 327 | It may happen that this requirement contradicts the license 328 | restrictions of other proprietary libraries that do not normally 329 | accompany the operating system. Such a contradiction means you cannot 330 | use both them and the Library together in an executable that you 331 | distribute. 332 | 333 | 7. You may place library facilities that are a work based on the 334 | Library side-by-side in a single library together with other library 335 | facilities not covered by this License, and distribute such a combined 336 | library, provided that the separate distribution of the work based on 337 | the Library and of the other library facilities is otherwise 338 | permitted, and provided that you do these two things: 339 | 340 | a) Accompany the combined library with a copy of the same work 341 | based on the Library, uncombined with any other library 342 | facilities. This must be distributed under the terms of the 343 | Sections above. 344 | 345 | b) Give prominent notice with the combined library of the fact 346 | that part of it is a work based on the Library, and explaining 347 | where to find the accompanying uncombined form of the same work. 348 | 349 | 8. You may not copy, modify, sublicense, link with, or distribute 350 | the Library except as expressly provided under this License. Any 351 | attempt otherwise to copy, modify, sublicense, link with, or 352 | distribute the Library is void, and will automatically terminate your 353 | rights under this License. However, parties who have received copies, 354 | or rights, from you under this License will not have their licenses 355 | terminated so long as such parties remain in full compliance. 356 | 357 | 9. You are not required to accept this License, since you have not 358 | signed it. However, nothing else grants you permission to modify or 359 | distribute the Library or its derivative works. These actions are 360 | prohibited by law if you do not accept this License. Therefore, by 361 | modifying or distributing the Library (or any work based on the 362 | Library), you indicate your acceptance of this License to do so, and 363 | all its terms and conditions for copying, distributing or modifying 364 | the Library or works based on it. 365 | 366 | 10. Each time you redistribute the Library (or any work based on the 367 | Library), the recipient automatically receives a license from the 368 | original licensor to copy, distribute, link with or modify the Library 369 | subject to these terms and conditions. You may not impose any further 370 | restrictions on the recipients' exercise of the rights granted herein. 371 | You are not responsible for enforcing compliance by third parties with 372 | this License. 373 | 374 | 11. If, as a consequence of a court judgment or allegation of patent 375 | infringement or for any other reason (not limited to patent issues), 376 | conditions are imposed on you (whether by court order, agreement or 377 | otherwise) that contradict the conditions of this License, they do not 378 | excuse you from the conditions of this License. If you cannot 379 | distribute so as to satisfy simultaneously your obligations under this 380 | License and any other pertinent obligations, then as a consequence you 381 | may not distribute the Library at all. For example, if a patent 382 | license would not permit royalty-free redistribution of the Library by 383 | all those who receive copies directly or indirectly through you, then 384 | the only way you could satisfy both it and this License would be to 385 | refrain entirely from distribution of the Library. 386 | 387 | If any portion of this section is held invalid or unenforceable under any 388 | particular circumstance, the balance of the section is intended to apply, 389 | and the section as a whole is intended to apply in other circumstances. 390 | 391 | It is not the purpose of this section to induce you to infringe any 392 | patents or other property right claims or to contest validity of any 393 | such claims; this section has the sole purpose of protecting the 394 | integrity of the free software distribution system which is 395 | implemented by public license practices. Many people have made 396 | generous contributions to the wide range of software distributed 397 | through that system in reliance on consistent application of that 398 | system; it is up to the author/donor to decide if he or she is willing 399 | to distribute software through any other system and a licensee cannot 400 | impose that choice. 401 | 402 | This section is intended to make thoroughly clear what is believed to 403 | be a consequence of the rest of this License. 404 | 405 | 12. If the distribution and/or use of the Library is restricted in 406 | certain countries either by patents or by copyrighted interfaces, the 407 | original copyright holder who places the Library under this License may add 408 | an explicit geographical distribution limitation excluding those countries, 409 | so that distribution is permitted only in or among countries not thus 410 | excluded. In such case, this License incorporates the limitation as if 411 | written in the body of this License. 412 | 413 | 13. The Free Software Foundation may publish revised and/or new 414 | versions of the Lesser General Public License from time to time. 415 | Such new versions will be similar in spirit to the present version, 416 | but may differ in detail to address new problems or concerns. 417 | 418 | Each version is given a distinguishing version number. If the Library 419 | specifies a version number of this License which applies to it and 420 | "any later version", you have the option of following the terms and 421 | conditions either of that version or of any later version published by 422 | the Free Software Foundation. If the Library does not specify a 423 | license version number, you may choose any version ever published by 424 | the Free Software Foundation. 425 | 426 | 14. If you wish to incorporate parts of the Library into other free 427 | programs whose distribution conditions are incompatible with these, 428 | write to the author to ask for permission. For software which is 429 | copyrighted by the Free Software Foundation, write to the Free 430 | Software Foundation; we sometimes make exceptions for this. Our 431 | decision will be guided by the two goals of preserving the free status 432 | of all derivatives of our free software and of promoting the sharing 433 | and reuse of software generally. 434 | 435 | NO WARRANTY 436 | 437 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 438 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 439 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 440 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 441 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 442 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 443 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 444 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 445 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 446 | 447 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 448 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 449 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 450 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 451 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 452 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 453 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 454 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 455 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 456 | DAMAGES. 457 | 458 | END OF TERMS AND CONDITIONS 459 | 460 | How to Apply These Terms to Your New Libraries 461 | 462 | If you develop a new library, and you want it to be of the greatest 463 | possible use to the public, we recommend making it free software that 464 | everyone can redistribute and change. You can do so by permitting 465 | redistribution under these terms (or, alternatively, under the terms of the 466 | ordinary General Public License). 467 | 468 | To apply these terms, attach the following notices to the library. It is 469 | safest to attach them to the start of each source file to most effectively 470 | convey the exclusion of warranty; and each file should have at least the 471 | "copyright" line and a pointer to where the full notice is found. 472 | 473 | 474 | Copyright (C) 475 | 476 | This library is free software; you can redistribute it and/or 477 | modify it under the terms of the GNU Lesser General Public 478 | License as published by the Free Software Foundation; either 479 | version 2.1 of the License, or (at your option) any later version. 480 | 481 | This library is distributed in the hope that it will be useful, 482 | but WITHOUT ANY WARRANTY; without even the implied warranty of 483 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 484 | Lesser General Public License for more details. 485 | 486 | You should have received a copy of the GNU Lesser General Public 487 | License along with this library; if not, write to the Free Software 488 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 489 | USA 490 | 491 | Also add information on how to contact you by electronic and paper mail. 492 | 493 | You should also get your employer (if you work as a programmer) or your 494 | school, if any, to sign a "copyright disclaimer" for the library, if 495 | necessary. Here is a sample; alter the names: 496 | 497 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 498 | library `Frob' (a library for tweaking knobs) written by James Random 499 | Hacker. 500 | 501 | , 1 April 1990 502 | Ty Coon, President of Vice 503 | 504 | That's all there is to it! 505 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | .. image:: https://travis-ci.org/fisxoj/json-schema.svg?branch=master 2 | :target: https://travis-ci.org/fisxoj/json-schema 3 | :alt: Travis CI status badge 4 | .. image:: https://coveralls.io/repos/github/fisxoj/json-schema/badge.svg?branch=master 5 | :target: https://coveralls.io/github/fisxoj/json-schema?branch=master 6 | :alt: Coveralls status badge 7 | .. image:: https://img.shields.io/badge/Contributor%20Covenant-v1.4%20adopted-ff69b4.svg 8 | :alt: Contributor Covenant 9 | :target: CODE_OF_CONDUCT.md 10 | 11 | 12 | :Source: `https://github.com/fisxoj/json-schema `_ 13 | :Docs: `https://fisxoj.github.io/json-schema/ `_ 14 | 15 | json-schema is a validator for drafts 4, 6, 7, and 2019-09 of the `JSON Schema `_ standard. It is (mostly) compliant with the `common test suite `_. The exceptions are 16 | 17 | **Draft 2019-09:** 18 | 19 | - ``unevaluatedItems`` and ``unevaluatedProperties`` are unimplemented 20 | 21 | **Drafts 4, 6, 7:** 22 | 23 | - ``$ref`` does not override any sibling keywords 24 | 25 | ------- 26 | Example 27 | ------- 28 | 29 | The main entry point to the library is :function:`json-schema:validate`, which takes a schema to validate against, the data to validate against it and a draft version to use for interpreting the schema. The default version is currently draft7. 30 | 31 | **Validating a simple type** 32 | 33 | Passing 34 | :: 35 | 36 | (json-schema:validate 3 :schema (json-schema.parse:parse "{\"type\":\"integer\"}")) 37 | ;; => T 38 | ;; NIL 39 | 40 | Failing (note the error messages in the second argument) 41 | :: 42 | 43 | (json-schema:validate 13 :schema (json-schema.parse:parse "{\"type\":\"integer\",\"maximum\":10}")) 44 | ;; => NIL 45 | ;; ("13 must be less than or equal to 10") 46 | 47 | 48 | **Validating an object** 49 | :: 50 | 51 | (setf schema (json-schema.parse:parse 52 | "{\"properties\":{\"foo\\nbar\":{\"type\":\"number\"},\"foo\\\"bar\":{\"type\":\"number\"},\"foo\\\\bar\":{\"type\":\"number\"},\"foo\\rbar\":{\"type\":\"number\"},\"foo\\tbar\":{\"type\":\"number\"},\"foo\\fbar\":{\"type\":\"number\"}}}")) 53 | 54 | Passing 55 | :: 56 | 57 | (json-schema:validate 58 | (json-schema.parse:parse 59 | "{\"foo\\nbar\":1,\"foo\\\"bar\":1,\"foo\\\\bar\":1,\"foo\\rbar\":1,\"foo\\tbar\":1,\"foo\\fbar\":1}") :schema schema) 60 | ;; => T 61 | ;; NIL 62 | 63 | Failing 64 | :: 65 | 66 | (json-schema:validate 67 | (json-schema.parse:parse 68 | "{\"foo\\nbar\":\"1\",\"foo\\\"bar\":\"1\",\"foo\\\\bar\":\"1\",\"foo\\rbar\":\"1\",\"foo\\tbar\":\"1\",\"foo\\fbar\":\"1\"}") :schema schema) 69 | ;; => NIL 70 | ;; ("got errors validating properties 71 | ;; 72 | ;; Additionally: 73 | ;; - Value 1 is not of type \"number\". 74 | ;; - Value 1 is not of type \"number\". 75 | ;; - Value 1 is not of type \"number\". 76 | ;; - Value 1 is not of type \"number\". 77 | ;; - Value 1 is not of type \"number\". 78 | ;; - Value 1 is not of type \"number\". 79 | ;; ") 80 | 81 | **Validating a document with a referenced schema** 82 | 83 | If your data contains a top-level ``$schema`` key, you don't need to pass a schema along. It will be fetched and validated against automatically. This works with, for example, the `draft2019-09 meta-schema `_. 84 | 85 | ----------- 86 | Usage Notes 87 | ----------- 88 | 89 | ~~~~~~~~ 90 | Contexts 91 | ~~~~~~~~ 92 | 93 | A context is a reusable set of state that contains all of the fetched network resources (if your schema references external resources) and resolved ids. By storing that all, you can reuse the validation context multiple times without fetching/resolving everything again. 94 | :: 95 | (ql:quickload '(trivial-benchmark json-schema)) 96 | 97 | (defvar *schema* (json-schema.parse:parse #P"~/Downloads/schema")) 98 | 99 | ;; schema is the json-schema meta schema document from: 100 | ;; https://json-schema.org/specification-links.html#draft-2019-09-formerly-known-as-draft-8 101 | 102 | (defvar *context* 103 | (json-schema:make-context 104 | *schema* 105 | :draft2019-09)) 106 | 107 | ;;; Cached 108 | 109 | (let ((data (json-schema.parse:parse "{\"type\": \"string\"}"))) 110 | (trivial-benchmark:with-timing (1000) 111 | (json-schema:validate data 112 | :context *context*))) 113 | 114 | ;; - SAMPLES TOTAL MINIMUM MAXIMUM MEDIAN AVERAGE DEVIATION 115 | ;; REAL-TIME 1000 0.826 0 0.022 0.001 0.000826 0.000797 116 | ;; RUN-TIME 1000 0.826 0 0.022 0.001 0.000826 0.0008 117 | ;; USER-RUN-TIME 1000 0.781011 0 0.020644 0.000745 0.000781 0.000665 118 | ;; SYSTEM-RUN-TIME 1000 0.049933 0 0.000986 0 0.00005 0.000184 119 | ;; PAGE-FAULTS 1000 0 0 0 0 0 0.0 120 | ;; GC-RUN-TIME 1000 0.02 0 0.02 0 0.00002 0.000632 121 | ;; BYTES-CONSED 1000 213753664 195344 228976 228032 213753.66 16221.591 122 | ;; EVAL-CALLS 1000 0 0 0 0 0 0.0 123 | 124 | 125 | ;;; Uncached 126 | 127 | (let ((data (json-schema.parse:parse "{\"type\": \"string\"}"))) 128 | (trivial-benchmark:with-timing (1000) 129 | (json-schema:validate data 130 | :schema *schema* 131 | :schema-version :draft2019-09))) 132 | 133 | ;; - SAMPLES TOTAL MINIMUM MAXIMUM MEDIAN AVERAGE DEVIATION 134 | ;; REAL-TIME 1000 203.185 0.148 1.471 0.185 0.203185 0.112807 135 | ;; RUN-TIME 1000 9.25 0.006 0.04 0.009 0.00925 0.002294 136 | ;; USER-RUN-TIME 1000 8.145081 0.003368 0.039067 0.008105 0.008145 0.002317 137 | ;; SYSTEM-RUN-TIME 1000 1.107377 0 0.004927 0.000994 0.001107 0.000967 138 | ;; PAGE-FAULTS 1000 0 0 0 0 0 0.0 139 | ;; GC-RUN-TIME 1000 0.08 0 0.03 0 0.00008 0.001464 140 | ;; BYTES-CONSED 1000 719780512 707728 751424 718160 719780.5 11026.181 141 | ;; EVAL-CALLS 1000 0 0 0 0 0 0.0 142 | 143 | 144 | So, for this trivial example, the cached version is around a 245x speedup! Note, though, that json-schema evaluates these things lazily, so not every reference is necessarily resolved when the context is created. They are mutable, though, and will build up state as they go. 145 | 146 | Thank you to `Raymond Wiker `_ for contributing the initial implementation. 147 | 148 | ~~~~~~~~~~~~~ 149 | Decoding JSON 150 | ~~~~~~~~~~~~~ 151 | 152 | json-schema operates mostly on :class:`cl:hash-table` objects. It requires them to have the ``:test`` argument set to :function:`cl:equal`, so that they work with string keys. Further, it expects ``:true`` and ``:false`` as the boolean values and ``:null`` as the decoded Javascript ``null``. Javascrpit arrays should be rendered as lists. This behavior is provided behind the scenes by `st-json `_. The :function:`json-schema.parse:parse` function provides this functionality over strings, streams, and pathnames for you. 153 | 154 | 155 | ~~~~~~~~~~~~~~ 156 | Network access 157 | ~~~~~~~~~~~~~~ 158 | 159 | JSON Schema allows schemas to reference other documents over the network. This library will fetch them automatically, by default. If you don't want this to be allowed, you should set :variable:`json-schema.reference:*resolve-remote-references*` to ``nil``. If a schema references a remote one, it will raise a :class:`json-schema.reference:fetching-not-allowed-error` instead of fetching it when fetching references is disallowed. 160 | -------------------------------------------------------------------------------- /benchmark.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload '(trivial-benchmark json-schema)) 2 | 3 | (defvar *schema* (json-schema.parse:parse #P"~/Downloads/schema")) 4 | 5 | ;; schema is the json-schema meta schema document from: 6 | ;; https://json-schema.org/specification-links.html#draft-2019-09-formerly-known-as-draft-8 7 | 8 | (defvar *context* 9 | (json-schema:make-context 10 | *schema* 11 | :draft2019-09)) 12 | 13 | ;;; Cached 14 | 15 | (let ((data (json-schema.parse:parse "{\"type\": \"string\"}"))) 16 | (trivial-benchmark:with-timing (1000) 17 | (json-schema:validate data 18 | :context *context*))) 19 | 20 | ;; - SAMPLES TOTAL MINIMUM MAXIMUM MEDIAN AVERAGE DEVIATION 21 | ;; REAL-TIME 1000 0.826 0 0.022 0.001 0.000826 0.000797 22 | ;; RUN-TIME 1000 0.826 0 0.022 0.001 0.000826 0.0008 23 | ;; USER-RUN-TIME 1000 0.781011 0 0.020644 0.000745 0.000781 0.000665 24 | ;; SYSTEM-RUN-TIME 1000 0.049933 0 0.000986 0 0.00005 0.000184 25 | ;; PAGE-FAULTS 1000 0 0 0 0 0 0.0 26 | ;; GC-RUN-TIME 1000 0.02 0 0.02 0 0.00002 0.000632 27 | ;; BYTES-CONSED 1000 213753664 195344 228976 228032 213753.66 16221.591 28 | ;; EVAL-CALLS 1000 0 0 0 0 0 0.0 29 | 30 | 31 | ;;; Uncached 32 | 33 | (let ((data (json-schema.parse:parse "{\"type\": \"string\"}"))) 34 | (trivial-benchmark:with-timing (1000) 35 | (json-schema:validate data 36 | :schema *schema* 37 | :schema-version :draft2019-09))) 38 | 39 | ;; - SAMPLES TOTAL MINIMUM MAXIMUM MEDIAN AVERAGE DEVIATION 40 | ;; REAL-TIME 1000 203.185 0.148 1.471 0.185 0.203185 0.112807 41 | ;; RUN-TIME 1000 9.25 0.006 0.04 0.009 0.00925 0.002294 42 | ;; USER-RUN-TIME 1000 8.145081 0.003368 0.039067 0.008105 0.008145 0.002317 43 | ;; SYSTEM-RUN-TIME 1000 1.107377 0 0.004927 0.000994 0.001107 0.000967 44 | ;; PAGE-FAULTS 1000 0 0 0 0 0 0.0 45 | ;; GC-RUN-TIME 1000 0.08 0 0.03 0 0.00008 0.001464 46 | ;; BYTES-CONSED 1000 719780512 707728 751424 718160 719780.5 11026.181 47 | ;; EVAL-CALLS 1000 0 0 0 0 0 0.0 48 | -------------------------------------------------------------------------------- /json-schema.asd: -------------------------------------------------------------------------------- 1 | ;;;; json-schema.asd 2 | 3 | (defsystem json-schema 4 | :description "JSON schema validation" 5 | :author "Matt Novenstern " 6 | :license "LLGPL" 7 | :version "2.0.0" 8 | :pathname "src" 9 | :components ((:file "utils") 10 | (:file "parse") 11 | (:file "types") 12 | (:file "reference") 13 | (:file "formats") 14 | (:file "validators") 15 | (:file "json-schema")) 16 | :depends-on ("alexandria" 17 | "arrows" 18 | "cl-ppcre" 19 | "dexador" 20 | "function-cache" 21 | "local-time" 22 | "local-time-duration" 23 | "quri" 24 | "sanity-clause" 25 | "st-json" 26 | "str" 27 | "trivial-types") 28 | :homepage "https://fisxoj.github.io/json-schema/" 29 | :in-order-to ((test-op (test-op json-schema/test))) 30 | :long-description #.(uiop:read-file-string #P"README.rst")) 31 | 32 | 33 | (defsystem json-schema/json-schema-test-suite 34 | :depends-on ("json-schema" 35 | "rove") 36 | :pathname "t" 37 | :components ((:file "json-schema-test-case-helper") 38 | (:file "draft2019-09") 39 | (:file "draft7") 40 | (:file "draft6") 41 | (:file "draft4")) 42 | :perform (test-op (op c) 43 | (declare (ignore op)) 44 | (uiop:symbol-call :rove :run c))) 45 | 46 | (defsystem json-schema/unit-tests 47 | :depends-on ("json-schema" 48 | "rove") 49 | :pathname "t" 50 | :components ((:file "utils") 51 | (:file "reference")) 52 | :perform (test-op (op c) 53 | (declare (ignore op)) 54 | (uiop:symbol-call :rove :run c))) 55 | 56 | (defsystem json-schema/test 57 | :in-order-to ((test-op (test-op json-schema/json-schema-test-suite) 58 | (test-op json-schema/unit-tests)))) 59 | -------------------------------------------------------------------------------- /src/formats.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema.formats 2 | (:use :cl :alexandria) 3 | (:export #:draft2019-09 4 | #:draft7 5 | #:draft6 6 | #:draft4 7 | #:draft3)) 8 | 9 | (in-package :json-schema.formats) 10 | 11 | (define-constant +hostname-regex+ (ppcre:create-optimized-test-function "^[A-Za-z0-9][A-Za-z0-9\.\-]{1,255}$") 12 | :test 'string=) 13 | 14 | 15 | (define-constant +unreserved-uri-characters+ (coerce "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ-._~:@/?!$&'()*+,;=" 'list) 16 | :test 'equalp) 17 | 18 | 19 | (defun datep (value) 20 | (handler-case (local-time:parse-rfc3339-timestring value 21 | :allow-missing-time-part t) 22 | (local-time:invalid-timestring (e) 23 | (declare (ignore e)) 24 | nil))) 25 | 26 | 27 | (defun date-time-p (value) 28 | (handler-case (local-time:parse-rfc3339-timestring value 29 | :allow-missing-time-part nil) 30 | (local-time:invalid-timestring (e) 31 | (declare (ignore e)) 32 | nil))) 33 | 34 | 35 | (defun durationp (value) 36 | (handler-case 37 | (and (stringp value) 38 | (local-time-duration:parse-iso8601-duration value)) 39 | (esrap:esrap-parse-error () 40 | nil))) 41 | 42 | 43 | (defun emailp (value) 44 | (and (stringp value) 45 | (find #\@ value :test 'char=))) 46 | 47 | 48 | (defun hostnamep (value) 49 | (and (stringp value) 50 | (ppcre:scan +hostname-regex+ value) 51 | (every (lambda (component) (< (length component) 64)) 52 | (str:split #\. value)) 53 | (not (str:ends-with-p "-" value)))) 54 | 55 | 56 | (defun ip-v4-address-p (value) 57 | (and (stringp value) 58 | (quri:ipv4-addr-p value))) 59 | 60 | 61 | (defun ip-v6-address-p (value) 62 | (and (stringp value) 63 | (quri:ipv6-addr-p value) 64 | ;; https://github.com/fukamachi/quri/pull/34/files 65 | (<= (length (str:split #\: value)) 8))) 66 | 67 | 68 | (defun json-pointer-p (value) 69 | (and (stringp value) 70 | (not (ppcre:scan "~([^01]|$)" value)) 71 | (or (emptyp value) 72 | (char= (char value 0) #\/)))) 73 | 74 | 75 | (defun timep (value) 76 | (and (stringp value) 77 | ;; https://github.com/dlowe-net/local-time/issues/90 78 | (handler-case (local-time:parse-timestring value 79 | :allow-missing-date-part t 80 | :allow-missing-time-part nil 81 | :fract-time-separators '(#\.)) 82 | (local-time:invalid-timestring (e) 83 | (declare (ignore e)) 84 | nil)))) 85 | 86 | 87 | (defun draft3-timep (value) 88 | (flet ((timelikep (value) 89 | (multiple-value-bind (matchp matches) 90 | (ppcre:scan-to-strings "([0-2]?[0-9]):([0-5][0-9]):([0-5][0-9])" 91 | value) 92 | (when (and matchp (= (length matches) 3)) 93 | (and (<= 0 (parse-integer (svref matches 0)) 24) 94 | (<= 0 (parse-integer (svref matches 1)) 59) 95 | (<= 0 (parse-integer (svref matches 2)) 59)))))) 96 | 97 | (and (stringp value) 98 | (timelikep value)))) 99 | 100 | 101 | (defun regexp (value) 102 | (handler-case (ppcre:parse-string value) 103 | (ppcre:ppcre-syntax-error (e) 104 | (declare (ignore e)) 105 | nil))) 106 | 107 | 108 | (defun uri (value) 109 | (handler-case 110 | (let ((uri (quri:uri value))) 111 | (not (emptyp (quri:uri-scheme uri)))) 112 | (quri:uri-error () 113 | nil))) 114 | 115 | 116 | (defun uri-reference (value) 117 | (handler-case 118 | (let ((uri (quri:uri value))) 119 | (and 120 | (or (zerop (length (quri:uri-path uri))) 121 | (member (char (quri:uri-path uri) 0) +unreserved-uri-characters+ :test 'char=)) 122 | (every (rcurry 'member +unreserved-uri-characters+ :test 'char=) 123 | (quri:uri-fragment uri)))) 124 | (quri:uri-error () 125 | nil))) 126 | 127 | 128 | ;;; draft checkers 129 | 130 | (defmacro def-checker (name &rest types-plist) 131 | `(defun ,name (value type) 132 | (alexandria:eswitch (type :test #'string-equal) 133 | ,@(loop for (type function) on types-plist by #'cddr 134 | collecting `(,type (,function value)))))) 135 | 136 | 137 | (def-checker draft2019-09 138 | "date" datep 139 | "date-time" date-time-p 140 | "duration" durationp 141 | "email" emailp 142 | "hostname" hostnamep 143 | "idn-email" emailp 144 | "ipv4" ip-v4-address-p 145 | "ipv6" ip-v6-address-p 146 | "json-pointer" json-pointer-p 147 | "regex" regexp 148 | "time" timep 149 | "uri" uri 150 | "uri-reference" uri-reference) 151 | 152 | 153 | (def-checker draft7 154 | "date" datep 155 | "date-time" date-time-p 156 | "email" emailp 157 | "hostname" hostnamep 158 | "idn-email" emailp 159 | "ipv4" ip-v4-address-p 160 | "ipv6" ip-v6-address-p 161 | "json-pointer" json-pointer-p 162 | "regex" regexp 163 | "time" timep 164 | "uri-reference" uri-reference 165 | "uri" uri) 166 | 167 | 168 | (def-checker draft6 169 | "date-time" date-time-p 170 | "email" emailp 171 | "hostname" hostnamep 172 | "idn-email" emailp 173 | "ipv4" ip-v4-address-p 174 | "ipv6" ip-v6-address-p 175 | "json-pointer" json-pointer-p 176 | "regex" regexp 177 | "uri-reference" uri-reference 178 | "uri" uri) 179 | 180 | 181 | (def-checker draft4 182 | "date-time" date-time-p 183 | "email" emailp 184 | "hostname" hostnamep 185 | "idn-email" emailp 186 | "ipv4" ip-v4-address-p 187 | "ipv6" ip-v6-address-p 188 | "json-pointer" json-pointer-p 189 | "regex" regexp 190 | "uri" uri) 191 | 192 | 193 | (def-checker draft3 194 | "date" datep 195 | "date-time" date-time-p 196 | "email" emailp 197 | "host-name" hostnamep 198 | "idn-email" emailp 199 | "ipv4" ip-v4-address-p 200 | "ipv6" ip-v6-address-p 201 | "json-pointer" json-pointer-p 202 | "regex" regexp 203 | "time" draft3-timep 204 | "uri" uri) 205 | -------------------------------------------------------------------------------- /src/json-schema.lisp: -------------------------------------------------------------------------------- 1 | (defpackage json-schema 2 | (:use :cl :alexandria) 3 | (:local-nicknames (:reference :json-schema.reference) 4 | (:validators :json-schema.validators)) 5 | (:shadowing-import-from :json-schema.utils 6 | :schema-version) 7 | (:import-from #:json-schema.reference 8 | #:make-context) 9 | (:export #:validate 10 | #:make-context 11 | #:*schema-version* 12 | #:schema-version)) 13 | 14 | (in-package :json-schema) 15 | 16 | 17 | (defparameter *schema-version* :draft7) 18 | 19 | 20 | (defun validate (data &key (schema-version *schema-version*) (pretty-errors-p t) schema context) 21 | "The primary validation function for json-schema. Takes data: which can be a simple value or an object as a hash table, and then optionally accepts a schema (if the data doesn't contain a top-level ``$schema`` key), schema version and pretty-errors-p deterimines whether the second return value is exception objects or strings of the rendered errors (strings by default). 22 | 23 | The third return value is a :class:`json-schema.reference::context`, which contains all of the state stored in processing a schema including caching network resources and all of the resolved ids." 24 | (assert (not (and schema context)) nil "You should only pass one of ") 25 | 26 | (let* ((schema (or schema 27 | (and context (reference:context-schema-version context)) 28 | (reference:fetch-schema (json-schema.utils:object-get "$schema" data)))) 29 | (context (or context (reference:make-context 30 | (or schema (reference:fetch-schema (json-schema.utils:object-get "$schema" data))) 31 | schema-version)))) 32 | (reference:with-context (context) 33 | (if-let ((errors (validators:validate 34 | (reference:context-root-schema context) 35 | data 36 | (reference:context-schema-version context)))) 37 | (values nil (mapcar (if pretty-errors-p #'princ-to-string #'identity) errors) context) 38 | (values t nil context))))) 39 | -------------------------------------------------------------------------------- /src/parse.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema.parse 2 | (:use :cl :alexandria :arrows) 3 | (:export 4 | #:parse)) 5 | 6 | (in-package :json-schema.parse) 7 | 8 | 9 | (defun parse (input) 10 | (flet ((parse (input) 11 | (let ((*read-default-float-format* 'double-float) 12 | (st-json:*decode-objects-as* :hashtable)) 13 | (st-json:read-json input)))) 14 | (etypecase input 15 | (string 16 | (parse input)) 17 | 18 | (pathname 19 | (with-open-file (input input) 20 | (parse input))) 21 | 22 | (stream 23 | (parse input))))) 24 | -------------------------------------------------------------------------------- /src/reference.lisp: -------------------------------------------------------------------------------- 1 | (defpackage json-schema.reference 2 | (:use :cl :alexandria :arrows) 3 | (:local-nicknames (:utils :json-schema.utils) 4 | (:parse :json-schema.parse)) 5 | (:export #:make-context 6 | #:with-context 7 | #:context-schema-version 8 | #:context-root-schema 9 | #:relative-reference-p 10 | #:get-subspec-by-ref 11 | #:resolve 12 | #:with-resolved-ref 13 | #:*resolve-remote-references* 14 | #:*http-read-timeout* 15 | #:*http-connect-timeout* 16 | #:fetch-schema 17 | 18 | ;; conditions 19 | #:remote-reference-error 20 | #:fetching-not-allowed-error 21 | #:reference-error 22 | #:nested-reference-error 23 | #:with-pushed-id 24 | #:get-id-fun-for-schema-version)) 25 | 26 | (in-package :json-schema.reference) 27 | 28 | ;;; NOTE: inside this file, `ref` refers to the property of a json object, and `reference` is the structure object we use internally for bookkeeping. 29 | 30 | 31 | (defvar *context* nil 32 | "The lookup context for references.") 33 | 34 | 35 | (defparameter +max-lookup-depth+ 100 36 | "Maximum number of nested references to allow before throwing a :class:`nested-reference-error`.") 37 | 38 | 39 | (defvar *current-lookup-depth* 0 40 | "Dynamic variable for tracking reference nesting depth.") 41 | 42 | 43 | (defvar *resolve-remote-references* t 44 | "Whether to download other schemas for references. Will error if another uri is referenced in a schema and this var is set to ``nil``.") 45 | 46 | 47 | (defvar *id-fun* 'default-id-fun 48 | "A default function for getting ids from schemas. Should return (values id found-p) like gethash.") 49 | 50 | 51 | (defvar *http-read-timeout* 10 52 | "Number of seconds before a :class:`remote-reference-error` will be signaled while trying to read a remote schema.") 53 | 54 | 55 | (defvar *http-connect-timeout* 10 56 | "Number of seconds before a :class:`remote-reference-error` will be signaled while trying to connect to a remote schema.") 57 | 58 | 59 | (defmacro with-lookup-depth-tracking (&body body) 60 | `(unwind-protect 61 | (progn 62 | (incf *current-lookup-depth*) 63 | (when (> *current-lookup-depth* +max-lookup-depth+) 64 | (error 'nested-reference-error)) 65 | ,@body) 66 | (decf *current-lookup-depth*))) 67 | 68 | 69 | (define-condition reference-error (error) 70 | ((message :type string 71 | :initarg :message)) 72 | 73 | (:report (lambda (c stream) 74 | (format stream "JSON Schema reference error: ~a" 75 | (slot-value c 'message))))) 76 | 77 | 78 | (define-condition fetching-not-allowed-error (reference-error) 79 | ((remote-uri :type string 80 | :initarg :uri)) 81 | 82 | (:report (lambda (c stream) 83 | (format stream "JSON Schema reference error: need to fetch ~S but *RESOLVE-REMOTE-REFERENCES* is nil." 84 | (slot-value c 'remote-uri))))) 85 | 86 | 87 | (define-condition remote-reference-error (reference-error) 88 | ((remote-uri :type string 89 | :initarg :uri)) 90 | (:report (lambda (c stream) 91 | (format stream "JSON Schema reference error, when fetching ~S: ~a" 92 | (slot-value c 'remote-uri) 93 | (slot-value c 'message))))) 94 | 95 | 96 | (define-condition nested-reference-error (reference-error) 97 | () 98 | (:report (lambda (c stream) 99 | (format stream "Reference nesting depth of ~d exceeded." 100 | +max-lookup-depth+)))) 101 | 102 | 103 | (defstruct (context (:constructor %make-context)) 104 | "A container for all state related to resolving references, namely: a stack of context urls" 105 | (root-schema nil :type utils:schema) 106 | (schema-version nil :type utils:schema-version) 107 | (uri-stack nil :type (trivial-types:proper-list string)) 108 | (references (make-hash-table :test 'equal) :type hash-table) 109 | (named-references (make-hash-table :test'equal) :type hash-table)) 110 | 111 | 112 | (defun make-context (schema schema-version) 113 | "Given a root schema document :param:`schema` and a json schema version :param:`schema-version`, create a reusable context object that will cache all schema data including remote references that get fetched." 114 | (check-type schema utils:schema) 115 | (check-type schema-version utils:schema-version) 116 | 117 | (%make-context 118 | :root-schema schema 119 | :schema-version schema-version)) 120 | 121 | 122 | (defun default-id-fun (schema) 123 | (if (typep schema 'utils:object) 124 | (utils:object-get "$id" schema "") 125 | (values "" nil))) 126 | 127 | 128 | (defun draft2019-09-id-fun (schema) 129 | "An id extraction function that also pays attention to $anchor properties which provide only location-independent references." 130 | 131 | (if (typep schema 'utils:object) 132 | (multiple-value-bind (id id-found-p) (utils:object-get "$id" schema) 133 | (multiple-value-bind (anchor anchor-found-p) (utils:object-get "$anchor" schema) 134 | (values (quri:merge-uris (or (str:concat "#" anchor) "") 135 | (or id "")) 136 | (or id-found-p anchor-found-p)))) 137 | (values "" nil))) 138 | 139 | 140 | (defun draft4-id-fun (schema) 141 | "Like the default, but id doesn't have a $ prefix." 142 | (if (typep schema 'utils:object) 143 | (utils:object-get "id" schema "") 144 | (values "" nil))) 145 | 146 | 147 | (defun get-id-fun-for-schema-version (schema-version) 148 | "Selects an id function that's appropriate for each schema draft." 149 | (check-type schema-version utils:schema-version) 150 | 151 | (ecase schema-version 152 | (:draft2019-09 153 | 'draft2019-09-id-fun) 154 | ((or :draft7 :draft6) 155 | 'default-id-fun) 156 | (:draft4 157 | 'draft4-id-fun))) 158 | 159 | 160 | (defmacro with-context ((context) &body body) 161 | (once-only (context) 162 | `(let* ((*context* ,context) 163 | (*id-fun* (get-id-fun-for-schema-version (context-schema-version *context*)))) 164 | (with-pushed-context ((context-root-schema *context*)) 165 | ,@body)))) 166 | 167 | 168 | (defun push-context (schema &optional (id-fun *id-fun*)) 169 | ;; (format t "~&> pc: pushing schema id ~S.~%" 170 | ;; (funcall id-fun schema)) 171 | 172 | (let ((uri (make-uri-without-fragment (funcall id-fun schema)))) 173 | (push uri (context-uri-stack *context*)) 174 | 175 | (unless (gethash uri (context-references *context*)) 176 | (setf (gethash uri (context-references *context*)) schema)) 177 | 178 | (populate-named-references-for-schema schema 179 | :id-fun id-fun 180 | :uri (quri:uri uri)))) 181 | 182 | 183 | (defun pop-context () 184 | (pop (context-uri-stack *context*))) 185 | 186 | 187 | (defmacro with-pushed-id ((id) &body body) 188 | (once-only (id) 189 | `(unwind-protect 190 | (progn 191 | (push (quri:render-uri (quri:merge-uris (make-uri-without-fragment ,id) (get-current-uri))) (context-uri-stack *context*)) 192 | ,@body) 193 | (pop-context)))) 194 | 195 | 196 | (defmacro with-pushed-context ((schema) &body body) 197 | (once-only (schema) 198 | `(unwind-protect 199 | (progn 200 | (push-context ,schema) 201 | ,@body) 202 | (pop-context)))) 203 | 204 | 205 | (defmacro with-resolved-ref ((ref resolved-schema &optional (id-fun '*id-fun*)) &body body) 206 | 207 | (once-only (ref) 208 | (with-gensyms (resolved-p schema-uri id found-p) 209 | `(multiple-value-bind (,resolved-schema ,resolved-p ,schema-uri) 210 | (resolve ,ref) 211 | 212 | (if ,resolved-p 213 | (unwind-protect 214 | (progn 215 | ;; FIXME: it's definitely happening here 216 | (push-context (gethash ,resolved-schema (context-references *context*)) 217 | (lambda (s) 218 | ;; If the schema contains an id, great. If not, use the url we fetched it from. 219 | (multiple-value-bind (,id ,found-p) 220 | (funcall ,id-fun s) 221 | (if ,found-p 222 | ,id 223 | ,schema-uri)))) 224 | 225 | ,@body) 226 | (pop-context)) 227 | (progn ,@body)))))) 228 | 229 | 230 | (defun get-current-uri () 231 | (assert (not (null (context-uri-stack *context*))) nil 232 | "No uris in context stack.") 233 | 234 | (first (context-uri-stack *context*))) 235 | 236 | 237 | (defun get-current-schema () 238 | (gethash (get-current-uri) (context-references *context*))) 239 | 240 | 241 | (defun unescape (string) 242 | "Unescape a string to replace ~0 and ~1 with ~ and /." 243 | 244 | (with-output-to-string (out) 245 | (with-input-from-string (in string) 246 | 247 | (loop for char = (read-char in nil nil) 248 | for next-char = (peek-char nil in nil nil) 249 | 250 | while char 251 | 252 | do (cond 253 | ((and (char= char #\~) (char= next-char #\0)) 254 | (read-char in) 255 | (princ #\~ out)) 256 | 257 | ((and (char= char #\~) (char= next-char #\1)) 258 | (read-char in) 259 | (princ #\/ out)) 260 | 261 | ((and (char= char #\~) (null next-char)) 262 | (error "String ended while reading escaped character.")) 263 | 264 | (t 265 | (princ char out))))))) 266 | 267 | 268 | (defun escape (string) 269 | (with-output-to-string (out) 270 | (loop for char across string 271 | do (cond 272 | ((char= char #\~) 273 | (princ "~0" out)) 274 | 275 | ((char= char #\/) 276 | (princ "~1" out)) 277 | 278 | (t 279 | (princ char out)))))) 280 | 281 | 282 | (defclass reference () 283 | ((relative-path :type (or string ;; location-independent reference 284 | (trivial-types:proper-list string)) ;; json pointer 285 | :initarg :relative-path 286 | :accessor relative-path-of) 287 | (uri :type string 288 | :initarg :uri 289 | :accessor uri-of))) 290 | 291 | 292 | (defmethod print-object ((object reference) stream) 293 | (print-unreadable-object (object stream :type t) 294 | (format stream "uri: ~S path: ~S" 295 | (uri-of object) 296 | (relative-path-of object)))) 297 | 298 | 299 | (defun reference-eq (reference1 reference2) 300 | (declare (type reference reference1 reference2)) 301 | 302 | (and (string= (uri-of reference1) (uri-of reference2)) 303 | (= (length (relative-path-of reference1)) 304 | (length (relative-path-of reference2))) 305 | (every #'= (relative-path-of reference1) (relative-path-of reference2)))) 306 | 307 | 308 | (defun make-relative-path-list (relative-path-string) 309 | (mapcar (lambda (element) 310 | (cond 311 | ((every (lambda (char) (member char '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0) 312 | :test #'char=)) 313 | element) 314 | (parse-integer element)) 315 | 316 | (t 317 | (funcall (compose #'quri:url-decode #'unescape) element)))) 318 | (subseq (str:split #\/ relative-path-string) 1))) 319 | 320 | 321 | (defun make-uri-without-fragment (uri) 322 | (-> (typecase uri 323 | (quri:uri uri) 324 | (string (quri:uri uri))) 325 | (quri:copy-uri :fragment nil 326 | :query nil) 327 | quri:render-uri)) 328 | 329 | 330 | (defun make-reference (reference-string) 331 | (let* ((uri (quri:merge-uris reference-string (get-current-uri))) 332 | (fragment (quri:uri-fragment uri))) 333 | 334 | (make-instance 'reference 335 | :relative-path (unless (zerop (length fragment)) 336 | (if (char= (char fragment 0) #\/) 337 | ;; json-pointer 338 | (make-relative-path-list fragment) 339 | ;; location-independent 340 | (str:concat "#" fragment))) 341 | :uri (make-uri-without-fragment uri)))) 342 | 343 | 344 | (defun relative-reference-p (reference) 345 | (check-type reference reference) 346 | (string= "" (uri-of reference))) 347 | 348 | 349 | (defun fetch-schema (uri) 350 | "Fetches a remote document or raises an error depending on the value of :variable:`*resolve-remote-references*`." 351 | (if *resolve-remote-references* 352 | (handler-case 353 | (-> uri 354 | (dex:get :read-timeout *http-read-timeout* 355 | :connect-timeout *http-connect-timeout* 356 | :force-binary t) 357 | babel:octets-to-string 358 | parse:parse) 359 | (usocket:connection-refused-error (error) 360 | (declare (ignore error)) 361 | (error 'remote-reference-error 362 | :message "connection refused" 363 | :uri uri)) 364 | (usocket:timeout-error (error) 365 | (declare (ignore error)) 366 | (error 'remote-reference-error 367 | :message "connection timed out" 368 | :uri uri)) 369 | (dex:http-request-not-found (error) 370 | (declare (ignore error)) 371 | (error 'remote-reference-error 372 | :message "document not found" 373 | :uri uri))) 374 | (error 'fetching-not-allowed-error 375 | :uri uri))) 376 | 377 | 378 | (defun fetch-reference (uri) 379 | "Fetches a schema and adds it to the current context as a side effect." 380 | (flet ((store-schema (schema) 381 | (setf (gethash uri (context-references *context*)) schema) 382 | (populate-named-references-for-schema schema 383 | :id-fun #'default-id-fun 384 | :uri (quri:uri uri)) 385 | schema)) 386 | (-> uri 387 | fetch-schema 388 | store-schema))) 389 | 390 | 391 | (defun get-ref (spec) 392 | (utils:object-get "$ref" spec)) 393 | 394 | 395 | (defun ref-p (spec) 396 | "A spec is a reference if it has only one key which is ``$ref``." 397 | 398 | (and (not (null spec)) 399 | (nth-value 1 (get-ref spec)))) 400 | 401 | 402 | (defun absolute-uri (reference) 403 | "Return an absolute URI for the reference in the current context." 404 | 405 | (quri:render-uri (quri:merge-uris (uri-of reference) (get-current-uri)))) 406 | 407 | 408 | (defun lookup (reference) 409 | "Look up a schema by reference in the ``*context*``. Returns ``(values schema new-context-p)``. ``new-context-p`` indicates that this schema is a new document that should be pushed to the context stack when visited." 410 | 411 | (with-lookup-depth-tracking 412 | (let* ((schema-uri (absolute-uri reference)) 413 | (relative-path (relative-path-of reference))) 414 | 415 | (flet ((ensure-schema-fetched () 416 | (unless (gethash schema-uri (context-references *context*)) 417 | (fetch-reference schema-uri))) 418 | (new-context-p () 419 | ;; some loookups might change the uri by id, 420 | ;; so this is a function to calculate it at return time 421 | (not (string= schema-uri (get-current-uri))))) 422 | 423 | (etypecase relative-path 424 | (null 425 | ;; no relative part 426 | (ensure-schema-fetched) 427 | 428 | (values (gethash schema-uri (context-references *context*)) 429 | (new-context-p) 430 | schema-uri)) 431 | 432 | (string 433 | ;; location-independent 434 | (ensure-schema-fetched) 435 | 436 | (values (gethash relative-path (gethash (uri-of reference) (context-named-references *context*))) 437 | (new-context-p) 438 | schema-uri)) 439 | 440 | (proper-list 441 | ;; json pointer 442 | 443 | (ensure-schema-fetched) 444 | 445 | (multiple-value-bind (schema found-p) 446 | (gethash schema-uri (context-references *context*)) 447 | 448 | (if found-p 449 | (values (loop with spec = schema 450 | for (component . rest) on relative-path by #'cdr 451 | 452 | if (stringp component) 453 | do (progn 454 | (setf spec (utils:object-get component spec)) 455 | (when-let ((id (funcall *id-fun* spec))) 456 | ;; if we're in the same object as an id, leave that off 457 | (when rest 458 | (setf schema-uri (quri:render-uri (quri:merge-uris id schema-uri)))))) 459 | else ;; an integer 460 | do (setf spec (nth component spec)) 461 | 462 | finally (return spec)) 463 | (new-context-p) 464 | schema-uri) 465 | (values nil nil schema-uri))))))))) 466 | 467 | 468 | (defun resolve (ref) 469 | "Resolves a reference schema object to the referred-to schema." 470 | 471 | (lookup (make-reference (get-ref ref)))) 472 | 473 | 474 | 475 | (defun collect-subschemas (schema &key (id-fun *id-fun*) current-uri properties-p) 476 | "Collect all named subschemas into an alist of (name . schema-object)." 477 | 478 | (when (typep schema 'utils:object) 479 | (multiple-value-bind (id found-p) (funcall id-fun schema) 480 | (let* ((current-uri (cond 481 | ;; properties-p: we don't want to collect any "$id" properties 482 | ;; that are direct children of a "properties" field. This is a 483 | ;; bit hacky, but is important because this happens in the 484 | ;; meta-schemas. 485 | (properties-p 486 | current-uri) 487 | ((and found-p current-uri) 488 | (quri:merge-uris id current-uri)) 489 | (found-p 490 | (quri:uri id)) 491 | (current-uri 492 | current-uri))) 493 | (subschema-ids (loop for key in (utils:object-keys schema) 494 | for maybe-schema = (utils:object-get key schema) 495 | 496 | appending (collect-subschemas maybe-schema 497 | :id-fun id-fun 498 | :current-uri current-uri 499 | :properties-p (utils:object-get "properties" schema))))) 500 | (if (and found-p (not properties-p)) 501 | (list* (cons current-uri schema) subschema-ids) 502 | subschema-ids))))) 503 | 504 | 505 | (defun populate-named-references-for-schema (schema &key (id-fun *id-fun*) uri) 506 | "Takes an alist of (uri . schema) and populates the appropriate hash tables in the named references slot of the context. Takes the output from collect subschemas, which may return named references for many uri's, since documents are allowed to insist they have whatever uri they want whenever they want." 507 | 508 | (loop for (uri . schema) in (collect-subschemas schema :id-fun id-fun :current-uri uri) 509 | for reference = (make-reference uri) 510 | 511 | ;; do (format t "~&Setting named reference ~S for document ~S." 512 | ;; (relative-path-of reference) 513 | ;; (uri-of reference)) 514 | 515 | unless (gethash (uri-of reference) (context-named-references *context*)) 516 | do (setf (gethash (uri-of reference) (context-named-references *context*)) 517 | (make-hash-table :test 'equal)) 518 | 519 | when (relative-path-of reference) 520 | do (setf (gethash (relative-path-of reference) (gethash (uri-of reference) (context-named-references *context*))) 521 | schema) 522 | 523 | unless (gethash (uri-of reference) (context-references *context*)) 524 | ;; pretend this is a document we downloaded... 525 | do (if (relative-path-of reference) 526 | ;; We're expected to resolve against these uris and not fetch them, soooo.... 527 | (setf (gethash (uri-of reference) (context-references *context*)) 528 | :stub) 529 | (setf (gethash (uri-of reference) (context-references *context*)) 530 | schema)))) 531 | -------------------------------------------------------------------------------- /src/types.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema.types 2 | (:use #:cl 3 | #:alexandria) 4 | (:local-nicknames (:utils :json-schema.utils)) 5 | (:export #:draft3 6 | #:draft4 7 | #:draft6 8 | #:draft7 9 | #:draft2019-09)) 10 | 11 | (in-package :json-schema.types) 12 | 13 | ;; adapted to lisp from: 14 | ;; https://github.com/Julian/jsonschema/blob/master/jsonschema/_types.py 15 | 16 | 17 | (defun boolean-p (value) 18 | (member value '(:false :true))) 19 | 20 | 21 | (defun object-p (value) 22 | (typep value 'utils:object)) 23 | 24 | 25 | (defun any-p (value) 26 | (declare (ignore value)) 27 | t) 28 | 29 | 30 | (defun array-p (value) 31 | "Arrays are valid, but not strings." 32 | 33 | (and (proper-list-p value) 34 | (not (stringp value)))) 35 | 36 | 37 | (defun null-p (value) 38 | (eq value :null)) 39 | 40 | 41 | (defun integer-p (value) 42 | "JSON Schema considers anything without a fractional part an integer, ie. 1.0d0 is an integer. 🤷" 43 | (and (numberp value) 44 | (= (floor value) value))) 45 | 46 | 47 | (defmacro def-checker (name &rest types-plist) 48 | `(defun ,name (value type) 49 | (alexandria:eswitch (type :test #'string-equal) 50 | ,@(loop for (type function) on types-plist by #'cddr 51 | collecting `(,type (,function value)))))) 52 | 53 | 54 | (def-checker draft3 55 | "any" any-p 56 | "array" arrayp 57 | "boolean" boolean-p 58 | "integer" integer-p 59 | "object" object-p 60 | "null" null-p 61 | "number" realp 62 | "string" stringp) 63 | 64 | 65 | (def-checker draft4 66 | "array" array-p 67 | "boolean" boolean-p 68 | "integer" integer-p 69 | "object" object-p 70 | "null" null-p 71 | "number" realp 72 | "string" stringp) 73 | 74 | 75 | (def-checker draft6 76 | "array" array-p 77 | "boolean" boolean-p 78 | "integer" integer-p 79 | "object" object-p 80 | "null" null-p 81 | "number" realp 82 | "string" stringp) 83 | 84 | 85 | (def-checker draft7 86 | "array" array-p 87 | "boolean" boolean-p 88 | "integer" integer-p 89 | "object" object-p 90 | "null" null-p 91 | "number" realp 92 | "string" stringp) 93 | 94 | 95 | (def-checker draft2019-09 96 | "array" array-p 97 | "boolean" boolean-p 98 | "integer" integer-p 99 | "object" object-p 100 | "null" null-p 101 | "number" realp 102 | "string" stringp) 103 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema.utils 2 | (:local-nicknames (:json :st-json)) 3 | (:use :cl :alexandria) 4 | (:export #:object-equal-p 5 | #:object-keys 6 | #:json-equal-p 7 | #:object-get 8 | #:empty-object-p 9 | 10 | #:schema-version 11 | #:object 12 | #:schema 13 | #:json-boolean 14 | #:json-null 15 | #:json-array 16 | #:make-empty-object 17 | #:json-pretty-printer)) 18 | 19 | (in-package :json-schema.utils) 20 | 21 | 22 | (deftype schema-version () 23 | '(member :draft2019-09 24 | :draft7 25 | :draft6 26 | :draft4 27 | :draft3)) 28 | 29 | 30 | (deftype object () 31 | 'hash-table) 32 | 33 | 34 | (deftype json-boolean () 35 | 'st-json:json-bool) 36 | 37 | 38 | (deftype json-null () 39 | 'st-json:json-null) 40 | 41 | 42 | (deftype json-array () 43 | 'proper-list) 44 | 45 | 46 | (deftype schema () 47 | '(or object json-boolean)) 48 | 49 | (defun make-empty-object () 50 | (make-hash-table :test 'equal)) 51 | 52 | 53 | (defun object-keys (object) 54 | (hash-table-keys object)) 55 | 56 | 57 | (defun object-get (key object &optional default) 58 | (declare (type string key) 59 | (type object object)) 60 | 61 | (multiple-value-bind (value found-p) (gethash key object) 62 | (values (if found-p value default) (the boolean found-p)))) 63 | 64 | 65 | (defun empty-object-p (object) 66 | (zerop (hash-table-count object))) 67 | 68 | 69 | (defun json-equal-p (thing1 thing2) 70 | "A generic comparison function for comparing anything that might be a json value." 71 | 72 | (typecase thing1 73 | (number 74 | (when (numberp thing2) 75 | (= thing1 thing2))) 76 | 77 | (string 78 | (when (stringp thing2) 79 | (string= thing1 thing2))) 80 | 81 | (object 82 | (when (typep thing2 'object) 83 | (object-equal-p thing1 thing2))) 84 | 85 | (proper-list 86 | (when (proper-list-p thing2) 87 | (and (= (length thing1) (length thing2)) 88 | (every #'json-equal-p thing1 thing2)))) 89 | 90 | (json-boolean 91 | (when (typep thing2 'json-boolean) 92 | (eq thing1 thing2))) 93 | 94 | (json-null 95 | (when (typep thing2 'json-null) 96 | (eq thing1 thing2))))) 97 | 98 | 99 | (defun object-equal-p (object1 object2) 100 | (and (alexandria:set-equal (object-keys object1) (object-keys object2) 101 | :test 'equal) 102 | (loop for key in (object-keys object1) 103 | for prop1 = (object-get key object1) 104 | for prop2 = (object-get key object2) 105 | unless (typecase prop1 106 | (object 107 | (when (typep prop2 'object) 108 | (json-equal-p prop1 prop2))) 109 | 110 | (t (equal prop1 prop2))) 111 | return nil 112 | finally (return t)))) 113 | 114 | 115 | (defun json-pretty-printer (stream json-object at colon) 116 | (declare (ignore at colon)) 117 | (st-json:write-json json-object stream)) 118 | -------------------------------------------------------------------------------- /src/validators.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema.validators 2 | (:local-nicknames (:formats :json-schema.formats) 3 | (:types :json-schema.types) 4 | (:utils :json-schema.utils) 5 | (:reference :json-schema.reference)) 6 | (:use :cl :alexandria) 7 | (:export #:validate 8 | #:validation-failed-error)) 9 | 10 | (in-package :json-schema.validators) 11 | 12 | (defparameter *schema-version* :draft7) 13 | 14 | 15 | (define-condition validation-failed-error (error) 16 | ((error-message :initarg :error-message) 17 | (property-name :initarg :property-name :initform nil) 18 | (sub-errors :initarg :sub-errors :initform nil)) 19 | (:report (lambda (c stream) 20 | (format stream "~a~@[~2%Additionally:~%~{- ~a~%~}~]" 21 | (slot-value c 'error-message) 22 | (slot-value c 'sub-errors))))) 23 | 24 | 25 | (defmacro defvfun (name validation-field &body body) 26 | (flet ((property-name (name) 27 | ;; When properties shadow symbols in the CL package, they get named {property}-validator, so clean that off for prettier names 28 | (let ((string (string-downcase name))) 29 | (if (str:ends-with-p "-validator" string) 30 | (subseq string 0 (- (length string) #.(length "-VALIDATOR"))) 31 | string)))) 32 | 33 | `(defun ,name (schema ,validation-field data) 34 | (declare (optimize space speed)) 35 | (macrolet ((require-type (type) 36 | `(unless (validate-type nil ,type data) 37 | (return-from ,',name))) 38 | 39 | (condition (form error-string &rest format-args) 40 | `(unless ,form 41 | (error 'validation-failed-error 42 | :property-name ,,(property-name name) 43 | :error-message (format nil ,error-string 44 | ,@format-args)))) 45 | 46 | (sub-errors (errors error-string &rest format-args) 47 | (once-only (errors) 48 | `(when ,errors 49 | (error 'validation-failed-error 50 | :sub-errors ,errors 51 | :property-name ,,(property-name name) 52 | :error-message (format nil ,error-string 53 | ,@format-args)))))) 54 | 55 | ,@body)))) 56 | 57 | 58 | (defun validate-type (schema type data) 59 | "This is a tool for checking type validation, but isn't a validator itself. It's used by many of the validator functions to decide wether they can have an opinion on the data being validated, but is also used by :function:`type-validator`." 60 | (declare (ignore schema)) 61 | 62 | (flet ((type-check (type) 63 | (ecase *schema-version* 64 | (:draft2019-09 (types:draft2019-09 data type)) 65 | (:draft7 (types:draft7 data type)) 66 | (:draft6 (types:draft6 data type)) 67 | (:draft4 (types:draft4 data type)) 68 | (:draft3 (types:draft3 data type))))) 69 | 70 | (if (listp type) 71 | (some #'type-check type) 72 | (type-check type)))) 73 | 74 | 75 | (define-condition no-validator-condition () 76 | ((field-name :initarg :field-name))) 77 | 78 | 79 | (defun validate (schema data &optional (schema-version *schema-version*) ignore-id) 80 | (declare (optimize space speed)) 81 | (check-type schema-version utils:schema-version) 82 | 83 | (let ((*schema-version* schema-version)) 84 | (cond 85 | ((typep schema 'utils:json-boolean) 86 | (if (eq schema :true) 87 | nil 88 | (list 89 | (make-instance 'validation-failed-error 90 | :property-name "" 91 | :error-message "Schema :false is always false.")))) 92 | 93 | ((utils:empty-object-p schema) 94 | nil) 95 | 96 | ((and (typep schema 'utils:object) 97 | (nth-value 1 (funcall (symbol-function (reference:get-id-fun-for-schema-version schema-version)) 98 | schema)) 99 | (not ignore-id)) 100 | 101 | (reference:with-pushed-id ((funcall (symbol-function (reference:get-id-fun-for-schema-version schema-version)) 102 | schema)) 103 | (validate schema data schema-version t))) 104 | 105 | ((typep schema 'utils:object) 106 | (loop for property in (utils:object-keys schema) 107 | for value = (utils:object-get property schema) 108 | appending (handler-case (progn 109 | (ecase schema-version 110 | (:draft2019-09 111 | (draft2019-09 schema 112 | property 113 | value 114 | data)) 115 | (:draft7 116 | (draft7 schema 117 | property 118 | value 119 | data)) 120 | (:draft6 121 | (draft6 schema 122 | property 123 | value 124 | data)) 125 | (:draft4 126 | (draft4 schema 127 | property 128 | value 129 | data))) 130 | nil) 131 | 132 | (no-validator-condition (c) 133 | (warn "No validator for field ~S - skipping." 134 | (slot-value c 'field-name)) 135 | nil) 136 | 137 | (validation-failed-error (error) 138 | (list error)))))))) 139 | 140 | ;;; Helpers for validators 141 | 142 | (defun check-dependencies (property-name dependencies data &key (allow-arrays t) (allow-objects t)) 143 | (flet ((check-dependency (key dependency) 144 | (etypecase dependency 145 | (utils:json-array 146 | (unless allow-arrays 147 | (make-instance 'validation-failed-error 148 | :property-name property-name 149 | :error-message (format nil "~d is not a valid dependency." 150 | dependency))) 151 | (unless (every (lambda (dependency-key) 152 | (nth-value 1 (utils:object-get dependency-key data))) 153 | dependency) 154 | (make-instance 'validation-failed-error 155 | :property-name "dependencies" 156 | :error-message (format nil "Field ~S depends on fields ~S, but some were missing." 157 | key 158 | (utils:object-get key dependencies))))) 159 | 160 | ;; A subschema... 😭 161 | (utils:object 162 | (unless allow-objects 163 | (make-instance 'validation-failed-error 164 | :property-name property-name 165 | :error-message (format nil "~d is not a valid dependency." 166 | dependency))) 167 | (when-let ((validation-errors (validate dependency data *schema-version*))) 168 | (make-instance 'validation-failed-error 169 | :property-name property-name 170 | :error-message (format nil "Field ~S depends on the schema ~/json-schema.utils:json-pretty-printer/ being valid, but it wasn't." 171 | key 172 | dependency)))) 173 | ;; maybe true, false, null 174 | ((or utils:json-boolean utils:json-null) 175 | (when-let ((validation-errors (validate dependency data *schema-version*))) 176 | (make-instance 'validation-failed-error 177 | :property-name property-name 178 | :error-message (format nil "Field ~S depends on the schema ~/json-schema.utils:json-pretty-printer/ being valid, but it wasn't." 179 | key 180 | dependency))))))) 181 | 182 | (remove-if #'null 183 | (loop for key in (utils:object-keys dependencies) 184 | when (nth-value 1 (utils:object-get key data)) 185 | ;; when the key is found in the data 186 | collecting (check-dependency key (utils:object-get key dependencies)))))) 187 | 188 | 189 | ;;; Validation functions for individaul properties 190 | 191 | 192 | (defun noop (schema property data) 193 | "This exists to say we have taken care of a property, but we should do nothing with it. Likely because this property is actually handled by other things. ``else`` and ``then`` are handled by :function:`if-validator`, &c." 194 | 195 | (declare (ignore schema property data))) 196 | 197 | 198 | (defvfun $ref reference 199 | (reference:with-resolved-ref (schema resolved-schema) 200 | (sub-errors (validate resolved-schema data) 201 | "Error validating referred schema at ~S." 202 | reference))) 203 | 204 | 205 | (defvfun additional-items additional-items 206 | (require-type "array") 207 | 208 | (when (validate-type nil "object" (utils:object-get "items" schema (utils:make-empty-object))) 209 | (return-from additional-items)) 210 | 211 | (let ((items-length (length (utils:object-get "items" schema)))) 212 | ;; There are only additional items if there are more than the items schema 213 | ;; mentions 214 | (when (> (length data) items-length) 215 | (sub-errors (loop for item in (subseq data items-length) 216 | appending (validate additional-items item)) 217 | "Errors validating additional items against ~a." 218 | additional-items)))) 219 | 220 | 221 | (defvfun additional-properties value 222 | (require-type "object") 223 | 224 | (labels ((remove-pattern-property-keys (list) 225 | (if-let ((pattern-properties (utils:object-get "patternProperties" schema))) 226 | 227 | (remove-if (lambda (key) 228 | (some (lambda (pattern) (ppcre:scan pattern key)) 229 | (utils:object-keys pattern-properties))) 230 | list) 231 | list))) 232 | 233 | (cond 234 | ((eq value :false) 235 | (let* ((schema-properties (when-let ((properties (utils:object-get "properties" schema))) 236 | (utils:object-keys properties))) 237 | 238 | (data-properties (utils:object-keys data)) 239 | 240 | ;; pattern properties don't count as additional 241 | (additional-properties (remove-pattern-property-keys 242 | (set-difference data-properties 243 | schema-properties 244 | :test #'string=)))) 245 | 246 | (condition (null additional-properties) 247 | "~S contains more properties (~S) than specified in the schema ~S" 248 | data-properties additional-properties schema-properties))) 249 | 250 | ((typep value 'utils:object) 251 | (let* ((schema-properties (when-let ((properties (utils:object-get "properties" schema))) 252 | (utils:object-keys properties))) 253 | 254 | (data-properties (utils:object-keys data)) 255 | 256 | ;; pattern properties don't count as additional 257 | (additional-properties (remove-pattern-property-keys 258 | (set-difference data-properties 259 | schema-properties 260 | :test #'string=))) 261 | (errors (loop for property in additional-properties 262 | appending (validate value (utils:object-get property data))))) 263 | (sub-errors errors 264 | "There were errors validating additional properties.")))))) 265 | 266 | 267 | (defvfun all-of sub-schemas 268 | (loop for sub-schema in sub-schemas 269 | appending (validate sub-schema data) into errors 270 | finally (sub-errors errors 271 | "~a didn't satisfy all schemas in ~{~/json-schema.utils:json-pretty-printer/~^, ~}" 272 | data 273 | sub-schemas))) 274 | 275 | 276 | (defvfun any-of sub-schemas 277 | 278 | (let ((errors (loop for sub-schema in sub-schemas 279 | for errors = (validate sub-schema data) 280 | 281 | when (null errors) 282 | return nil 283 | 284 | collect errors into all-errors 285 | 286 | finally (return all-errors)))) 287 | 288 | (sub-errors errors 289 | "~a isn't valid for any of the given schemas." 290 | data))) 291 | 292 | 293 | (defvfun const const 294 | (condition (utils:json-equal-p data const) 295 | "~a is not equal to constant ~a." 296 | data const)) 297 | 298 | 299 | (defvfun contains contains 300 | (require-type "array") 301 | 302 | (condition (some (lambda (data) (not (validate contains data))) data) 303 | "~a does not contain ~a." 304 | data contains)) 305 | 306 | 307 | (defvfun description description 308 | (condition (stringp description) 309 | "Description must be a string.")) 310 | 311 | 312 | 313 | (defvfun dependencies dependencies 314 | (require-type "object") 315 | 316 | (let ((failed-dependencies (check-dependencies "dependencies" dependencies data))) 317 | 318 | (sub-errors failed-dependencies 319 | "There were failed dependencies."))) 320 | 321 | 322 | (defvfun dependent-required dependencies 323 | (require-type "object") 324 | 325 | (let ((failed-dependencies (check-dependencies "dependentRequired" dependencies data :allow-objects nil))) 326 | 327 | (sub-errors failed-dependencies 328 | "There were failed dependencies."))) 329 | 330 | 331 | (defvfun dependent-schemas schemas 332 | (require-type "object") 333 | 334 | (let ((failed-dependencies (check-dependencies "dependentSchemas" schemas data :allow-arrays nil))) 335 | 336 | (sub-errors failed-dependencies 337 | "There were failed dependencies."))) 338 | 339 | (defvfun enum members 340 | (condition (member data members :test #'utils:json-equal-p) 341 | "~a isn't one of ~{~a~^, ~}." 342 | data members)) 343 | 344 | 345 | (defvfun exclusive-maximum maximum 346 | (require-type "number") 347 | 348 | (condition (not (>= data maximum)) 349 | "~d must be strictly less than ~a." 350 | data maximum)) 351 | 352 | 353 | (defvfun exclusive-minimum minimum 354 | (require-type "number") 355 | 356 | (condition (not (<= data minimum)) 357 | "~d must be strictly more than ~a." 358 | data minimum)) 359 | 360 | (defvfun format-validator type 361 | (require-type "string") 362 | 363 | (flet ((validate () 364 | (ecase *schema-version* 365 | (:draft2019-09 (formats:draft2019-09 data type)) 366 | (:draft7 (formats:draft7 data type)) 367 | (:draft6 (formats:draft6 data type)) 368 | (:draft4 (formats:draft4 data type)) 369 | (:draft3 (formats:draft3 data type))))) 370 | 371 | (condition (validate) 372 | "~a is not of format ~a." 373 | data type))) 374 | 375 | 376 | (defvfun if-validator condition-schema 377 | (if (null (validate condition-schema data)) 378 | (when-let ((then-schema (utils:object-get "then" schema))) 379 | (sub-errors (validate then-schema data) 380 | "Errors occurred validating then clause.")) 381 | (when-let ((else-schema (utils:object-get "else" schema))) 382 | (sub-errors (validate else-schema data) 383 | "Errors occurred validating else clause.")))) 384 | 385 | 386 | (defvfun items items 387 | (require-type "array") 388 | 389 | (if (typep items 'utils:json-array) 390 | ;; There are schemas in the items property 391 | (sub-errors (loop for sub-schema in items 392 | for item in data 393 | appending (validate sub-schema item)) 394 | "Errors occurred validating items of an array.") 395 | ;; There is one schema for every item in the array 396 | (sub-errors (loop for item in data 397 | appending (validate items item)) 398 | "Errors occurred validating items against ~/json-schema.utils:json-pretty-printer/." 399 | items))) 400 | 401 | 402 | (defvfun type-validator type 403 | (condition (typep type '(or utils:json-array string)) 404 | "~S is an invalid type specifier." 405 | type) 406 | (condition (validate-type nil type data) 407 | "Value ~a is not of type ~S." 408 | data type)) 409 | 410 | 411 | (defvfun maximum maximum 412 | (require-type "number") 413 | 414 | (condition (<= data maximum) 415 | "~d must be less than or equal to ~d" 416 | data maximum)) 417 | 418 | 419 | (defvfun maximum-draft4 maximum 420 | (require-type "number") 421 | 422 | (let ((exclusive-p (eq :true (utils:object-get "exclusiveMaximum" schema :false)))) 423 | (if exclusive-p 424 | (condition (< data maximum) 425 | "~d must be strictly less than ~d." 426 | data maximum) 427 | (condition (<= data maximum) 428 | "~d must be less than or equal to ~d." 429 | data maximum)))) 430 | 431 | 432 | (defvfun max-length length 433 | (require-type "string") 434 | 435 | (condition (>= length (length data)) 436 | "String ~S must be at most ~d characters long." 437 | data length)) 438 | 439 | 440 | (defvfun max-items length 441 | (require-type "array") 442 | 443 | (condition (>= length (length data)) 444 | "Array ~/json-schema.utils:json-pretty-printer/ must be at most ~d items long." 445 | data 446 | length)) 447 | 448 | 449 | (defvfun minimum minimum 450 | (require-type "number") 451 | 452 | (condition (>= data minimum) 453 | "~d must be greater than or equal to ~d." 454 | data minimum)) 455 | 456 | 457 | (defvfun minimum-draft4 minimum 458 | (require-type "number") 459 | 460 | (let ((exclusive-p (eq :true (utils:object-get "exclusiveMaximum" schema :false)))) 461 | (if exclusive-p 462 | (condition (> data minimum) 463 | "~d must be strictly greater than ~d." 464 | data minimum) 465 | (condition (>= data minimum) 466 | "~d must be greater than or equal to ~d." 467 | data minimum)))) 468 | 469 | 470 | (defvfun min-items length 471 | (require-type "array") 472 | 473 | (condition (<= length (length data)) 474 | "Array ~a must be at least ~d items long." 475 | data length)) 476 | 477 | (defvfun min-length length 478 | (require-type "string") 479 | 480 | (condition (<= length (length data)) 481 | "String ~S must be at least ~d characters long." 482 | data length)) 483 | 484 | 485 | (defvfun min-properties count 486 | (require-type "object") 487 | 488 | (condition (>= (length (utils:object-keys data)) count) 489 | "~a must have at least ~d properties." 490 | data count)) 491 | 492 | 493 | (defvfun max-properties count 494 | (require-type "object") 495 | 496 | (condition (<= (length (utils:object-keys data)) count) 497 | "~a must have at most ~d properties." 498 | data count)) 499 | 500 | 501 | (defvfun multiple-of divisor 502 | (require-type "number") 503 | 504 | (when (zerop divisor) 505 | (return-from multiple-of)) 506 | 507 | (etypecase divisor 508 | (integer 509 | (condition (zerop (mod (the number data) divisor)) 510 | "~d is not a multiple of ~d." 511 | data divisor)) 512 | 513 | (real 514 | (condition (= (truncate data divisor) (/ data divisor)) 515 | "~d is not a multiple of ~d." 516 | data divisor)))) 517 | 518 | 519 | (defvfun not-validator sub-schema 520 | (condition (not (null (validate sub-schema data))) 521 | "~a should not be valid under ~/json-schema.utils:json-pretty-printer/." 522 | data sub-schema)) 523 | 524 | 525 | (defvfun one-of sub-schemas 526 | (let ((errors-for-schema (loop for sub-schema in sub-schemas 527 | collecting (validate sub-schema data)))) 528 | 529 | (sub-errors (unless (some #'null errors-for-schema) 530 | errors-for-schema) 531 | "~a was not valid under any given schema." 532 | (if (hash-table-p data) 533 | (format nil "{~{~a~^,~}}" 534 | (loop for k being the hash-keys of data 535 | for n below 10 536 | collect k)) 537 | data)) 538 | 539 | (condition (= 1 (length (remove-if-not #'null errors-for-schema))) 540 | "~a was valid for more than one given schema." 541 | data))) 542 | 543 | 544 | (defvfun pattern-properties patterns 545 | (require-type "object") 546 | 547 | (flet ((test-key (key) 548 | (loop with property-data = (utils:object-get key data) 549 | for pattern-property in (utils:object-keys patterns) 550 | for property-schema = (utils:object-get pattern-property patterns) 551 | 552 | when (ppcre:scan pattern-property key) 553 | appending (handler-case (validate property-schema property-data) 554 | (validation-failed-error (error) 555 | error))))) 556 | 557 | (let ((errors (loop for data-property in (utils:object-keys data) 558 | appending (test-key data-property)))) 559 | 560 | (sub-errors errors 561 | "got errors validating properties")))) 562 | 563 | 564 | (defvfun properties properties 565 | (require-type "object") 566 | 567 | (let ((errors (loop for property in (utils:object-keys properties) 568 | for property-schema = (utils:object-get property properties) 569 | for (property-data found-p) = (multiple-value-list (utils:object-get property data)) 570 | 571 | when found-p 572 | appending (validate property-schema property-data)))) 573 | 574 | (sub-errors errors 575 | "got errors validating properties"))) 576 | 577 | 578 | (defvfun property-names names-schema 579 | (require-type "object") 580 | 581 | (sub-errors (loop for property in (utils:object-keys data) 582 | appending (validate names-schema property)) 583 | "Errors validating propertyNames.")) 584 | 585 | 586 | (defvfun pattern pattern 587 | (require-type "string") 588 | 589 | (condition (ppcre:scan pattern data) 590 | "~S didn't match pattern ~S" 591 | data pattern)) 592 | 593 | 594 | (defvfun required required-fields 595 | (require-type "object") 596 | 597 | (let ((missing-keys (set-difference required-fields 598 | (utils:object-keys data) 599 | :test #'string=))) 600 | 601 | (condition (null missing-keys) 602 | "Object is missing the required keys: ~{~a~^, ~}" 603 | missing-keys))) 604 | 605 | 606 | (defvfun unevaluated-properties unevaluated-properties 607 | (require-type "object") 608 | 609 | (let ((unevaluated-property-names 610 | (set-difference (utils:object-keys data) 611 | (utils:object-keys (utils:object-get "properties" schema (utils:make-empty-object))) 612 | :test 'equal))) 613 | 614 | (cond 615 | ((eq unevaluated-properties :false) 616 | (condition (null unevaluated-property-names) 617 | "No unevaluated properties allowed, but found ~S." 618 | unevaluated-property-names)) 619 | 620 | ((typep unevaluated-properties 'utils:object) 621 | (let ((errors (loop for property in unevaluated-property-names 622 | for (property-data found-p) = (multiple-value-list (utils:object-get property data)) 623 | 624 | when found-p 625 | appending (validate unevaluated-properties 626 | property-data)))) 627 | 628 | (sub-errors errors 629 | "Unevaluated property error.")))))) 630 | 631 | 632 | (defvfun unique-items unique 633 | (require-type "array") 634 | 635 | (when (eq unique :true) 636 | (condition (= (length data) 637 | (length (remove-duplicates data :test 'utils:json-equal-p))) 638 | "Not all items in ~{~a~^, ~} are unique." 639 | data))) 640 | 641 | 642 | ;;; Validators for properties in different drafts of jsonschema 643 | 644 | 645 | (defmacro def-validator (name &rest keys-plist) 646 | `(defun ,name (schema field value data) 647 | (alexandria:switch (field :test #'string-equal) 648 | ,@(loop for (field function) on keys-plist by #'cddr 649 | for error = (handler-case `(,field (,function schema value data)) 650 | (validation-failed-error (error) 651 | error)) 652 | when error 653 | collecting error) 654 | (otherwise (signal 'no-validator-condition :field-name field))))) 655 | 656 | 657 | (def-validator draft2019-09 658 | "$anchor" noop 659 | "$defs" noop 660 | "$ref" $ref 661 | "additionalItems" additional-items 662 | "additionalProperties" additional-properties 663 | "allOf" all-of 664 | "anyOf" any-of 665 | "const" const 666 | "contains" contains 667 | "dependentRequired" dependent-required 668 | "dependentSchemas" dependent-schemas 669 | "else" noop 670 | "enum" enum 671 | "exclusiveMaximum" exclusive-maximum 672 | "exclusiveMinimum" exclusive-minimum 673 | "format" format-validator 674 | "if" if-validator 675 | "items" items 676 | "maximum" maximum 677 | "maxItems" max-items 678 | "maxLength" max-length 679 | "maxProperties" max-properties 680 | "minimum" minimum 681 | "minItems" min-items 682 | "minLength" min-length 683 | "minProperties" min-properties 684 | "multipleOf" multiple-of 685 | "not" not-validator 686 | "oneOf" one-of 687 | "patternProperties" pattern-properties 688 | "properties" properties 689 | "propertyNames" property-names 690 | "pattern" pattern 691 | "required" required 692 | "then" noop 693 | "type" type-validator 694 | "unevaluatedProperties" unevaluated-properties 695 | "uniqueItems" unique-items) 696 | 697 | 698 | (def-validator draft7 699 | "$defs" noop 700 | "$id" noop 701 | "$ref" $ref 702 | "$schema" noop 703 | "additionalItems" additional-items 704 | "additionalProperties" additional-properties 705 | "allOf" all-of 706 | "anyOf" any-of 707 | "const" const 708 | "contains" contains 709 | "description" description 710 | "dependencies" dependencies 711 | "else" noop 712 | "enum" enum 713 | "exclusiveMaximum" exclusive-maximum 714 | "exclusiveMinimum" exclusive-minimum 715 | "format" format-validator 716 | "if" if-validator 717 | "items" items 718 | "maximum" maximum 719 | "maxItems" max-items 720 | "maxLength" max-length 721 | "maxProperties" max-properties 722 | "minimum" minimum 723 | "minItems" min-items 724 | "minLength" min-length 725 | "minProperties" min-properties 726 | "multipleOf" multiple-of 727 | "not" not-validator 728 | "oneOf" one-of 729 | "patternProperties" pattern-properties 730 | "properties" properties 731 | "propertyNames" property-names 732 | "pattern" pattern 733 | "required" required 734 | "then" noop 735 | "type" type-validator 736 | "uniqueItems" unique-items) 737 | 738 | 739 | (def-validator draft6 740 | "$id" noop 741 | "$ref" $ref 742 | "$schema" noop 743 | "additionalItems" additional-items 744 | "additionalProperties" additional-properties 745 | "allOf" all-of 746 | "anyOf" any-of 747 | "const" const 748 | "contains" contains 749 | "default" noop 750 | "dependencies" dependencies 751 | "enum" enum 752 | "exclusiveMaximum" exclusive-maximum 753 | "exclusiveMinimum" exclusive-minimum 754 | "format" format-validator 755 | "items" items 756 | "maximum" maximum 757 | "maxItems" max-items 758 | "maxLength" max-length 759 | "maxProperties" max-properties 760 | "minimum" minimum 761 | "minItems" min-items 762 | "minLength" min-length 763 | "minProperties" min-properties 764 | "multipleOf" multiple-of 765 | "not" not-validator 766 | "oneOf" one-of 767 | "pattern" pattern 768 | "patternProperties" pattern-properties 769 | "properties" properties 770 | "propertyNames" property-names 771 | "required" required 772 | "type" type-validator 773 | "uniqueItems" unique-items) 774 | 775 | 776 | (def-validator draft4 777 | "id" noop 778 | "$ref" $ref 779 | "$schema" noop 780 | "additionalItems" additional-items 781 | "additionalProperties" additional-properties 782 | "allOf" all-of 783 | "anyOf" any-of 784 | "const" const 785 | "contains" contains 786 | "default" noop 787 | "dependencies" dependencies 788 | "enum" enum 789 | "format" format-validator 790 | "items" items 791 | "maximum" maximum-draft4 792 | "maxItems" max-items 793 | "maxLength" max-length 794 | "maxProperties" max-properties 795 | "minimum" minimum-draft4 796 | "minItems" min-items 797 | "minLength" min-length 798 | "minProperties" min-properties 799 | "multipleOf" multiple-of 800 | "not" not-validator 801 | "oneOf" one-of 802 | "pattern" pattern 803 | "patternProperties" pattern-properties 804 | "properties" properties 805 | "propertyNames" property-names 806 | "required" required 807 | "type" type-validator 808 | "uniqueItems" unique-items) 809 | -------------------------------------------------------------------------------- /t/draft2019-09.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema/test/draft2019-09 2 | (:use :cl :json-schema-test-case-helper)) 3 | 4 | (in-package :json-schema/test/draft2019-09) 5 | 6 | (test-cases-from-file "additionalItems") 7 | 8 | (test-cases-from-file "additionalProperties") 9 | 10 | (test-cases-from-file "allOf") 11 | 12 | (test-cases-from-file "anchor") 13 | 14 | (test-cases-from-file "anyOf") 15 | 16 | (test-cases-from-file "boolean_schema") 17 | 18 | (test-cases-from-file "const") 19 | 20 | (test-cases-from-file "contains") 21 | 22 | (test-cases-from-file "default") 23 | 24 | (test-cases-from-file "defs" 25 | :skip (("invalid definition" . ("invalid definition schema")))) 26 | 27 | (test-cases-from-file "dependentRequired") 28 | 29 | (test-cases-from-file "dependentSchemas") 30 | 31 | (test-cases-from-file "enum") 32 | 33 | (test-cases-from-file "exclusiveMaximum") 34 | 35 | (test-cases-from-file "exclusiveMinimum") 36 | 37 | (test-cases-from-file "format") 38 | 39 | (test-cases-from-file "if-then-else") 40 | 41 | (test-cases-from-file "items") 42 | 43 | (test-cases-from-file "maximum") 44 | 45 | (test-cases-from-file "maxItems") 46 | 47 | (test-cases-from-file "maxLength") 48 | 49 | (test-cases-from-file "maxProperties") 50 | 51 | (test-cases-from-file "minimum") 52 | 53 | (test-cases-from-file "minItems") 54 | 55 | (test-cases-from-file "minLength") 56 | 57 | (test-cases-from-file "minProperties") 58 | 59 | (test-cases-from-file "multipleOf" 60 | :skip (("by number" . ("4.5 is multiple of 1.5")))) 61 | 62 | (test-cases-from-file "not") 63 | 64 | (test-cases-from-file "oneOf") 65 | 66 | (test-cases-from-file "pattern") 67 | 68 | (test-cases-from-file "patternProperties") 69 | 70 | (test-cases-from-file "properties") 71 | 72 | (test-cases-from-file "propertyNames") 73 | 74 | (test-cases-from-file "ref") 75 | 76 | (test-cases-from-file "refRemote" 77 | :skip (("base URI change - change folder" . t))) 78 | 79 | (test-cases-from-file "required") 80 | 81 | (test-cases-from-file "type") 82 | 83 | (test-cases-from-file "unevaluatedItems" 84 | :skip t) 85 | 86 | (test-cases-from-file "unevaluatedProperties" 87 | :skip t) 88 | 89 | (test-cases-from-file "uniqueItems") 90 | 91 | (test-cases-from-file "optional/bignum") 92 | 93 | (test-cases-from-file "optional/format/date") 94 | 95 | (test-cases-from-file "optional/format/date-time") 96 | 97 | (test-cases-from-file "optional/format/duration") 98 | 99 | (test-cases-from-file "optional/format/email") 100 | 101 | (test-cases-from-file "optional/format/hostname") 102 | 103 | (test-cases-from-file "optional/format/idn-email" 104 | :skip t) 105 | 106 | (test-cases-from-file "optional/format/idn-hostname" 107 | :skip t) 108 | 109 | (test-cases-from-file "optional/format/ipv4") 110 | 111 | (test-cases-from-file "optional/format/ipv6") 112 | 113 | (test-cases-from-file "optional/format/iri" 114 | :skip t) 115 | 116 | (test-cases-from-file "optional/format/iri-reference" 117 | :skip t) 118 | 119 | (test-cases-from-file "optional/format/json-pointer") 120 | 121 | (test-cases-from-file "optional/format/regex") 122 | 123 | (test-cases-from-file "optional/format/json-pointer" 124 | :skip t) 125 | 126 | (test-cases-from-file "optional/format/time") 127 | 128 | (test-cases-from-file "optional/format/uri") 129 | 130 | (test-cases-from-file "optional/format/uri-reference") 131 | 132 | (test-cases-from-file "optional/format/uri-template" 133 | :skip t) 134 | -------------------------------------------------------------------------------- /t/draft4.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema/test/draft4 2 | (:use :cl :json-schema-test-case-helper)) 3 | 4 | (in-package :json-schema/test/draft4) 5 | 6 | (test-cases-from-file "additionalItems") 7 | 8 | (test-cases-from-file "additionalProperties") 9 | 10 | (test-cases-from-file "allOf") 11 | 12 | (test-cases-from-file "anyOf") 13 | 14 | (test-cases-from-file "default") 15 | 16 | (test-cases-from-file "definitions") 17 | 18 | (test-cases-from-file "dependencies") 19 | 20 | (test-cases-from-file "enum") 21 | 22 | (test-cases-from-file "format") 23 | 24 | (test-cases-from-file "items") 25 | 26 | (test-cases-from-file "maximum") 27 | 28 | (test-cases-from-file "maxItems") 29 | 30 | (test-cases-from-file "maxLength") 31 | 32 | (test-cases-from-file "maxProperties") 33 | 34 | (test-cases-from-file "minimum" 35 | :skip (("exclusiveMinimum validation" . ("boundary point is invalid")))) 36 | 37 | (test-cases-from-file "minItems") 38 | 39 | (test-cases-from-file "minLength") 40 | 41 | (test-cases-from-file "minProperties") 42 | 43 | (test-cases-from-file "multipleOf" 44 | :skip (("by number" . ("4.5 is multiple of 1.5")))) 45 | 46 | (test-cases-from-file "not") 47 | 48 | (test-cases-from-file "oneOf") 49 | 50 | (test-cases-from-file "pattern") 51 | 52 | (test-cases-from-file "patternProperties") 53 | 54 | (test-cases-from-file "properties") 55 | 56 | (test-cases-from-file "ref" 57 | :skip (("ref overrides any sibling keywords" . ("ref valid, maxItems ignored")))) 58 | 59 | (test-cases-from-file "refRemote") 60 | 61 | (test-cases-from-file "required") 62 | 63 | (test-cases-from-file "type") 64 | 65 | (test-cases-from-file "uniqueItems") 66 | 67 | (test-cases-from-file "optional/format/date-time") 68 | 69 | (test-cases-from-file "optional/format/email") 70 | 71 | (test-cases-from-file "optional/format/hostname") 72 | 73 | (test-cases-from-file "optional/format/ipv4") 74 | 75 | (test-cases-from-file "optional/format/ipv6") 76 | 77 | (test-cases-from-file "optional/format/uri") 78 | -------------------------------------------------------------------------------- /t/draft6.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema/test/draft6 2 | (:use :cl :json-schema-test-case-helper)) 3 | 4 | (in-package :json-schema/test/draft6) 5 | 6 | (test-cases-from-file "additionalItems") 7 | 8 | (test-cases-from-file "additionalProperties") 9 | 10 | (test-cases-from-file "allOf") 11 | 12 | (test-cases-from-file "anyOf") 13 | 14 | (test-cases-from-file "boolean_schema") 15 | 16 | (test-cases-from-file "const") 17 | 18 | (test-cases-from-file "contains") 19 | 20 | (test-cases-from-file "default") 21 | 22 | (test-cases-from-file "definitions") 23 | 24 | (test-cases-from-file "dependencies") 25 | 26 | (test-cases-from-file "enum") 27 | 28 | (test-cases-from-file "exclusiveMaximum") 29 | 30 | (test-cases-from-file "exclusiveMinimum") 31 | 32 | (test-cases-from-file "format") 33 | 34 | (test-cases-from-file "items") 35 | 36 | (test-cases-from-file "maximum") 37 | 38 | (test-cases-from-file "maxItems") 39 | 40 | (test-cases-from-file "maxLength") 41 | 42 | (test-cases-from-file "maxProperties") 43 | 44 | (test-cases-from-file "minimum") 45 | 46 | (test-cases-from-file "minItems") 47 | 48 | (test-cases-from-file "minLength") 49 | 50 | (test-cases-from-file "minProperties") 51 | 52 | (test-cases-from-file "multipleOf" 53 | :skip (("by number" . ("4.5 is multiple of 1.5")))) 54 | 55 | (test-cases-from-file "not") 56 | 57 | (test-cases-from-file "oneOf") 58 | 59 | (test-cases-from-file "pattern") 60 | 61 | (test-cases-from-file "patternProperties") 62 | 63 | (test-cases-from-file "properties") 64 | 65 | (test-cases-from-file "propertyNames") 66 | 67 | (test-cases-from-file "ref" 68 | :skip (("ref overrides any sibling keywords" . ("ref valid, maxItems ignored")))) 69 | 70 | (test-cases-from-file "refRemote") 71 | 72 | (test-cases-from-file "required") 73 | 74 | (test-cases-from-file "type") 75 | 76 | (test-cases-from-file "uniqueItems") 77 | 78 | ;; optional cases 79 | 80 | (test-cases-from-file "optional/bignum") 81 | 82 | (test-cases-from-file "optional/non-bmp-regex") 83 | 84 | (test-cases-from-file "optional/format/date-time" 85 | :skip (("validation of date-time strings" . ("an invalid closing Z after time-zone offset")))) 86 | 87 | (test-cases-from-file "optional/format/email") 88 | 89 | (test-cases-from-file "optional/format/hostname") 90 | 91 | (test-cases-from-file "optional/format/ipv4") 92 | 93 | (test-cases-from-file "optional/format/ipv6") 94 | 95 | (test-cases-from-file "optional/format/json-pointer") 96 | 97 | (test-cases-from-file "optional/format/uri") 98 | 99 | (test-cases-from-file "optional/format/uri-reference") 100 | 101 | (test-cases-from-file "optional/format/uri-template" 102 | :skip t) 103 | -------------------------------------------------------------------------------- /t/draft7.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema/test/draft7 2 | (:use :cl :json-schema-test-case-helper)) 3 | 4 | (in-package :json-schema/test/draft7) 5 | 6 | (test-cases-from-file "additionalItems") 7 | 8 | (test-cases-from-file "additionalProperties") 9 | 10 | (test-cases-from-file "allOf") 11 | 12 | (test-cases-from-file "anyOf") 13 | 14 | (test-cases-from-file "boolean_schema") 15 | 16 | (test-cases-from-file "const") 17 | 18 | (test-cases-from-file "contains") 19 | 20 | (test-cases-from-file "default") 21 | 22 | (test-cases-from-file "definitions") 23 | 24 | (test-cases-from-file "dependencies") 25 | 26 | (test-cases-from-file "enum") 27 | 28 | (test-cases-from-file "exclusiveMaximum") 29 | 30 | (test-cases-from-file "exclusiveMinimum") 31 | 32 | (test-cases-from-file "format") 33 | 34 | (test-cases-from-file "if-then-else") 35 | 36 | (test-cases-from-file "items") 37 | 38 | (test-cases-from-file "maximum") 39 | 40 | (test-cases-from-file "maxItems") 41 | 42 | (test-cases-from-file "maxLength") 43 | 44 | (test-cases-from-file "maxProperties") 45 | 46 | (test-cases-from-file "minimum") 47 | 48 | (test-cases-from-file "minItems") 49 | 50 | (test-cases-from-file "minLength") 51 | 52 | (test-cases-from-file "minProperties") 53 | 54 | (test-cases-from-file "multipleOf" 55 | :skip (("by number" . ("4.5 is multiple of 1.5")))) 56 | 57 | (test-cases-from-file "not") 58 | 59 | (test-cases-from-file "oneOf") 60 | 61 | (test-cases-from-file "pattern") 62 | 63 | (test-cases-from-file "patternProperties") 64 | 65 | (test-cases-from-file "properties") 66 | 67 | (test-cases-from-file "propertyNames") 68 | 69 | (test-cases-from-file "ref" 70 | :skip (("ref overrides any sibling keywords" . ("ref valid, maxItems ignored")))) 71 | 72 | (test-cases-from-file "refRemote") 73 | 74 | (test-cases-from-file "required") 75 | 76 | (test-cases-from-file "type") 77 | 78 | (test-cases-from-file "uniqueItems") 79 | 80 | ;; optional tests 81 | 82 | (test-cases-from-file "optional/bignum") 83 | 84 | (test-cases-from-file "optional/format/date") 85 | 86 | (test-cases-from-file "optional/format/date-time") 87 | 88 | (test-cases-from-file "optional/format/email") 89 | 90 | (test-cases-from-file "optional/format/hostname") 91 | 92 | (test-cases-from-file "optional/format/idn-email" 93 | :skip t) 94 | 95 | (test-cases-from-file "optional/format/idn-hostname" 96 | :skip t) 97 | 98 | (test-cases-from-file "optional/format/ipv4") 99 | 100 | (test-cases-from-file "optional/format/ipv6") 101 | 102 | (test-cases-from-file "optional/format/iri" 103 | :skip t) 104 | 105 | (test-cases-from-file "optional/format/iri-reference" 106 | :skip t) 107 | 108 | (test-cases-from-file "optional/format/json-pointer") 109 | 110 | (test-cases-from-file "optional/format/regex") 111 | 112 | (test-cases-from-file "optional/format/json-pointer" 113 | :skip t) 114 | 115 | (test-cases-from-file "optional/format/time") 116 | 117 | (test-cases-from-file "optional/format/uri") 118 | 119 | (test-cases-from-file "optional/format/uri-reference") 120 | 121 | (test-cases-from-file "optional/format/uri-template" 122 | :skip t) 123 | -------------------------------------------------------------------------------- /t/jso-printer.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema/test.jso-printer 2 | (:local-nicknames (:json :st-json)) 3 | (:use :cl)) 4 | 5 | (in-package :json-schema/test.jso-printer) 6 | 7 | 8 | (defmethod print-object ((object json:jso) stream) 9 | (format stream "#jso(~a)" (json:write-json-to-string object))) 10 | -------------------------------------------------------------------------------- /t/json-schema-test-case-helper.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema-test-case-helper 2 | (:use :cl :alexandria :arrows :rove) 3 | (:local-nicknames (:utils :json-schema.utils)) 4 | (:export #:test-cases-from-file)) 5 | 6 | (in-package :json-schema-test-case-helper) 7 | 8 | (defvar *skips* nil 9 | "For keeping track of tests to skip.") 10 | 11 | 12 | (defun data-of (spec) 13 | (utils:object-get "data" spec)) 14 | 15 | 16 | (defun valid-p (spec) 17 | (eq (utils:object-get "valid" spec) :true)) 18 | 19 | 20 | (defun description-of (spec) 21 | (utils:object-get "description" spec)) 22 | 23 | 24 | (defun schema-of (spec) 25 | (utils:object-get "schema" spec)) 26 | 27 | 28 | (defun test-cases-of (spec) 29 | (utils:object-get "tests" spec)) 30 | 31 | 32 | (defun unhash (data) 33 | (typecase data 34 | (utils:object 35 | `(json-schema.parse:parse ,(st-json:write-json-to-string data))) 36 | 37 | (list 38 | `(list ,@(mapcar #'unhash data))) 39 | 40 | (t 41 | data))) 42 | 43 | 44 | (defun spec-to-deftest (spec) 45 | (with-gensyms (schema-gensym) 46 | (let ((assertions (mapcar (curry 'test-case-to-assertion spec schema-gensym) 47 | (test-cases-of spec)))) 48 | `(testing ,(description-of spec) 49 | ;; If every test case is a skip, don't define the test 50 | ;; data since we won't use it, anyway. 51 | ,(if (every (lambda (a) (eq (car a) 'skip)) assertions) 52 | `(progn ,@assertions) 53 | `(let ((,schema-gensym ,(unhash (schema-of spec)))) 54 | ,@assertions)))))) 55 | 56 | 57 | (defmacro test-cases-from-file (name &key skip) 58 | (let* ((*skips* skip) 59 | (version-from-package (->> *package* 60 | package-name 61 | (str:split #\/) 62 | third 63 | string-downcase)) 64 | (pathname-directory (list :relative "JSON-Schema-Test-Suite" "tests" version-from-package)) 65 | (test-spec-pathname (asdf:system-relative-pathname :json-schema 66 | (merge-pathnames (pathname name) 67 | (make-pathname :directory pathname-directory 68 | :type "json"))))) 69 | 70 | `(deftest ,(intern (format nil "TEST-~:@(~a~)" name) *package*) 71 | (let ((json-schema:*schema-version* ,(make-keyword (string-upcase version-from-package)))) 72 | ,@(mapcar #'spec-to-deftest 73 | (json-schema.parse:parse test-spec-pathname)))))) 74 | 75 | 76 | (defun check-test-skip (suite-spec assertion-spec) 77 | (flet ((aget (key alist &optional default) 78 | (or (cdr (assoc key alist :test #'string=)) 79 | default))) 80 | 81 | (when *skips* 82 | (or (eq *skips* t) ;; skip all 83 | (let ((group-skips (aget (description-of suite-spec) *skips*))) 84 | (or (eq group-skips t) 85 | (find (description-of assertion-spec) group-skips 86 | :test #'string=))))))) 87 | 88 | 89 | (defun test-case-to-assertion (suite-spec schema-gensym assertion-spec) 90 | (if (check-test-skip suite-spec assertion-spec) 91 | `(skip ,(description-of assertion-spec)) 92 | 93 | `(,(if (valid-p assertion-spec) 'ok 'ng) 94 | (json-schema:validate ,(unhash (data-of assertion-spec)) 95 | :schema ,schema-gensym) 96 | ,(description-of assertion-spec)))) 97 | -------------------------------------------------------------------------------- /t/json-schema.lisp: -------------------------------------------------------------------------------- 1 | (defpackage json-schema/test 2 | (:use :cl :rove)) 3 | 4 | (in-package :json-schema/test) 5 | 6 | (deftest test-json-schema 7 | (ok (eq 1 1) "testing works")) 8 | -------------------------------------------------------------------------------- /t/reference.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema/test.reference 2 | (:local-nicknames (:put :json-schema.reference) 3 | (:utils :json-schema.utils) 4 | (:parse :json-schema.parse)) 5 | (:use :cl :rove)) 6 | 7 | (in-package :json-schema/test.reference) 8 | 9 | (defmacro with-context ((&key uri-stack references named-references (schema-version :draft7)) &body body) 10 | (let ((references (or references (make-hash-table :test 'equal))) 11 | (named-references (or named-references (make-hash-table :test 'equal)))) 12 | `(let ((json-schema.reference::*context* (json-schema.reference::%make-context 13 | :uri-stack ,uri-stack 14 | :references ,references 15 | :named-references ,named-references 16 | :schema-version ,schema-version 17 | :root-schema (make-hash-table :test 'equal)))) 18 | ,@body))) 19 | 20 | 21 | (deftest test-unescape 22 | (ok (string= (put::unescape "#/my-name") "#/my-name")) 23 | 24 | (ok (string= (put::unescape "my~1name") "my/name")) 25 | 26 | (ok (string= (put::unescape "my~1name~0") "my/name~"))) 27 | 28 | 29 | (deftest make-reference 30 | (with-context (:uri-stack '("")) 31 | (let ((relative-reference (put::make-reference "#/something/2/3/another")) 32 | (absolute-only-reference (put::make-reference "https://example.com/potato-schema.json")) 33 | (another-reference (put::make-reference "https://example.com/potato-schema.json#/somewhere/in/the/document"))) 34 | 35 | (testing "a relative reference" 36 | (ok (string= "" 37 | (put::uri-of relative-reference)) 38 | "has no uri.") 39 | (ok (= (length (put::relative-path-of relative-reference)) 4) 40 | "has a list of components for a relative path.") 41 | 42 | (let ((parts (put::relative-path-of relative-reference))) 43 | (ok (and (stringp (first parts)) 44 | (integerp (second parts)) 45 | (integerp (third parts)) 46 | (stringp (fourth parts))) 47 | "the relativite path components are strings or integers."))) 48 | 49 | (testing "an absolute reference" 50 | (ok (string= "https://example.com/potato-schema.json" 51 | (put::uri-of absolute-only-reference)) 52 | "has a uri.") 53 | (ok (null (put::relative-path-of absolute-only-reference)) 54 | "has a an empty list of components for a relative path.")) 55 | 56 | (testing "a reference with both components" 57 | (ok (string= "https://example.com/potato-schema.json" 58 | (put::uri-of another-reference)) 59 | "has a uri.") 60 | (ok (= (length (put::relative-path-of relative-reference)) 4) 61 | "has a list of components for a relative path.")))) 62 | 63 | ;; https://github.com/fisxoj/json-schema/pull/16 64 | (testing "a reference inside a referenced document" 65 | (with-context (:uri-stack '("https://somewhere.com/schemas/department.json")) 66 | (ok (string= (put::uri-of (put::make-reference "employee.json")) 67 | "https://somewhere.com/schemas/employee.json") 68 | "inherits the relative path of the document.")))) 69 | 70 | 71 | (deftest test-escape 72 | (ok (string= (put::escape "my~cool~name") "my~0cool~0name"))) 73 | 74 | 75 | (deftest test-context 76 | (testing "an uncomplicated context" 77 | (let ((simple-ref (parse:parse 78 | "{\"components\": {\"key\": 4, \"another\": {\"$ref\": \"#/components/key\"}}}"))) 79 | (put:with-context ((put:make-context simple-ref :draft7)) 80 | (let ((resolved (put::resolve (utils:object-get "another" (utils:object-get "components" simple-ref))))) 81 | (ok (not (null resolved)) 82 | "can resolve a reference.") 83 | 84 | (ok (= resolved 4) 85 | "can resolve a simple relative reference to the correct value."))))) 86 | 87 | (testing "with an encoded path component" 88 | (let ((simple-ref (parse:parse 89 | "{\"components\": {\"~key\": 4, \"another\": {\"$ref\": \"#/components/~0key\"}}}"))) 90 | (put:with-context ((put:make-context simple-ref :draft7)) 91 | (let ((resolved (put::resolve (utils:object-get "another" (utils:object-get "components" simple-ref))))) 92 | (ok (not (null resolved)) 93 | "can resolve a reference.") 94 | 95 | (ok (= resolved 4) 96 | "can resolve a simple relative reference to the correct value."))))) 97 | 98 | (testing "encoded ref names" 99 | (let ((document (parse:parse "{\"$defs\": { 100 | \"tilda~field\": {\"type\": \"integer\"}, 101 | \"slash/field\": {\"type\": \"integer\"}, 102 | \"percent%field\": {\"type\": \"integer\"} 103 | }, 104 | \"properties\": { 105 | \"tilda\": {\"$ref\": \"#/$defs/tilda~0field\"}, 106 | \"slash\": {\"$ref\": \"#/$defs/slash~1field\"}, 107 | \"percent\": {\"$ref\": \"#/$defs/percent%25field\"}}}"))) 108 | (put:with-context ((put:make-context document :draft7)) 109 | (ok (string= (utils:object-get "type" 110 | (put:resolve (utils:object-get "slash" (utils:object-get "properties" document)))) 111 | "integer") 112 | "can fetch a ref with an encoded slash in it.") 113 | 114 | (ok (string= (utils:object-get "type" 115 | (put:resolve (utils:object-get "tilda" (utils:object-get "properties" document)))) 116 | "integer") 117 | "can fetch a ref with an encoded tilda in it.") 118 | 119 | (ok (string= (utils:object-get "type" 120 | (put:resolve (utils:object-get "percent" (utils:object-get "properties" document)))) 121 | "integer") 122 | "can fetch a ref with an encoded percent sign in it."))))) 123 | -------------------------------------------------------------------------------- /t/utils.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :json-schema/test.utils 2 | (:local-nicknames (:put :json-schema.utils) 3 | (:parse :json-schema.parse)) 4 | (:use :cl :rove)) 5 | 6 | (in-package :json-schema/test.utils) 7 | 8 | 9 | (deftest object-equal-p 10 | (testing "simple objects" 11 | (let ((object1 (parse:parse "{\"a\":1, \"b\":[\"r\",\"m\",\"p\"]}")) 12 | (object2 (parse:parse "{\"a\":1, \"b\":[\"r\",\"m\",\"p\"]}")) 13 | (object3 (parse:parse "{\"a\":2, \"b\":[\"r\",\"m\",\"q\"]}")) 14 | (object4 (parse:parse "{\"a\":1, \"b\":[\"r\",\"m\",\"q\"]}")) 15 | (object5 (parse:parse "{\"a\":1, \"b\":[\"r\",\"m\",\"p\"],\"c\":false}"))) 16 | 17 | (ok (put:object-equal-p object1 object2) 18 | "two equal objects are equal.") 19 | 20 | (ng (put:object-equal-p object1 object3) 21 | "an object with a different value for a key is not the same.") 22 | 23 | (ng (put:object-equal-p object1 object4) 24 | "an object with a different value in an array is not the same.") 25 | 26 | (ng (put:object-equal-p object1 object5) 27 | "an object with an additional field that is otherwise the same is not the same.")))) 28 | --------------------------------------------------------------------------------