├── .gitignore ├── .merlin ├── .ocp-indent ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── ocplib-resto.install ├── ocplib-resto.opam └── src ├── META ├── build.ocp ├── ezResto.ml ├── ezResto.mli ├── ezRestoDirectory.ml ├── ezRestoDirectory.mli ├── ezResto_test.ml ├── resto.ml ├── resto.mli ├── restoDirectory.ml ├── restoDirectory.mli └── resto_test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *~ 3 | _obuild 4 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S src/* 2 | B _obuild/* 3 | PKG lwt 4 | PKG ocplib-json-typed 5 | PKG result 6 | FLG -open Result 7 | FLG -w -40 8 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause = 4 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | services: 4 | - docker 5 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 6 | script: bash ./.travis-docker.sh 7 | env: 8 | global: 9 | - PACKAGE="ocplib-resto" 10 | matrix: 11 | - DISTRO=debian-stable OCAML_VERSION=4.03.0 12 | - DISTRO=debian-stable OCAML_VERSION=4.02.3 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | In the following, "ocplib-resto" refers to all files marked 2 | "Copyright OCamlPro" in this distribution. 3 | 4 | ocplib-resto is distributed under the terms of the 5 | GNU Lesser General Public License (LGPL) version 2.1 (included below). 6 | 7 | As a special exception to the GNU Lesser General Public License, you 8 | may link, statically or dynamically, a "work that uses ocplib-resto" 9 | with a publicly distributed version of ocplib-resto to produce an 10 | executable file containing portions of ocplib-resto, and distribute 11 | that executable file under terms of your choice, without any of the 12 | additional requirements listed in clause 6 of the GNU Lesser General 13 | Public License. By "a publicly distributed version of ocplib-resto", 14 | we mean either the unmodified ocplib-resto as distributed by OCamlPro, 15 | or a modified version of ocplib-resto that is distributed under the 16 | conditions defined in clause 2 of the GNU Lesser General Public 17 | License. This exception does not however invalidate any other reasons 18 | why the executable file might be covered by the GNU Lesser General 19 | Public License. 20 | 21 | ---------------------------------------------------------------------- 22 | 23 | GNU LESSER GENERAL PUBLIC LICENSE 24 | 25 | Version 2.1, February 1999 26 | 27 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 28 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 29 | Everyone is permitted to copy and distribute verbatim copies 30 | of this license document, but changing it is not allowed. 31 | 32 | [This is the first released version of the Lesser GPL. It also counts 33 | as the successor of the GNU Library Public License, version 2, hence 34 | the version number 2.1.] 35 | 36 | Preamble 37 | 38 | The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. 39 | 40 | This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. 41 | 42 | When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. 43 | 44 | To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. 45 | 46 | For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling 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 library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. 49 | 50 | To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. 51 | 52 | Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. 53 | 54 | Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. 55 | 56 | When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. 57 | 58 | We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. 59 | 60 | For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. 61 | 62 | In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. 63 | 64 | Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. 65 | 66 | The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. 67 | 68 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 69 | 70 | 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". 71 | 72 | A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. 73 | 74 | The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) 75 | 76 | "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. 77 | 78 | Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 79 | 80 | 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. 81 | 82 | You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 83 | 84 | 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: 85 | 86 | a) The modified work must itself be a software library. 87 | b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. 88 | c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. 89 | d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. 90 | 91 | (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) 92 | 93 | These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. 94 | 95 | Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. 96 | 97 | In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 98 | 99 | 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. 100 | 101 | Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. 102 | 103 | This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 104 | 105 | 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. 106 | 107 | If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 108 | 109 | 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. 110 | 111 | However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. 112 | 113 | When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. 114 | 115 | If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) 116 | 117 | Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 118 | 119 | 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. 120 | 121 | You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: 122 | 123 | a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) 124 | b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. 125 | c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. 126 | d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. 127 | e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. 128 | 129 | For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. 130 | 131 | It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 132 | 133 | 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: 134 | 135 | a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. 136 | b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 137 | 138 | 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 139 | 140 | 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 141 | 142 | 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 143 | 144 | 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. 145 | 146 | If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. 147 | 148 | It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. 149 | 150 | This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 151 | 152 | 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 153 | 154 | 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. 155 | 156 | Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 157 | 158 | 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. 159 | 160 | NO WARRANTY 161 | 162 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 163 | 164 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 165 | END OF TERMS AND CONDITIONS 166 | 167 | How to Apply These Terms to Your New Libraries 168 | 169 | If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). 170 | 171 | To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. 172 | 173 | one line to give the library's name and an idea of what it does. 174 | Copyright (C) year name of author 175 | 176 | This library is free software; you can redistribute it and/or 177 | modify it under the terms of the GNU Lesser General Public 178 | License as published by the Free Software Foundation; either 179 | version 2.1 of the License, or (at your option) any later version. 180 | 181 | This library is distributed in the hope that it will be useful, 182 | but WITHOUT ANY WARRANTY; without even the implied warranty of 183 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 184 | Lesser General Public License for more details. 185 | 186 | You should have received a copy of the GNU Lesser General Public 187 | License along with this library; if not, write to the Free Software 188 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 189 | 190 | Also add information on how to contact you by electronic and paper mail. 191 | 192 | You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: 193 | 194 | Yoyodyne, Inc., hereby disclaims all copyright interest in 195 | the library `Frob' (a library for tweaking knobs) written 196 | by James Random Hacker. 197 | 198 | signature of Ty Coon, 1 April 1990 199 | Ty Coon, President of Vice 200 | 201 | That's all there is to it! 202 | 203 | -------------------------------------------------- 204 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: 3 | ocp-build init 4 | ocp-build build ocplib-resto ocplib-resto-directory 5 | 6 | test: 7 | ocp-build init 8 | ocp-build build test 9 | ./_obuild/test/test.byte 10 | 11 | clean: 12 | [ ! -d _obuild ] || ocp-build clean 13 | 14 | distclean: 15 | -rm -rf _obuild 16 | -rm -rf */*~ *~ 17 | 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ocplib-resto (WIP) 2 | 3 | This is a minimal OCaml library for type-safe HTTP/JSON RPCs. 4 | 5 | This is based on a notion of service, *à la* Eliom, and it uses 6 | `ocplib-json-typed` for self-documenting JSON encoders. 7 | 8 | See `src/ezResto_test.ml` or `src/reste_test.ml` for example.` -------------------------------------------------------------------------------- /ocplib-resto.install: -------------------------------------------------------------------------------- 1 | lib: [ 2 | 3 | "src/META" 4 | 5 | "src/resto.mli" 6 | "src/resto.ml" 7 | "_obuild/ocplib-resto/resto.cmi" 8 | "_obuild/ocplib-resto/resto.cmx" 9 | "?_obuild/ocplib-resto/resto.cmti" 10 | "?_obuild/ocplib-resto/resto.cmt" 11 | 12 | "src/ezResto.mli" 13 | "src/ezResto.ml" 14 | "_obuild/ocplib-resto/ezResto.cmi" 15 | "_obuild/ocplib-resto/ezResto.cmx" 16 | "?_obuild/ocplib-resto/ezResto.cmti" 17 | "?_obuild/ocplib-resto/ezResto.cmt" 18 | 19 | "_obuild/ocplib-resto/ocplib-resto.cma" 20 | "?_obuild/ocplib-resto/ocplib-resto.cmxa" 21 | "?_obuild/ocplib-resto/ocplib-resto.cmxs" 22 | "?_obuild/ocplib-resto/ocplib-resto.a" 23 | 24 | "src/restoDirectory.mli" { "directory/restoDirectory.mli" } 25 | "src/restoDirectory.ml" { "directory/restoDirectory.ml" } 26 | "_obuild/ocplib-resto-directory/restoDirectory.cmi" 27 | { "directory/restoDirectory.cmi" } 28 | "_obuild/ocplib-resto-directory/restoDirectory.cmx" 29 | { "directory/restoDirectory.cmx" } 30 | "?_obuild/ocplib-resto-directory/restoDirectory.cmti" 31 | { "directory/restoDirectory.cmti" } 32 | "?_obuild/ocplib-resto-directory/restoDirectory.cmt" 33 | { "directory/restoDirectory.cmt" } 34 | 35 | "src/ezRestoDirectory.mli" 36 | { "directory/ezRestoDirectory.mli" } 37 | "src/ezRestoDirectory.ml" 38 | { "directory/ezRestoDirectory.ml" } 39 | "_obuild/ocplib-resto-directory/ezRestoDirectory.cmi" 40 | { "directory/ezRestoDirectory.cmi" } 41 | "_obuild/ocplib-resto-directory/ezRestoDirectory.cmx" 42 | { "directory/ezRestoDirectory.cmx" } 43 | "?_obuild/ocplib-resto-directory/ezRestoDirectory.cmti" 44 | { "directory/ezRestoDirectory.cmti" } 45 | "?_obuild/ocplib-resto-directory/ezRestoDirectory.cmt" 46 | { "directory/ezRestoDirectory.cmt" } 47 | 48 | "_obuild/ocplib-resto-directory/ocplib-resto-directory.cma" 49 | { "directory/ocplib-resto-directory.cma" } 50 | "?_obuild/ocplib-resto-directory/ocplib-resto-directory.cmxa" 51 | { "directory/ocplib-resto-directory.cmxa" } 52 | "?_obuild/ocplib-resto-directory/ocplib-resto-directory.cmxs" 53 | { "directory/ocplib-resto-directory.cmxs" } 54 | "?_obuild/ocplib-resto-directory/ocplib-resto-directory.a" 55 | { "directory/ocplib-resto-directory.a" } 56 | 57 | ] -------------------------------------------------------------------------------- /ocplib-resto.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "ocplib-resto" 3 | version: "dev" 4 | maintainer: "Grégoire Henry " 5 | authors: "Grégoire Henry " 6 | license: "LGPL-2.1-with-OCaml-exception" 7 | homepage: "https://github.com/OCamlPro/ocplib-resto" 8 | bug-reports: "https://github.com/OCamlPro/ocplib-resto/issues" 9 | depends: [ 10 | "ocamlfind" {build} 11 | "ocp-build" {build} 12 | "result" 13 | "lwt" 14 | "ocplib-json-typed" { >= "0.4" } 15 | ] 16 | build: [make] 17 | dev-repo: "git+https://github.com/OCamlPro/ocplib-resto" 18 | -------------------------------------------------------------------------------- /src/META: -------------------------------------------------------------------------------- 1 | version = "~unreleased" 2 | description = "Lighweight library for typeful RPCs" 3 | requires = "ocplib-json-typed,result" 4 | archive(byte) = "ocplib-resto.cma" 5 | archive(byte, plugin) = "ocplib-resto.cma" 6 | archive(native) = "ocplib-resto.cmxa" 7 | archive(native, plugin) = "ocplib-resto.cmxs" 8 | 9 | package "directory" ( 10 | version = "~unreleased" 11 | description = "Lighweight library for typeful RPCs" 12 | requires = "lwt,ocplib-resto" 13 | directory = "directory" 14 | archive(byte) = "ocplib-resto-directory.cma" 15 | archive(byte, plugin) = "ocplib-resto-directory.cma" 16 | archive(native) = "ocplib-resto-directory.cmxa" 17 | archive(native, plugin) = "ocplib-resto-directory.cmxs" 18 | package "functor" ( 19 | version = "~unreleased" 20 | description = "Lighweight library for typeful RPCs" 21 | requires = "ocplib-resto.directory,ocplib-resto.functor" 22 | directory = "functor" 23 | ) 24 | ) 25 | 26 | package "functor" ( 27 | version = "~unreleased" 28 | description = "Lighweight library for typeful RPCs" 29 | requires = "ocplib-resto" 30 | directory = "functor" 31 | ) 32 | -------------------------------------------------------------------------------- /src/build.ocp: -------------------------------------------------------------------------------- 1 | comp += [ "-g" ] 2 | link += [ "-g" ] 3 | comp += [ "-bin-annot" ] 4 | comp += [ "-open" "Result" ] 5 | comp += [ "-w" "-40" ] 6 | requires = [ "result" ] 7 | 8 | begin library "ocplib-resto" 9 | requires += [ 10 | "lwt" 11 | "ocplib-json-typed" 12 | ] 13 | files = [ 14 | "resto.ml" 15 | "ezResto.ml" 16 | ] 17 | end 18 | 19 | begin library "ocplib-resto-directory" 20 | requires += [ 21 | "ocplib-resto" 22 | ] 23 | files = [ 24 | "restoDirectory.ml" 25 | "ezRestoDirectory.ml" 26 | ] 27 | end 28 | 29 | begin program "test" 30 | requires += [ 31 | "ocplib-resto-directory" 32 | ] 33 | files = [ 34 | "resto_test.ml" 35 | "ezResto_test.ml" 36 | ] 37 | end -------------------------------------------------------------------------------- /src/ezResto.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | open Resto 12 | 13 | type json = Json_repr.Ezjsonm.value 14 | module Arg = Arg 15 | module Path = struct 16 | type 'params path = (unit, 'params) Path.path 17 | let root = Path.root 18 | let add_suffix = Path.add_suffix 19 | let add_arg = Path.add_arg 20 | let (/) = add_suffix 21 | let (/:) = add_arg 22 | let map = Path.map 23 | end 24 | type ('params, 'input, 'output) service = 25 | (unit, 'params, 'input, 'output) Resto.service 26 | let service = service 27 | let forge_request = forge_request 28 | let read_answer = read_answer 29 | module Description = Description 30 | module Make = Make 31 | -------------------------------------------------------------------------------- /src/ezResto.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | (** Typed path argument. *) 12 | module Arg : sig 13 | 14 | type 'a arg = 'a Resto.Arg.arg 15 | val make: 16 | ?descr:string -> 17 | name:string -> 18 | destruct:(string -> ('a, string) result) -> 19 | construct:('a -> string) -> 20 | unit -> 'a arg 21 | 22 | type descr = Resto.Arg.descr = { 23 | name: string ; 24 | descr: string option ; 25 | } 26 | val descr: 'a arg -> descr 27 | 28 | val int: int arg 29 | val int32: int32 arg 30 | val int64: int64 arg 31 | val float: float arg 32 | 33 | end 34 | 35 | 36 | (** Parametrized path to services. *) 37 | module Path : sig 38 | 39 | type 'params path = (unit, 'params) Resto.Path.path 40 | 41 | val root: unit path 42 | 43 | val add_suffix: 'params path -> string -> 'params path 44 | val (/): 'params path -> string -> 'params path 45 | 46 | val add_arg: 'params path -> 'a Arg.arg -> ('params * 'a) path 47 | val (/:): 'params path -> 'a Arg.arg -> ('params * 'a) path 48 | 49 | val map: ('a -> 'b) -> ('b -> 'a) -> 'a path -> 'b path 50 | 51 | end 52 | 53 | 54 | (** Services. *) 55 | type ('params, 'input, 'output) service = 56 | (unit, 'params, 'input, 'output) Resto.service 57 | 58 | val service: 59 | ?description: string -> 60 | input: 'input Json_encoding.encoding -> 61 | output: 'output Json_encoding.encoding -> 62 | 'params Path.path -> 63 | ('params, 'input, 'output) service 64 | 65 | type json = Json_repr.Ezjsonm.value 66 | 67 | val forge_request: 68 | ('params, 'input, 'output) service -> 69 | 'params -> 'input -> string list * json 70 | 71 | val read_answer: 72 | ('params, 'input, 'output) service -> 73 | json -> ('output, string) result 74 | 75 | module Make (Repr : Json_repr.Repr) : sig 76 | 77 | val forge_request: 78 | ('params, 'input, 'output) service -> 79 | 'params -> 'input -> string list * Repr.value 80 | 81 | val read_answer: 82 | ('params, 'input, 'output) service -> 83 | Repr.value -> ('output, string) result 84 | 85 | end 86 | 87 | (** Service directory description *) 88 | module Description : sig 89 | 90 | type service_descr = 91 | Resto.Description.service_descr = { 92 | description: string option ; 93 | input: Json_schema.schema ; 94 | output: Json_schema.schema ; 95 | } 96 | 97 | type directory_descr = 98 | Resto.Description.directory_descr = 99 | | Static of static_directory_descr 100 | | Dynamic of string option 101 | 102 | and static_directory_descr = 103 | Resto.Description.static_directory_descr = { 104 | service: service_descr option ; 105 | subdirs: static_subdirectories_descr option ; 106 | } 107 | 108 | and static_subdirectories_descr = 109 | Resto.Description.static_subdirectories_descr = 110 | | Suffixes of directory_descr Map.Make(String).t 111 | | Arg of Arg.descr * directory_descr 112 | 113 | val service: 114 | ?description:string -> 115 | 'params Path.path -> 116 | ('params, bool option, directory_descr) service 117 | 118 | val pp_print_directory_descr: 119 | Format.formatter -> directory_descr -> unit 120 | 121 | end 122 | -------------------------------------------------------------------------------- /src/ezRestoDirectory.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | open Resto 12 | open RestoDirectory 13 | open Lwt 14 | 15 | module Answer = RestoDirectory.Answer 16 | 17 | open RestoDirectory.Answer 18 | 19 | exception Cannot_parse = RestoDirectory.Cannot_parse 20 | type step = RestoDirectory.step = 21 | | Static of string 22 | | Dynamic of Arg.descr 23 | 24 | type conflict = RestoDirectory.conflict = 25 | | CService | CDir | CBuilder | CCustom 26 | | CTypes of Arg.descr * Arg.descr 27 | | CType of Arg.descr * string list 28 | 29 | exception Conflict = RestoDirectory.Conflict 30 | 31 | module Make(Repr : Json_repr.Repr) = struct 32 | 33 | module Impl = RestoDirectory.Make(Repr) 34 | open Impl 35 | 36 | type directory = unit Impl.directory 37 | let empty = empty 38 | let prefix path dir = (prefix path (map (fun _ -> ()) dir)) 39 | let merge = merge 40 | 41 | let lookup tree = lookup tree () 42 | 43 | let register d s h = register d s h 44 | let register0 d s h = register0 d s h 45 | let register1 d s h = register1 d s h 46 | let register2 d s h = register2 d s h 47 | let register3 d s h = register3 d s h 48 | let register4 d s h = register4 d s h 49 | let register5 d s h = register5 d s h 50 | 51 | let register_dynamic_directory ?descr dir path builder = 52 | register_dynamic_directory ?descr dir path 53 | (fun p -> builder p >>= fun dir -> Lwt.return (map (fun _ -> ()) dir)) 54 | 55 | let register_dynamic_directory1 ?descr root s f = 56 | register_dynamic_directory ?descr root s Internal.(curry (S Z) f) 57 | let register_dynamic_directory2 ?descr root s f = 58 | register_dynamic_directory ?descr root s Internal.(curry (S (S Z)) f) 59 | let register_dynamic_directory3 ?descr root s f = 60 | register_dynamic_directory ?descr root s Internal.(curry (S (S (S Z))) f) 61 | 62 | type custom_lookup = Impl.custom_lookup = 63 | | CustomService of Description.service_descr * 64 | (Repr.value option -> Repr.value answer Lwt.t) 65 | | CustomDirectory of Description.directory_descr 66 | 67 | let register_custom_lookup = register_custom_lookup 68 | let register_custom_lookup1 = register_custom_lookup1 69 | let register_custom_lookup2 = register_custom_lookup2 70 | let register_custom_lookup3 = register_custom_lookup3 71 | 72 | let register_describe_directory_service = 73 | register_describe_directory_service 74 | 75 | end 76 | 77 | include Make(Json_repr.Ezjsonm) 78 | -------------------------------------------------------------------------------- /src/ezRestoDirectory.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | open EzResto 12 | 13 | module Answer : sig 14 | 15 | (** Return type for service handler *) 16 | type 'a answer = 17 | { code : int ; 18 | body : 'a output ; 19 | } 20 | 21 | and 'a output = 22 | | Empty 23 | | Single of 'a 24 | | Stream of 'a stream 25 | 26 | and 'a stream = { 27 | next: unit -> 'a option Lwt.t ; 28 | shutdown: unit -> unit ; 29 | } 30 | 31 | val ok: 'a -> 'a answer 32 | val return: 'a -> 'a answer Lwt.t 33 | 34 | end 35 | 36 | (** Possible error while registring services. *) 37 | type step = 38 | | Static of string 39 | | Dynamic of Arg.descr 40 | type conflict = 41 | | CService | CDir | CBuilder | CCustom 42 | | CTypes of Arg.descr * Arg.descr 43 | | CType of Arg.descr * string list 44 | exception Conflict of step list * conflict 45 | 46 | exception Cannot_parse of Arg.descr * string * string list 47 | 48 | module Make (Repr : Json_repr.Repr) : sig 49 | 50 | (** Dispatch tree *) 51 | type directory 52 | 53 | (** Empty tree *) 54 | val empty: directory 55 | 56 | val prefix: 'a Path.path -> directory -> directory 57 | val merge: directory -> directory -> directory 58 | 59 | (** Resolve a service. *) 60 | val lookup: 61 | directory -> string list -> 62 | (Repr.value option -> Repr.value Answer.answer Lwt.t) Lwt.t 63 | 64 | 65 | (** Registring handler in service tree. *) 66 | val register: 67 | directory -> 68 | ('params, 'input, 'output) service -> 69 | ('params -> 'input -> 'output Answer.answer Lwt.t) -> 70 | directory 71 | 72 | (** Registring handler in service tree. Curryfied variant. *) 73 | val register0: 74 | directory -> 75 | (unit, 'i, 'o) service -> 76 | ('i -> 'o Answer.answer Lwt.t) -> 77 | directory 78 | 79 | val register1: 80 | directory -> 81 | (unit * 'a, 'i, 'o) service -> 82 | ('a -> 'i -> 'o Answer.answer Lwt.t) -> 83 | directory 84 | 85 | val register2: 86 | directory -> 87 | ((unit * 'a) * 'b, 'i, 'o) service -> 88 | ('a -> 'b -> 'i -> 'o Answer.answer Lwt.t) -> 89 | directory 90 | 91 | val register3: 92 | directory -> 93 | (((unit * 'a) * 'b) * 'c, 'i, 'o) service -> 94 | ('a -> 'b -> 'c -> 'i -> 'o Answer.answer Lwt.t) -> 95 | directory 96 | 97 | val register4: 98 | directory -> 99 | ((((unit * 'a) * 'b) * 'c) * 'd, 'i, 'o) service -> 100 | ('a -> 'b -> 'c -> 'd -> 'i -> 'o Answer.answer Lwt.t) -> 101 | directory 102 | 103 | val register5: 104 | directory -> 105 | (((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'i, 'o) service -> 106 | ('a -> 'b -> 'c -> 'd -> 'e -> 'i -> 'o Answer.answer Lwt.t) -> 107 | directory 108 | 109 | (** Registring dynamic subtree. *) 110 | val register_dynamic_directory: 111 | ?descr:string -> 112 | directory -> 113 | 'params Path.path -> 114 | ('params -> directory Lwt.t) -> 115 | directory 116 | 117 | (** Registring dynamic subtree. (Curryfied variant) *) 118 | val register_dynamic_directory1: 119 | ?descr:string -> 120 | directory -> 121 | (unit * 'a) Path.path -> 122 | ('a -> directory Lwt.t) -> 123 | directory 124 | 125 | val register_dynamic_directory2: 126 | ?descr:string -> 127 | directory -> 128 | ((unit * 'a) * 'b) Path.path -> 129 | ('a -> 'b -> directory Lwt.t) -> 130 | directory 131 | 132 | val register_dynamic_directory3: 133 | ?descr:string -> 134 | directory -> 135 | (((unit * 'a) * 'b) * 'c) Path.path -> 136 | ('a -> 'b -> 'c -> directory Lwt.t) -> 137 | directory 138 | 139 | (** Registring dynamic subtree. (Curryfied variant) *) 140 | 141 | 142 | (** Registring custom directory lookup. *) 143 | type custom_lookup = 144 | | CustomService of Description.service_descr * 145 | (Repr.value option -> Repr.value Answer.answer Lwt.t) 146 | | CustomDirectory of Description.directory_descr 147 | 148 | val register_custom_lookup: 149 | ?descr:string -> 150 | directory -> 151 | ('params) Path.path -> 152 | ('params -> string list -> custom_lookup Lwt.t) -> 153 | directory 154 | 155 | val register_custom_lookup1: 156 | ?descr:string -> 157 | directory -> 158 | (unit * 'a) Path.path -> 159 | ('a -> string list -> custom_lookup Lwt.t) -> 160 | directory 161 | 162 | val register_custom_lookup2: 163 | ?descr:string -> 164 | directory -> 165 | ((unit * 'a) * 'b) Path.path -> 166 | ('a -> 'b -> string list -> custom_lookup Lwt.t) -> 167 | directory 168 | 169 | val register_custom_lookup3: 170 | ?descr:string -> 171 | directory -> 172 | (((unit * 'a) * 'b) * 'c) Path.path -> 173 | ('a -> 'b -> 'c -> string list -> custom_lookup Lwt.t) -> 174 | directory 175 | 176 | 177 | (** Registring a description service. *) 178 | val register_describe_directory_service: 179 | directory -> 180 | (unit, bool option, Description.directory_descr) service -> 181 | directory 182 | 183 | end 184 | 185 | include (module type of Make (Json_repr.Ezjsonm)) 186 | 187 | -------------------------------------------------------------------------------- /src/ezResto_test.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | open EzResto 12 | 13 | (** Shared part *) 14 | 15 | let repeat_service = 16 | service 17 | ~input:Json_encoding.any_ezjson_value 18 | ~output:Json_encoding.any_ezjson_value 19 | Path.(root / "foo" /: Arg.int / "repeat") 20 | 21 | let add_service = 22 | service 23 | ~input:Json_encoding.int 24 | ~output:Json_encoding.int 25 | Path.(root / "foo" /: Arg.int / "add") 26 | 27 | let alternate_add_service = 28 | service 29 | ~input:Json_encoding.null 30 | ~output:Json_encoding.float 31 | Path.(root / "bar" /: Arg.int /: Arg.float / "add") 32 | 33 | let alternate_add_service' = 34 | service 35 | ~input:Json_encoding.null 36 | ~output:Json_encoding.int 37 | Path.(map 38 | (fun (((),i),f) -> (i,int_of_float f)) 39 | (fun (i,f) -> (((),i),float_of_int f)) 40 | (root / "bar" /: Arg.int /: Arg.float / "add'")) 41 | 42 | let minus_service root = 43 | service 44 | ~input:Json_encoding.null 45 | ~output:Json_encoding.float 46 | Path.(root /: Arg.int / "minus") 47 | 48 | let describe_service = 49 | Description.service Path.(root / "describe") 50 | 51 | (** Server only *) 52 | 53 | module Directory = EzRestoDirectory 54 | open Directory.Answer 55 | 56 | let rec repeat i json = 57 | if i <= 0 then [] 58 | else json :: repeat (i-1) json 59 | 60 | let dir = Directory.empty 61 | let dir = 62 | Directory.register1 dir repeat_service 63 | (fun i json -> return (`A (repeat i json))) 64 | let dir = 65 | Directory.register1 dir add_service 66 | (fun i j -> return (i+j)) 67 | let dir = 68 | Directory.register2 dir alternate_add_service 69 | (fun i j () -> return (float_of_int i+.j)) 70 | let dir = 71 | Directory.register dir alternate_add_service' 72 | (fun (i,j) () -> return (i+j)) 73 | let dir = 74 | Directory.register_describe_directory_service 75 | dir describe_service 76 | 77 | 78 | (** Testing faked client/server communication. *) 79 | 80 | let request service args arg = 81 | let args, arg = forge_request service args arg in 82 | match Lwt.state (Directory.lookup dir args) with 83 | | Lwt.Return handler -> begin 84 | match Lwt.state (handler arg) with 85 | | Lwt.Return { code = 200 ; body = Single x } -> begin 86 | match read_answer service x with 87 | | Ok x -> x 88 | | Error msg -> failwith ("Parse error: " ^ msg) 89 | end 90 | | _ -> failwith "Unexpected lwt result" 91 | end 92 | | _ -> failwith "Unexpected lwt result" 93 | 94 | let () = 95 | let dir = request describe_service () (Some true) in 96 | Format.printf "@[%a@]@." Description.pp_print_directory_descr dir 97 | 98 | let () = 99 | let test service args arg expected = 100 | request service args arg = expected in 101 | assert (test repeat_service ((), 3) (`A []) (`A (repeat 3 (`A [])))) ; 102 | assert (test add_service ((), 2) 3 5) ; 103 | assert (test alternate_add_service (((), 1), 2.5) () 3.5) ; 104 | assert (test alternate_add_service' (1, 2) () 3) ; 105 | () 106 | 107 | let () = 108 | Printf.printf "\n### OK EzResto ###\n\n%!" 109 | -------------------------------------------------------------------------------- /src/resto.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | 12 | module StringMap = Map.Make(String) 13 | let map_option f = function 14 | | None -> None 15 | | Some x -> Some (f x) 16 | 17 | 18 | module Internal = struct 19 | 20 | module Ty = struct 21 | 22 | type 'a witness = .. 23 | exception Not_equal 24 | type (_, _) eq = Eq : ('a, 'a) eq 25 | module type Ty = sig 26 | type t val witness : t witness 27 | val eq: 'a witness -> ('a, t) eq 28 | end 29 | type 'a id = (module Ty with type t = 'a) 30 | let new_id (type a) () = 31 | let module Ty = struct 32 | type t = a 33 | type 'a witness += Ty : t witness 34 | let witness = Ty 35 | let eq (type b) : b witness -> (b, t) eq = 36 | function Ty -> Eq | _ -> raise Not_equal 37 | end in 38 | (module Ty : Ty with type t = a) 39 | let eq : type a b. a id -> b id -> (a, b) eq = 40 | fun (module TyA) (module TyB) -> TyB.eq TyA.witness 41 | 42 | end 43 | 44 | type descr = { 45 | name: string ; 46 | descr: string option ; 47 | } 48 | 49 | type 'a arg = { 50 | id: 'a Ty.id; 51 | destruct: string -> ('a, string) result ; 52 | construct: 'a -> string ; 53 | descr: descr ; 54 | } 55 | 56 | let from_arg x = x 57 | let to_arg x = x 58 | 59 | type (_,_) rpath = 60 | | Root : ('rkey, 'rkey) rpath 61 | | Static : ('rkey, 'key) rpath * string -> ('rkey, 'key) rpath 62 | | Dynamic : ('rkey, 'key) rpath * 'a arg -> ('rkey, 'key * 'a) rpath 63 | 64 | type (_,_) path = 65 | | Path: ('prefix, 'params) rpath -> ('prefix, 'params) path 66 | | MappedPath: 67 | ('prefix, 'key) rpath * ('key -> 'params) * ('params -> 'key) -> 68 | ('prefix, 'params) path 69 | 70 | let from_path x = x 71 | let to_path x = x 72 | 73 | type ('prefix, 'params, 'input, 'output) iservice = { 74 | description : string option ; 75 | path : ('prefix, 'params) path ; 76 | input : 'input Json_encoding.encoding ; 77 | output : 'output Json_encoding.encoding ; 78 | } 79 | 80 | let from_service x = x 81 | let to_service x = x 82 | 83 | end 84 | 85 | open Internal 86 | 87 | module Ty = Internal.Ty 88 | 89 | module Arg = struct 90 | 91 | type descr = Internal.descr = { 92 | name: string ; 93 | descr: string option ; 94 | } 95 | type 'a arg = 'a Internal.arg 96 | 97 | let eq a b = Ty.eq a.id b.id 98 | 99 | let make ?descr ~name ~destruct ~construct () = 100 | let id = Ty.new_id () in 101 | let descr = { name ; descr } in 102 | { descr ; id ; construct ; destruct } 103 | 104 | let descr (ty: 'a arg) = ty.descr 105 | 106 | let descr_encoding = 107 | let open Json_encoding in 108 | conv 109 | (fun {name; descr} -> (name, descr)) 110 | (fun (name, descr) -> {name; descr}) 111 | (obj2 (req "name" string) (opt "descr" string)) 112 | 113 | let int = 114 | let int_of_string s = 115 | try Ok (int_of_string s) 116 | with Failure _ -> 117 | Error (Printf.sprintf "Cannot parse integer value: %S." s) in 118 | make "int" int_of_string string_of_int () 119 | let float = 120 | let float_of_string s = 121 | try Ok (float_of_string s) 122 | with Failure _ -> 123 | Error (Printf.sprintf "Cannot parse float value: %S." s) in 124 | make "float" float_of_string string_of_float () 125 | let int32 = 126 | let int32_of_string s = 127 | try Ok (Int32.of_string s) 128 | with Failure _ -> 129 | Error (Printf.sprintf "Cannot parse int32 value: %S." s) in 130 | make "int32" int32_of_string Int32.to_string () 131 | let int64 = 132 | let int64_of_string s = 133 | try Ok (Int64.of_string s) 134 | with Failure _ -> 135 | Error (Printf.sprintf "Cannot parse int64 value: %S." s) in 136 | make "int64" int64_of_string Int64.to_string () 137 | 138 | end 139 | 140 | module Path = struct 141 | 142 | type ('a, 'b) rpath = ('a, 'b) Internal.rpath 143 | type ('a, 'b) path = ('a, 'b) Internal.path 144 | 145 | type 'prefix context = ('prefix, 'prefix) path 146 | 147 | let root = Path Root 148 | 149 | let add_suffix path name = 150 | match path with 151 | | Path path -> Path (Static (path, name)) 152 | | MappedPath (path, map, rmap) -> 153 | MappedPath (Static (path, name), map, rmap) 154 | 155 | let add_arg path arg = 156 | match path with 157 | | Path path -> Path (Dynamic (path, arg)) 158 | | MappedPath (path, map, rmap) -> 159 | MappedPath (Dynamic (path, arg), 160 | (fun (x, y) -> (map x, y)), 161 | (fun (x, y) -> (rmap x, y))) 162 | 163 | let add_context : 164 | type a p. a Arg.arg -> p context -> (p * a) context = 165 | fun arg path -> 166 | match path with 167 | | Path Root -> Path Root 168 | | MappedPath (Root, map, rmap) -> 169 | MappedPath (Root, 170 | (fun (x, y) -> (map x, y)), 171 | (fun (x, y) -> (rmap x, y))) 172 | | _ -> failwith "Resto.Path.prefix: cannot prefix non-root path." 173 | 174 | let map map rmap = function 175 | | Path p -> MappedPath (p, map, rmap) 176 | | MappedPath (p, map', rmap') -> 177 | MappedPath (p, (fun x -> map (map' x)), (fun x -> rmap' (rmap x))) 178 | 179 | let prefix 180 | : type p pr a. (pr, a) path -> (a, p) path -> (pr, p) path 181 | = fun p1 p2 -> 182 | let rec prefix 183 | : type pr a k. 184 | (pr, a) path -> (a, k) rpath -> (pr, k) path 185 | = fun p1 p2 -> 186 | match p2 with 187 | | Root -> p1 188 | | Static (path, name) -> add_suffix (prefix p1 path) name 189 | | Dynamic (path, arg) -> add_arg (prefix p1 path) arg in 190 | match p2 with 191 | | Path p2 -> prefix p1 p2 192 | | MappedPath (p2, m, rm) -> map m rm (prefix p1 p2) 193 | 194 | let (/) = add_suffix 195 | let (/:) = add_arg 196 | let ( **/ ) = add_context 197 | 198 | 199 | end 200 | 201 | open Path 202 | 203 | type ('prefix, 'params, 'input, 'output) service = 204 | ('prefix, 'params, 'input, 'output) Internal.iservice 205 | 206 | let service ?description ~input ~output path = 207 | { description ; path ; input ; output } 208 | 209 | let prefix path s = { s with path = Path.prefix path s.path } 210 | 211 | module Make(Repr : Json_repr.Repr) = struct 212 | 213 | open Json_encoding 214 | include Make(Repr) 215 | 216 | type json = Repr.value 217 | 218 | let rec forge_request_args 219 | : type p. (unit, p) path -> p -> string list 220 | = fun path args -> 221 | let rec forge_request_args 222 | : type k. (unit, k) rpath -> k -> string list -> string list 223 | = fun path args acc -> 224 | let open Path in 225 | match path, args with 226 | | Root, _ -> 227 | acc 228 | | Static (path, name), args -> 229 | forge_request_args path args (name :: acc) 230 | | Dynamic (path, arg), (args, x) -> 231 | forge_request_args path args (arg.construct x :: acc) in 232 | match path with 233 | | Path path -> forge_request_args path args [] 234 | | MappedPath (path, _, rmap) -> forge_request_args path (rmap args) [] 235 | 236 | let forge_request 237 | : type p i o. 238 | (unit, p, i, o) service -> p -> i -> string list * Repr.value 239 | = fun s args arg -> 240 | forge_request_args s.path args, 241 | construct s.input arg 242 | 243 | let read_answer 244 | : type p i o. 245 | (unit, p, i, o) service -> Repr.value -> (o, string) result 246 | = fun s json -> 247 | try Ok (destruct s.output json) 248 | with exn -> 249 | Error 250 | (Format.asprintf "%a" (fun ppf -> Json_encoding.print_error ppf) exn) 251 | 252 | end 253 | 254 | include Make(Json_repr.Ezjsonm) 255 | 256 | module Description = struct 257 | 258 | type service_descr = { 259 | description: string option ; 260 | input: Json_schema.schema ; 261 | output: Json_schema.schema ; 262 | } 263 | 264 | let service_descr_encoding = 265 | let open Json_encoding in 266 | conv 267 | (fun {description; input; output} -> (description, input, output)) 268 | (fun (description, input, output) -> {description; input; output}) 269 | (obj3 (opt "description" string) 270 | (req "input" any_schema) 271 | (req "output" any_schema)) 272 | 273 | type directory_descr = 274 | | Static of static_directory_descr 275 | | Dynamic of string option 276 | 277 | and static_directory_descr = { 278 | service: service_descr option ; 279 | subdirs: static_subdirectories_descr option ; 280 | } 281 | 282 | and static_subdirectories_descr = 283 | | Suffixes of directory_descr Map.Make(String).t 284 | | Arg of Arg.descr * directory_descr 285 | 286 | let directory_descr_encoding = 287 | let open Json_encoding in 288 | mu "service_tree" @@ fun directory_descr_encoding -> 289 | let static_subdirectories_descr_encoding = 290 | union [ 291 | case (obj1 (req "suffixes" 292 | (list (obj2 (req "name" string) 293 | (req "tree" directory_descr_encoding))))) 294 | (function Suffixes map -> 295 | Some (StringMap.bindings map) | _ -> None) 296 | (fun m -> 297 | let add acc (n,t) = StringMap.add n t acc in 298 | Suffixes (List.fold_left add StringMap.empty m)) ; 299 | case (obj1 (req "dynamic_dispatch" 300 | (obj2 (req "arg" Arg.descr_encoding) 301 | (req "tree" directory_descr_encoding)))) 302 | (function Arg (ty, tree) -> Some (ty, tree) | _ -> None) 303 | (fun (ty, tree) -> Arg (ty, tree)) 304 | ] in 305 | let static_directory_descr_encoding = 306 | conv 307 | (fun { service ; subdirs } -> (service, subdirs)) 308 | (fun (service, subdirs) -> { service ; subdirs }) 309 | (obj2 (opt "service" service_descr_encoding) 310 | (opt "subdirs" static_subdirectories_descr_encoding)) in 311 | union [ 312 | case (obj1 (req "static" static_directory_descr_encoding)) 313 | (function Static descr -> Some descr | _ -> None) 314 | (fun descr -> Static descr) ; 315 | case (obj1 (req "dynamic" (option string))) 316 | (function Dynamic descr -> Some descr | _ -> None) 317 | (fun descr -> Dynamic descr) ; 318 | ] 319 | 320 | let service ?description path = 321 | let description = 322 | match description with 323 | | Some descr -> descr 324 | | None -> "" 325 | in 326 | service 327 | ~description 328 | ~input:Json_encoding.(obj1 (opt "recursive" bool)) 329 | ~output:directory_descr_encoding 330 | path 331 | 332 | let rec pp_print_directory_descr ppf = 333 | let open Format in 334 | function 335 | | Static dir -> 336 | fprintf ppf "@[%a@]" pp_print_static_directory_descr dir 337 | | Dynamic None -> 338 | fprintf ppf "" 339 | | Dynamic (Some descr) -> 340 | fprintf ppf " : %s" descr 341 | 342 | and pp_print_static_directory_descr ppf = 343 | let open Format in 344 | function 345 | | { service = None ; subdirs = None } -> 346 | fprintf ppf "{}" 347 | | { service = Some service ; subdirs = None } -> 348 | fprintf ppf "%a" 349 | pp_print_dispatch_service_descr service 350 | | { service = None ; subdirs = Some subdirs } -> 351 | fprintf ppf "%a" 352 | pp_print_static_subdirectories_descr subdirs 353 | | { service = Some service ; subdirs = Some subdirs } -> 354 | fprintf ppf "@[%a@ %a@]" 355 | pp_print_dispatch_service_descr service 356 | pp_print_static_subdirectories_descr subdirs 357 | 358 | and pp_print_static_subdirectories_descr ppf = 359 | let open Format in 360 | function 361 | | Suffixes map -> 362 | let print_binding ppf (name, tree) = 363 | fprintf ppf "@[%s:@ %a@]" 364 | name pp_print_directory_descr tree in 365 | fprintf ppf "@[%a@]" 366 | (pp_print_list ~pp_sep:pp_print_cut print_binding) 367 | (StringMap.bindings map) 368 | | Arg (arg, tree) -> 369 | fprintf ppf "@[[:%s:]@ @[%a@]@]" 370 | (arg.name) pp_print_directory_descr tree 371 | 372 | and pp_print_dispatch_service_descr ppf = 373 | let open Format in 374 | function 375 | | { description = None} -> 376 | fprintf ppf "" 377 | | { description = Some descr} -> 378 | fprintf ppf " : %s" descr 379 | 380 | end 381 | -------------------------------------------------------------------------------- /src/resto.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | (** Typed path argument. *) 12 | module Arg : sig 13 | 14 | type 'a arg 15 | val make: 16 | ?descr:string -> 17 | name:string -> 18 | destruct:(string -> ('a, string) result) -> 19 | construct:('a -> string) -> 20 | unit -> 'a arg 21 | 22 | type descr = { 23 | name: string ; 24 | descr: string option ; 25 | } 26 | val descr: 'a arg -> descr 27 | 28 | val int: int arg 29 | val int32: int32 arg 30 | val int64: int64 arg 31 | val float: float arg 32 | 33 | end 34 | 35 | 36 | (** Parametrized path to services. *) 37 | module Path : sig 38 | 39 | type ('prefix, 'params) path 40 | type 'prefix context = ('prefix, 'prefix) path 41 | 42 | val root: 'a context 43 | 44 | val add_suffix: 45 | ('prefix, 'params) path -> string -> ('prefix, 'params) path 46 | val (/): 47 | ('prefix, 'params) path -> string -> ('prefix, 'params) path 48 | 49 | val add_arg: 50 | ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path 51 | val (/:): 52 | ('prefix, 'params) path -> 'a Arg.arg -> ('prefix, 'params * 'a) path 53 | 54 | val prefix: 55 | ('prefix, 'a) path -> ('a, 'params) path -> ('prefix, 'params) path 56 | 57 | val map: 58 | ('a -> 'b) -> ('b -> 'a) -> ('prefix, 'a) path -> ('prefix, 'b) path 59 | 60 | end 61 | 62 | 63 | (** Services. *) 64 | type ('prefix, 'params, 'input, 'output) service 65 | 66 | val service: 67 | ?description: string -> 68 | input: 'input Json_encoding.encoding -> 69 | output: 'output Json_encoding.encoding -> 70 | ('prefix, 'params) Path.path -> 71 | ('prefix, 'params, 'input, 'output) service 72 | 73 | val prefix: 74 | ('prefix, 'inner_prefix) Path.path -> 75 | ('inner_prefix, 'params, 'input, 'output) service -> 76 | ('prefix, 'params, 'input, 'output) service 77 | 78 | 79 | type json = Json_repr.Ezjsonm.value 80 | 81 | val forge_request: 82 | (unit, 'params, 'input, 'output) service -> 83 | 'params -> 'input -> string list * json 84 | 85 | val read_answer: 86 | (unit, 'params, 'input, 'output) service -> 87 | json -> ('output, string) result 88 | 89 | module Make (Repr : Json_repr.Repr) : sig 90 | 91 | val forge_request: 92 | (unit, 'params, 'input, 'output) service -> 93 | 'params -> 'input -> string list * Repr.value 94 | 95 | val read_answer: 96 | (unit, 'params, 'input, 'output) service -> 97 | Repr.value -> ('output, string) result 98 | 99 | end 100 | 101 | (** Service directory description *) 102 | module Description : sig 103 | 104 | type service_descr = { 105 | description: string option ; 106 | input: Json_schema.schema ; 107 | output: Json_schema.schema ; 108 | } 109 | 110 | type directory_descr = 111 | | Static of static_directory_descr 112 | | Dynamic of string option 113 | 114 | and static_directory_descr = { 115 | service: service_descr option ; 116 | subdirs: static_subdirectories_descr option ; 117 | } 118 | 119 | and static_subdirectories_descr = 120 | | Suffixes of directory_descr Map.Make(String).t 121 | | Arg of Arg.descr * directory_descr 122 | 123 | val service: 124 | ?description:string -> 125 | ('prefix, 'params) Path.path -> 126 | ('prefix, 'params, bool option, directory_descr) service 127 | 128 | val pp_print_directory_descr: 129 | Format.formatter -> directory_descr -> unit 130 | 131 | end 132 | 133 | 134 | (**/**) 135 | 136 | module Internal : sig 137 | 138 | module Ty : sig 139 | 140 | exception Not_equal 141 | type (_, _) eq = Eq : ('a, 'a) eq 142 | 143 | type 'a id 144 | val eq : 'a id -> 'b id -> ('a, 'b) eq 145 | 146 | end 147 | 148 | type 'a arg = { 149 | id: 'a Ty.id; 150 | destruct: string -> ('a, string) result ; 151 | construct: 'a -> string ; 152 | descr: Arg.descr ; 153 | } 154 | 155 | val from_arg : 'a arg -> 'a Arg.arg 156 | val to_arg : 'a Arg.arg -> 'a arg 157 | 158 | type (_, _) rpath = 159 | | Root : ('rkey, 'rkey) rpath 160 | | Static : ('rkey, 'key) rpath * string -> ('rkey, 'key) rpath 161 | | Dynamic : ('rkey, 'key) rpath * 'a arg -> ('rkey, 'key * 'a) rpath 162 | 163 | type (_, _) path = 164 | | Path: ('prefix, 'params) rpath -> ('prefix, 'params) path 165 | | MappedPath: 166 | ('prefix, 'key) rpath * ('key -> 'params) * ('params -> 'key) -> 167 | ('prefix, 'params) path 168 | 169 | val from_path : ('a, 'b) path -> ('a, 'b) Path.path 170 | val to_path : ('a, 'b) Path.path -> ('a, 'b) path 171 | 172 | type ('prefix, 'params, 'input, 'output) iservice = { 173 | description : string option ; 174 | path : ('prefix, 'params) path ; 175 | input : 'input Json_encoding.encoding ; 176 | output : 'output Json_encoding.encoding ; 177 | } 178 | 179 | val from_service: 180 | ('prefix, 'params, 'input, 'output) iservice -> 181 | ('prefix, 'params, 'input, 'output) service 182 | val to_service: 183 | ('prefix, 'params, 'input, 'output) service -> 184 | ('prefix, 'params, 'input, 'output) iservice 185 | 186 | end 187 | 188 | (**/**) 189 | -------------------------------------------------------------------------------- /src/restoDirectory.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | open Resto 12 | 13 | let map_option f = function 14 | | None -> None 15 | | Some x -> Some (f x) 16 | 17 | let (>>=) = Lwt.bind 18 | let (>|=) = Lwt.(>|=) 19 | module StringMap = Map.Make(String) 20 | 21 | module Internal = struct 22 | 23 | type (_,_,_,_,_,_) conv = 24 | | Z : (unit, 'g, 'g, unit, 'f, 'f) conv 25 | | S : ('t, 'g, 'b * 's, 'rt, 'f, 'r) conv -> 26 | ('t * 'b, 'g, 's, 'a * 'rt, 'a -> 'f, 'r) conv 27 | let reverse 28 | : type a b c d e f. (a, c, unit, d, e, f) conv -> a -> c 29 | = fun c v -> 30 | let rec reverse 31 | : type a b c d e f g. (a, c, d, e, f, g) conv -> a -> d -> c 32 | = fun c v acc -> 33 | match c, v with 34 | | Z, _ -> acc 35 | | S c, (v, x) -> reverse c v (x, acc) in 36 | reverse c v () 37 | let rec curry 38 | : type a b c d e f. (a, b, c, d, e, f) conv -> e -> d -> f 39 | = fun c f -> 40 | match c with 41 | | Z -> fun () -> f 42 | | S c -> (fun (v, x) -> curry c (f v) x) 43 | let curry c f = 44 | let f = curry c f in 45 | fun x -> f (reverse c x) 46 | 47 | end 48 | 49 | let descr x = x.Arg.descr 50 | 51 | module Answer = struct 52 | 53 | type 'a stream = { 54 | next: unit -> 'a option Lwt.t ; 55 | shutdown: unit -> unit ; 56 | } 57 | 58 | type 'a output = 59 | | Empty 60 | | Single of 'a 61 | | Stream of 'a stream 62 | 63 | type 'a answer = 64 | { code : int ; 65 | body : 'a output ; 66 | } 67 | 68 | let ok json = { code = 200 ; body = Single json } 69 | let return json = Lwt.return { code = 200 ; body = Single json } 70 | 71 | let ok_stream st = { code = 200 ; body = Stream st } 72 | let return_stream st = Lwt.return { code = 200 ; body = Stream st } 73 | 74 | let map (type a) (type b) (f:a -> b) (({ code ; body } as ans) : a answer) : b answer = 75 | match ans.body with 76 | | Empty -> { code ; body = Empty } 77 | | Single body -> { code ; body = Single (f body) } 78 | | Stream { next ; shutdown } -> 79 | let next () = 80 | next () >>= function 81 | | None -> Lwt.return_none 82 | | Some x -> Lwt.return (Some (f x)) in 83 | { code ; body = Stream { next ; shutdown } } 84 | 85 | end 86 | 87 | open Answer 88 | 89 | type step = 90 | | Static of string 91 | | Dynamic of Arg.descr 92 | 93 | type conflict = 94 | | CService 95 | | CDir 96 | | CBuilder 97 | | CCustom 98 | | CTypes of Arg.descr * Arg.descr 99 | | CType of Arg.descr * string list 100 | 101 | exception Conflict of step list * conflict 102 | exception Cannot_parse of Arg.descr * string * string list 103 | 104 | module Make(Repr : Json_repr.Repr) = struct 105 | 106 | open Resto.Internal 107 | include Json_encoding.Make(Repr) 108 | 109 | type 'key directory = 110 | | Map : 111 | ('key -> 'inner_key) * 'inner_key directory -> 'key directory 112 | | Static : 'key static_directory -> 'key directory 113 | | Dynamic : 114 | string option * ('key -> 'key directory Lwt.t) -> 'key directory 115 | | Custom : 116 | string option * ( 'key -> string list -> custom_lookup Lwt.t) -> 117 | 'key directory 118 | 119 | and 'key static_directory = { 120 | service: 'key registred_service option ; 121 | subdirs: 'key static_subdirectories option 122 | } 123 | 124 | and _ static_subdirectories = 125 | | Suffixes: 'key directory StringMap.t -> 'key static_subdirectories 126 | | Arg: 'a Resto.Internal.arg * ('key * 'a) directory -> 'key static_subdirectories 127 | 128 | and _ registred_service = 129 | | RegistredService: 130 | string option * 131 | 'i Json_encoding.encoding * 'o Json_encoding.encoding * 132 | ('key -> 'i -> 'o answer Lwt.t) -> 133 | 'key registred_service 134 | 135 | and custom_lookup = 136 | | CustomService of Description.service_descr * 137 | (Repr.value option -> Repr.value answer Lwt.t) 138 | | CustomDirectory of Description.directory_descr 139 | 140 | let empty = Static { service = None ; subdirs = None } 141 | 142 | let rec map_directory 143 | : type a b. 144 | (a -> b) -> b directory -> a directory 145 | = fun f t -> 146 | match t with 147 | | Map (g, dir) -> Map ((fun x -> g (f x)), dir) 148 | | Custom (descr, lookup) -> 149 | let lookup a = lookup (f a) in 150 | Custom (descr, lookup) 151 | | Dynamic (descr, builder) -> 152 | let builder a = builder (f a) >|= map_directory f in 153 | Dynamic (descr, builder) 154 | | Static dir -> 155 | Static (map_static_directory f dir) 156 | 157 | and map_static_directory 158 | : type a b. 159 | (a -> b) -> b static_directory -> a static_directory 160 | = fun f t -> 161 | { service = map_option (map_registred_service f) t.service ; 162 | subdirs = map_option (map_static_subdirectories f) t.subdirs ; 163 | } 164 | and map_static_subdirectories 165 | : type a b. 166 | (a -> b) -> b static_subdirectories -> a static_subdirectories 167 | = fun f t -> 168 | match t with 169 | | Suffixes map -> 170 | Suffixes (StringMap.map (map_directory f) map) 171 | | Arg (arg, dir) -> 172 | let dir = map_directory (fun (a, x) -> f a, x) dir in 173 | Arg (arg, dir) 174 | and map_registred_service 175 | : type a b pr. 176 | (a -> b) -> b registred_service -> a registred_service 177 | = fun f t -> 178 | match t with 179 | | RegistredService (d,i,o,h) -> 180 | RegistredService (d, i, o, (fun p i -> h (f p) i)) 181 | 182 | let map = map_directory 183 | 184 | let prefix 185 | : type p pr. (pr, p) Path.path -> p directory -> pr directory 186 | = fun path dir -> 187 | let rec prefix 188 | : type k pr. (pr, k) Resto.Internal.rpath -> k directory -> pr directory 189 | = fun path dir -> 190 | match path with 191 | | Root -> dir 192 | | Static (path, name) -> 193 | let subdirs = Suffixes (StringMap.singleton name dir) in 194 | prefix path (Static { subdirs = Some subdirs ; service = None }) 195 | | Dynamic (path, arg) -> 196 | let subdirs = Arg (arg, dir) in 197 | prefix path (Static { subdirs = Some subdirs ; service = None }) in 198 | match Resto.Internal.to_path path with 199 | | Path path -> prefix path dir 200 | | MappedPath (path, map, _) -> prefix path (map_directory map dir) 201 | 202 | let conflict steps kind = raise (Conflict (steps, kind)) 203 | 204 | let rec merge 205 | : type p. 206 | step list -> p directory -> p directory -> p directory 207 | = fun path t1 t2 -> 208 | match t1, t2 with 209 | | Map (f, x), t -> 210 | merge path (map_directory f x) t 211 | | t, Map (f, x) -> 212 | merge path t (map_directory f x) 213 | | Static { subdirs = None ; service = None } , t 214 | | t, Static { subdirs = None ; service = None } -> t 215 | | Static n1, Static n2 -> 216 | Static (merge_static_directory path n1 n2) 217 | | Dynamic _, _ 218 | | _, Dynamic _ -> conflict path CBuilder 219 | | Custom _, _ 220 | | _, Custom _ -> conflict path CCustom 221 | 222 | and merge_static_directory 223 | : type p. 224 | step list -> p static_directory -> p static_directory -> p static_directory 225 | = fun path t1 t2 -> 226 | let subdirs = 227 | match t1.subdirs, t2.subdirs with 228 | | None, None -> None 229 | | None, Some dir | Some dir, None -> Some dir 230 | | Some d1, Some d2 -> 231 | match d1, d2 with 232 | | Suffixes m1, Suffixes m2 -> 233 | let merge = 234 | StringMap.fold 235 | (fun n t m -> 236 | let st = 237 | try StringMap.find n m with Not_found -> empty in 238 | StringMap.add n (merge (Static n :: path) st t) m) in 239 | Some (Suffixes (merge m1 m2)) 240 | | Arg (arg1, subt1), Arg (arg2, subt2) -> 241 | begin 242 | try let Ty.Eq = Ty.eq arg1.id arg2.id in 243 | let subt = merge (Dynamic arg1.descr :: path) subt1 subt2 in 244 | Some (Arg (arg1, subt)) 245 | with Ty.Not_equal -> 246 | conflict path (CTypes (arg1.descr, arg2.descr)) 247 | end 248 | | Arg (arg, _), Suffixes m -> 249 | conflict path 250 | (CType (arg.descr, List.map fst (StringMap.bindings m))) 251 | | Suffixes m, Arg (arg, _) -> 252 | conflict path 253 | (CType (arg.descr, List.map fst (StringMap.bindings m))) in 254 | let service = 255 | match t1.service, t2.service with 256 | | None, None -> None 257 | | None, Some s | Some s, None -> Some s 258 | | Some _, Some _ -> conflict path CService 259 | in 260 | { subdirs ; service } 261 | 262 | let merge x y = merge [] x y 263 | 264 | let rec describe_directory 265 | : type a p. ?recurse:bool -> ?arg:a -> a directory -> Description.directory_descr Lwt.t 266 | = fun ?(recurse = true) ?arg dir -> 267 | match dir with 268 | | Map (_, dir) -> describe_directory ~recurse dir 269 | | Dynamic (descr, builder) -> begin 270 | match arg with 271 | | None -> 272 | Lwt.return (Dynamic descr : Description.directory_descr) 273 | | Some arg -> 274 | builder arg >>= fun dir -> describe_directory ~recurse dir 275 | end 276 | | Custom (descr, lookup) -> 277 | Lwt.return (Dynamic descr : Description.directory_descr) 278 | | Static dir -> 279 | describe_static_directory recurse arg dir >>= fun dir -> 280 | Lwt.return (Static dir : Description.directory_descr) 281 | 282 | and describe_static_directory 283 | : type a p. 284 | bool -> a option -> a static_directory -> 285 | Description.static_directory_descr Lwt.t 286 | = fun recurse arg dir -> 287 | let service = map_option describe_service dir.service in 288 | if not recurse && service = None then raise Not_found ; 289 | begin 290 | if recurse 291 | then match dir.subdirs with 292 | | None -> Lwt.return_none 293 | | Some subdirs -> 294 | describe_static_subdirectories arg subdirs >>= fun dirs -> 295 | Lwt.return (Some dirs) 296 | else Lwt.return_none 297 | end >>= fun subdirs -> 298 | Lwt.return ({ service ; subdirs } : Description.static_directory_descr) 299 | 300 | and describe_static_subdirectories 301 | : type a p. 302 | a option -> a static_subdirectories -> 303 | Description.static_subdirectories_descr Lwt.t 304 | = fun arg dir -> 305 | match dir with 306 | | Suffixes map -> 307 | StringMap.fold (fun key dir map -> 308 | map >>= fun map -> 309 | describe_directory ~recurse:true ?arg dir >>= fun dir -> 310 | Lwt.return (StringMap.add key dir map)) 311 | map (Lwt.return StringMap.empty) >>= fun map -> 312 | Lwt.return (Suffixes map : Description.static_subdirectories_descr) 313 | | Arg (arg, dir) -> 314 | describe_directory ~recurse:true dir >>= fun dir -> 315 | Lwt.return (Arg (arg.descr, dir) 316 | : Description.static_subdirectories_descr) 317 | 318 | and describe_service 319 | : type a p. 320 | a registred_service -> Description.service_descr 321 | = fun service -> 322 | match service with 323 | | RegistredService (description,input,output,_) -> 324 | { description ; 325 | input = Json_encoding.schema input ; 326 | output = Json_encoding.schema output } 327 | 328 | (* let pp_print_directory ppf dir = *) 329 | (* Format.fprintf ppf "%a@." *) 330 | (* Description.pp_print_directory_descr (describe_directory dir) *) 331 | 332 | 333 | (**************************************************************************** 334 | * Lookup 335 | ****************************************************************************) 336 | 337 | type resolved_directory = 338 | Dir: 'a directory * 'a -> resolved_directory 339 | 340 | let rec resolve 341 | : type a p. 342 | string list -> a directory -> a -> string list -> resolved_directory Lwt.t 343 | = fun prefix dir args path -> 344 | match path, dir with 345 | | _, Map (f, dir) -> resolve prefix dir (f args) path 346 | | _, Dynamic (_, builder) -> 347 | builder args >>= fun dir -> resolve prefix dir args path 348 | | _, Custom(descr, lookup) -> 349 | let lookup () _ = lookup args path in 350 | Lwt.return (Dir (Custom (descr, lookup), ())) 351 | | [], Static _ -> Lwt.return (Dir (dir, args)) 352 | | name :: path, Static { subdirs = None } -> raise Not_found 353 | | name :: path, Static { subdirs = Some (Suffixes static) } -> 354 | resolve 355 | (name :: prefix) (StringMap.find name static) args path 356 | | name :: path, Static { subdirs = Some (Arg (arg, dir)) } -> 357 | match arg.destruct name with 358 | | Ok x -> resolve (name :: prefix) dir (args, x) path 359 | | Error msg -> 360 | raise (Cannot_parse (arg.descr, msg, name :: prefix)) 361 | 362 | let lookup 363 | : type a p. 364 | a directory -> a -> string list -> 365 | (Repr.value option -> Repr.value answer Lwt.t) Lwt.t 366 | = fun dir args path -> 367 | resolve [] dir args path >>= fun (Dir (dir, args)) -> 368 | match dir with 369 | | Static dir -> begin 370 | match dir.service with 371 | | None -> raise Not_found 372 | | Some (RegistredService (_, input, output, handler)) -> 373 | let call (json: Repr.value option) : Repr.value answer Lwt.t = 374 | match json with 375 | | None -> begin 376 | match destruct input (Repr.repr (`O [])) with 377 | | exception exn -> 378 | Lwt.return { code = 405 ; body = Empty } 379 | | input -> 380 | Lwt.map 381 | (Answer.map (fun x -> construct output x)) 382 | (handler args input) 383 | end 384 | | Some json -> begin 385 | match destruct input json with 386 | | exception exn -> 387 | let body = 388 | let msg = 389 | Format.asprintf "%a" 390 | (fun ppf -> Json_encoding.print_error ppf) exn in 391 | Repr.repr @@ 392 | `O [ "error", 393 | Repr.repr @@ 394 | `String "input has wrong JSON structure" ; 395 | "msg", Repr.repr @@ 396 | `String msg ] in 397 | Lwt.return { code = 400 ; body = Single body } 398 | | input -> 399 | Lwt.map 400 | (Answer.map (fun x -> construct output x)) 401 | (handler args input) 402 | end in 403 | Lwt.return call 404 | end 405 | | Map _ | Dynamic (_,_) -> assert false 406 | | Custom (_,lookup) -> begin 407 | lookup args [] >>= function 408 | | CustomService (_, handler) -> Lwt.return handler 409 | | CustomDirectory _ -> Lwt.fail Not_found 410 | end 411 | 412 | let describe_directory 413 | : type a p. 414 | ?recurse:bool -> a directory -> a -> string list -> Description.directory_descr Lwt.t 415 | = fun ?recurse dir args path -> 416 | resolve [] dir args path >>= fun (Dir (dir, arg)) -> 417 | describe_directory ?recurse ~arg dir 418 | 419 | 420 | 421 | (**************************************************************************** 422 | * Registration 423 | ****************************************************************************) 424 | 425 | let rec step_of_path 426 | : type p rk. (rk, p) rpath -> step list -> step list 427 | = fun path acc -> 428 | match path with 429 | | Root -> acc 430 | | Static (path, name) -> step_of_path path (Static name :: acc) 431 | | Dynamic (path, arg) -> step_of_path path (Dynamic arg.descr :: acc) 432 | let step_of_path p = step_of_path p [] 433 | 434 | let conflict path kind = raise (Conflict (step_of_path path, kind)) 435 | 436 | let rec insert 437 | : type k rk. 438 | (rk, k) rpath -> rk directory -> k directory * (k directory -> rk directory) 439 | = fun path dir -> 440 | match path with 441 | | Root -> dir, (fun x -> x) 442 | | Static (subpath, name) -> begin 443 | let subdir, rebuild = insert subpath dir in 444 | let dirmap, service = 445 | match subdir with 446 | | Map _ -> failwith "Not implemented" 447 | | Static { subdirs = None ; service } -> 448 | StringMap.empty, service 449 | | Static { subdirs = Some (Suffixes m) ; 450 | service } -> 451 | m, service 452 | | Static { subdirs = Some (Arg (arg, _)) } -> 453 | conflict path (CType (arg.descr, [name])) 454 | | Custom _ -> conflict path CCustom 455 | | Dynamic _ -> conflict path CBuilder in 456 | let dir = 457 | try StringMap.find name dirmap with Not_found -> empty in 458 | let rebuild s = 459 | let subdirs = 460 | Some (Suffixes (StringMap.add name s dirmap)) in 461 | rebuild (Static { subdirs ; service }) in 462 | dir, rebuild 463 | end 464 | | Dynamic (subpath, arg) -> begin 465 | let subdir, rebuild = insert subpath dir in 466 | let dir, service = 467 | match subdir with 468 | | Map _ -> failwith "Not implemented" 469 | | Static { subdirs = None ; service } -> 470 | empty, service 471 | | Static { subdirs = Some (Arg (arg', dir)) ; 472 | service } -> begin 473 | try 474 | let Ty.Eq = Ty.eq arg.id arg'.id in 475 | (dir :> k directory), service 476 | with Ty.Not_equal -> 477 | conflict path (CTypes (arg.descr, arg'.descr)) 478 | end 479 | | Static { subdirs = Some (Suffixes m) } -> 480 | conflict path 481 | (CType (arg.descr, List.map fst (StringMap.bindings m))) 482 | | Dynamic _ -> conflict path CBuilder 483 | | Custom _ -> conflict path CCustom in 484 | let rebuild s = 485 | let subdirs = Some (Arg (arg, s)) in 486 | rebuild (Static { subdirs ; service }) in 487 | dir, rebuild 488 | end 489 | 490 | let register 491 | : type p i o pr. 492 | pr directory -> (pr, p, i, o) service -> 493 | (p -> i -> o answer Lwt.t) -> pr directory = 494 | fun root s handler -> 495 | let s = Resto.Internal.to_service s in 496 | let register 497 | : type k. (pr, k) rpath -> (k -> i -> o answer Lwt.t) -> pr directory = 498 | fun path handler -> 499 | let dir, insert = insert path root in 500 | let service = 501 | Some (RegistredService (s.description, s.input, s.output, handler)) in 502 | match dir with 503 | | Map _ -> failwith "Not implemented" 504 | | Static ({ service = None } as dir) -> 505 | insert (Static { dir with service }) 506 | | Static _ -> conflict path CService 507 | | Custom _ -> conflict path CCustom 508 | | Dynamic _ -> conflict path CBuilder in 509 | match s.path with 510 | | Path p -> register p handler 511 | | MappedPath (p, map, _) -> register p (fun p i -> handler (map p) i) 512 | 513 | let register_dynamic_directory 514 | : type pr a pr. 515 | ?descr:string -> 516 | pr directory -> (pr, a) Path.path -> 517 | (a -> a directory Lwt.t) -> pr directory = 518 | fun ?descr root path builder -> 519 | let path = Resto.Internal.to_path path in 520 | let register 521 | : type k. (pr, k) rpath -> (k -> k directory Lwt.t) -> pr directory = 522 | fun path builder -> 523 | let dir, insert = insert path root in 524 | match dir with 525 | | Map _ -> failwith "Not implemented" 526 | | Static ({ service = None ; subdirs = None }) -> 527 | insert (Dynamic (descr, builder)) 528 | | Static ({ service = Some _ }) -> conflict path CService 529 | | Static ({ subdirs = Some _ }) -> conflict path CDir 530 | | Custom _ -> conflict path CCustom 531 | | Dynamic _ -> conflict path CBuilder in 532 | match path with 533 | | Path p -> register p builder 534 | | MappedPath (p, map, _) -> 535 | register p 536 | (fun args -> builder (map args) >|= map_directory map) 537 | 538 | let register_custom_lookup 539 | : type pr a pr. 540 | ?descr:string -> 541 | pr directory -> (pr, a) Path.path -> (a -> string list -> custom_lookup Lwt.t) -> 542 | pr directory = 543 | fun ?descr root path lookup -> 544 | let path = Resto.Internal.to_path path in 545 | let register 546 | : type k. 547 | (pr, k) rpath -> (k -> string list -> custom_lookup Lwt.t) -> 548 | pr directory 549 | = fun path lookup -> 550 | let dir, insert = insert path root in 551 | match dir with 552 | | Map _ -> failwith "Not implemented" 553 | | Static ({ service = None ; subdirs = None }) -> 554 | insert (Custom (descr, lookup)) 555 | | Static ({ service = Some _ }) -> conflict path CService 556 | | Static ({ subdirs = Some _ }) -> conflict path CDir 557 | | Custom _ -> conflict path CCustom 558 | | Dynamic _ -> conflict path CBuilder in 559 | match path with 560 | | Path p -> register p lookup 561 | | MappedPath (p, map, _) -> 562 | register p (fun args -> lookup (map args)) 563 | 564 | 565 | let register_describe_directory_service 566 | : type pr. 567 | pr directory -> (pr, pr, bool option, Description.directory_descr) service -> 568 | pr directory 569 | = fun root service -> 570 | let { description ; path ; output ; input } = 571 | Resto.Internal.to_service service in 572 | let descr : Description.service_descr = { 573 | description ; 574 | input = Json_encoding.schema input ; 575 | output = Json_encoding.schema output ; 576 | } in 577 | let dir = ref root in 578 | let lookup args path = 579 | let handler json = 580 | let recurse = 581 | match json with 582 | | None -> false 583 | | Some json -> 584 | match destruct input json with 585 | | exception _ -> false 586 | | None -> false 587 | | Some b -> b in 588 | describe_directory ~recurse !dir args path >>= fun d -> 589 | return (construct output d) in 590 | Lwt.return (CustomService (descr, handler)) in 591 | dir := 592 | register_custom_lookup root (Resto.Internal.from_path path) lookup ; 593 | !dir 594 | 595 | 596 | (**************************************************************************** 597 | * Let's currify! 598 | ****************************************************************************) 599 | 600 | open Internal 601 | 602 | let register0 root s f = register root s Resto.(curry Z f) 603 | let register1 root s f = register root s Resto.(curry (S Z) f) 604 | let register2 root s f = register root s Resto.(curry (S (S Z)) f) 605 | let register3 root s f = register root s Resto.(curry (S (S (S Z))) f) 606 | let register4 root s f = register root s Resto.(curry (S (S (S (S Z)))) f) 607 | let register5 root s f = register root s Resto.(curry (S (S (S (S (S Z))))) f) 608 | 609 | let register_dynamic_directory0 ?descr root s f = 610 | register_dynamic_directory ?descr root s Resto.(curry Z f) 611 | let register_dynamic_directory1 ?descr root s f = 612 | register_dynamic_directory ?descr root s Resto.(curry (S Z) f) 613 | let register_dynamic_directory2 ?descr root s f = 614 | register_dynamic_directory ?descr root s Resto.(curry (S (S Z)) f) 615 | let register_dynamic_directory3 ?descr root s f = 616 | register_dynamic_directory ?descr root s Resto.(curry (S (S (S Z))) f) 617 | 618 | let register_custom_lookup1 ?descr root s f = 619 | register_custom_lookup ?descr root s Resto.(curry (S Z) f) 620 | let register_custom_lookup2 ?descr root s f = 621 | register_custom_lookup ?descr root s Resto.(curry (S (S Z)) f) 622 | let register_custom_lookup3 ?descr root s f = 623 | register_custom_lookup ?descr root s Resto.(curry (S (S (S Z))) f) 624 | 625 | end 626 | 627 | include Make (Json_repr.Ezjsonm) 628 | -------------------------------------------------------------------------------- /src/restoDirectory.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | open Resto 12 | 13 | module Answer : sig 14 | 15 | (** Return type for service handler *) 16 | type 'a answer = 17 | { code : int ; 18 | body : 'a output ; 19 | } 20 | 21 | and 'a output = 22 | | Empty 23 | | Single of 'a 24 | | Stream of 'a stream 25 | 26 | and 'a stream = { 27 | next: unit -> 'a option Lwt.t ; 28 | shutdown: unit -> unit ; 29 | } 30 | 31 | val ok: 'a -> 'a answer 32 | val ok_stream: 'a stream -> 'a answer 33 | val return: 'a -> 'a answer Lwt.t 34 | val return_stream: 'a stream -> 'a answer Lwt.t 35 | 36 | end 37 | 38 | (** Possible error while registring services. *) 39 | type step = 40 | | Static of string 41 | | Dynamic of Arg.descr 42 | type conflict = 43 | | CService | CDir | CBuilder | CCustom 44 | | CTypes of Arg.descr * 45 | Arg.descr 46 | | CType of Arg.descr * string list 47 | exception Conflict of step list * conflict 48 | exception Cannot_parse of Arg.descr * string * string list 49 | 50 | module Make (Repr : Json_repr.Repr) : sig 51 | 52 | (** Dispatch tree *) 53 | type 'prefix directory 54 | 55 | (** Empty tree *) 56 | val empty: 'prefix directory 57 | 58 | val map: ('a -> 'b) -> 'b directory -> 'a directory 59 | 60 | val prefix: ('pr, 'p) Path.path -> 'p directory -> 'pr directory 61 | val merge: 'a directory -> 'a directory -> 'a directory 62 | 63 | (** Resolve a service. *) 64 | val lookup: 65 | 'prefix directory -> 'prefix -> string list -> 66 | (Repr.value option -> Repr.value Answer.answer Lwt.t) Lwt.t 67 | 68 | 69 | (** Registring handler in service tree. *) 70 | val register: 71 | 'prefix directory -> 72 | ('prefix, 'params, 'input, 'output) service -> 73 | ('params -> 'input -> 'output Answer.answer Lwt.t) -> 74 | 'prefix directory 75 | 76 | (** Registring handler in service tree. Curryfied variant. *) 77 | val register0: 78 | unit directory -> 79 | (unit, unit, 'i, 'o) service -> 80 | ('i -> 'o Answer.answer Lwt.t) -> 81 | unit directory 82 | 83 | val register1: 84 | 'prefix directory -> 85 | ('prefix, unit * 'a, 'i, 'o) service -> 86 | ('a -> 'i -> 'o Answer.answer Lwt.t) -> 87 | 'prefix directory 88 | 89 | val register2: 90 | 'prefix directory -> 91 | ('prefix, (unit * 'a) * 'b, 'i, 'o) service -> 92 | ('a -> 'b -> 'i -> 'o Answer.answer Lwt.t) -> 93 | 'prefix directory 94 | 95 | val register3: 96 | 'prefix directory -> 97 | ('prefix, ((unit * 'a) * 'b) * 'c, 'i, 'o) service -> 98 | ('a -> 'b -> 'c -> 'i -> 'o Answer.answer Lwt.t) -> 99 | 'prefix directory 100 | 101 | val register4: 102 | 'prefix directory -> 103 | ('prefix, (((unit * 'a) * 'b) * 'c) * 'd, 'i, 'o) service -> 104 | ('a -> 'b -> 'c -> 'd -> 'i -> 'o Answer.answer Lwt.t) -> 105 | 'prefix directory 106 | 107 | val register5: 108 | 'prefix directory -> 109 | ('prefix, ((((unit * 'a) * 'b) * 'c) * 'd) * 'e, 'i, 'o) service -> 110 | ('a -> 'b -> 'c -> 'd -> 'e -> 'i -> 'o Answer.answer Lwt.t) -> 111 | 'prefix directory 112 | 113 | (** Registring dynamic subtree. *) 114 | val register_dynamic_directory: 115 | ?descr:string -> 116 | 'prefix directory -> 117 | ('prefix, 'a) Path.path -> ('a -> 'a directory Lwt.t) -> 118 | 'prefix directory 119 | 120 | (** Registring dynamic subtree. (Curryfied variant) *) 121 | val register_dynamic_directory1: 122 | ?descr:string -> 123 | 'prefix directory -> 124 | ('prefix, unit * 'a) Path.path -> 125 | ('a -> (unit * 'a) directory Lwt.t) -> 126 | 'prefix directory 127 | 128 | val register_dynamic_directory2: 129 | ?descr:string -> 130 | 'prefix directory -> 131 | ('prefix, (unit * 'a) * 'b) Path.path -> 132 | ('a -> 'b -> ((unit * 'a) * 'b) directory Lwt.t) -> 133 | 'prefix directory 134 | 135 | val register_dynamic_directory3: 136 | ?descr:string -> 137 | 'prefix directory -> 138 | ('prefix, ((unit * 'a) * 'b) * 'c) Path.path -> 139 | ('a -> 'b -> 'c -> (((unit * 'a) * 'b) * 'c) directory Lwt.t) -> 140 | 'prefix directory 141 | 142 | (** Registring custom directory lookup. *) 143 | type custom_lookup = 144 | | CustomService of Description.service_descr * 145 | (Repr.value option -> Repr.value Answer.answer Lwt.t) 146 | | CustomDirectory of Description.directory_descr 147 | 148 | val register_custom_lookup: 149 | ?descr:string -> 150 | 'prefix directory -> 151 | ('prefix, 'params) Path.path -> 152 | ('params -> string list -> custom_lookup Lwt.t) -> 153 | 'prefix directory 154 | 155 | val register_custom_lookup1: 156 | ?descr:string -> 157 | 'prefix directory -> 158 | ('prefix, unit * 'a) Path.path -> 159 | ('a -> string list -> custom_lookup Lwt.t) -> 160 | 'prefix directory 161 | 162 | val register_custom_lookup2: 163 | ?descr:string -> 164 | 'prefix directory -> 165 | ('prefix, (unit * 'a) * 'b) Path.path -> 166 | ('a -> 'b -> string list -> custom_lookup Lwt.t) -> 167 | 'prefix directory 168 | 169 | val register_custom_lookup3: 170 | ?descr:string -> 171 | 'prefix directory -> 172 | ('prefix, ((unit * 'a) * 'b) * 'c) Path.path -> 173 | ('a -> 'b -> 'c -> string list -> custom_lookup Lwt.t) -> 174 | 'prefix directory 175 | 176 | 177 | (** Registring a description service. *) 178 | val register_describe_directory_service: 179 | 'prefix directory -> 180 | ('prefix, 'prefix, bool option, Description.directory_descr) service -> 181 | 'prefix directory 182 | 183 | end 184 | 185 | include (module type of Make (Json_repr.Ezjsonm)) 186 | 187 | module Internal : sig 188 | 189 | type (_,_,_,_,_,_) conv = 190 | | Z : (unit, 'g, 'g, unit, 'f, 'f) conv 191 | | S : ('t, 'g, 'b * 's, 'rt, 'f, 'r) conv -> 192 | ('t * 'b, 'g, 's, 'a * 'rt, 'a -> 'f, 'r) conv 193 | val curry : ('a, 'b, unit, 'b, 'c, 'd) conv -> 'c -> 'a -> 'd 194 | 195 | end 196 | -------------------------------------------------------------------------------- /src/resto_test.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* ocplib-resto *) 3 | (* Copyright (C) 2016, OCamlPro. *) 4 | (* *) 5 | (* All rights reserved. This file is distributed under the terms *) 6 | (* of the GNU Lesser General Public License version 2.1, with the *) 7 | (* special exception on linking described in the file LICENSE. *) 8 | (* *) 9 | (**************************************************************************) 10 | 11 | open Resto 12 | 13 | (** Shared part *) 14 | 15 | let repeat_service = 16 | service 17 | ~input:Json_encoding.any_ezjson_value 18 | ~output:Json_encoding.any_ezjson_value 19 | Path.(root / "foo" /: Arg.int / "repeat") 20 | 21 | let add_service = 22 | service 23 | ~input:Json_encoding.int 24 | ~output:Json_encoding.int 25 | Path.(root / "foo" /: Arg.int / "add") 26 | 27 | let alternate_add_service = 28 | service 29 | ~input:Json_encoding.null 30 | ~output:Json_encoding.float 31 | Path.(root / "bar" /: Arg.int /: Arg.float / "add") 32 | 33 | let alternate_add_service' = 34 | service 35 | ~input:Json_encoding.null 36 | ~output:Json_encoding.int 37 | Path.(map 38 | (fun (((),i),f) -> (i,int_of_float f)) 39 | (fun (i,f) -> (((),i),float_of_int f)) 40 | (root / "bar" /: Arg.int /: Arg.float / "add'")) 41 | 42 | let minus_service custom_root = 43 | service 44 | ~input:Json_encoding.null 45 | ~output:Json_encoding.float 46 | Path.(custom_root /: Arg.int / "minus") 47 | 48 | let describe_service = 49 | Description.service Path.(root / "describe") 50 | 51 | let dummy_service = 52 | service 53 | ~input:Json_encoding.null 54 | ~output:Json_encoding.null 55 | Path.(root / "a" / "path" / "long" / "enough" / 56 | "for" / "" / "to" / "trigger" 57 | /: Arg.float /: Arg.float /: Arg.float /: Arg.float 58 | /: Arg.float /: Arg.float /: Arg.float) 59 | 60 | let prefix_dir1 = Path.(root / "tartine" /: Arg.float / "chaussure") 61 | let prefix_dir2 = Path.(root / "epice" /: Arg.int) 62 | 63 | 64 | (** Client only *) 65 | 66 | let real_minus_service1 = minus_service prefix_dir1 67 | let real_minus_service2 = minus_service prefix_dir2 68 | 69 | 70 | (** Server only *) 71 | 72 | module Directory = RestoDirectory 73 | open Directory.Answer 74 | 75 | let rec repeat i json = 76 | if i <= 0 then [] 77 | else json :: repeat (i-1) json 78 | 79 | let dir = Directory.empty 80 | let dir = 81 | Directory.register1 dir repeat_service 82 | (fun i json -> return (`A (repeat i json))) 83 | let dir = 84 | Directory.register1 dir add_service 85 | (fun i j -> return (i+j)) 86 | let dir = 87 | Directory.register2 dir alternate_add_service 88 | (fun i j () -> return (float_of_int i+.j)) 89 | let dir = 90 | Directory.register dir alternate_add_service' 91 | (fun (i,j) () -> return (i+j)) 92 | let dir = 93 | Directory.register dir dummy_service 94 | (fun ((((((((),a), b), c), d), e), f), g) () -> return ()) 95 | 96 | let prefixed_dir = Directory.empty 97 | let prefixed_dir = 98 | Directory.register2 prefixed_dir (minus_service Path.root) 99 | (fun i j () -> return (i -. float_of_int j)) 100 | 101 | let dir = 102 | Directory.register_dynamic_directory1 dir prefix_dir1 103 | (fun _ -> Lwt.return prefixed_dir) 104 | let dir = 105 | Directory.register_dynamic_directory1 dir 106 | prefix_dir2 107 | (fun _ -> 108 | Lwt.return 109 | (Directory.map 110 | (fun ((), x) -> ((), float_of_int x)) 111 | prefixed_dir)) 112 | 113 | let dir = 114 | Directory.register_describe_directory_service 115 | dir describe_service 116 | 117 | 118 | (** Testing faked client/server communication. *) 119 | 120 | 121 | let request service args arg = 122 | let args, arg = forge_request service args arg in 123 | match Lwt.state (Directory.lookup dir () args) with 124 | | Lwt.Return handler -> begin 125 | match Lwt.state (handler arg) with 126 | | Lwt.Return { code = 200 ; body = Single x } -> begin 127 | match read_answer service x with 128 | | Ok x -> x 129 | | Error msg -> failwith ("Parse error: " ^ msg) 130 | end 131 | | _ -> failwith "Unexpected lwt result" 132 | end 133 | | _ -> failwith "Unexpected lwt result" 134 | 135 | let () = 136 | let dir = request describe_service () (Some true) in 137 | Format.printf "@[%a@]@." Description.pp_print_directory_descr dir 138 | 139 | let () = 140 | let test service args arg expected = request service args arg = expected in 141 | assert (test repeat_service ((), 3) (`A []) (`A (repeat 3 (`A [])))) ; 142 | assert (test add_service ((), 2) 3 5) ; 143 | assert (test alternate_add_service (((), 1), 2.5) () 3.5) ; 144 | assert (test real_minus_service1 (((), 2.5), 1) () 1.5) ; 145 | assert (test real_minus_service2 (((), 2), 1) () 1.) ; 146 | assert (test alternate_add_service' (1, 2) () 3) ; 147 | () 148 | 149 | let () = 150 | Printf.printf "\n### OK Resto ###\n\n%!" 151 | --------------------------------------------------------------------------------