├── .gitignore ├── .merlin ├── AUTHORS ├── CHANGES ├── COPYING ├── Makefile ├── README.md ├── dune-project ├── pa_sqlexpr.opam ├── ppx_sqlexpr.opam ├── sqlexpr.opam ├── sqlexpr.syntax.opam ├── src ├── OMakefile ├── dune ├── ppx │ ├── dune │ ├── ppx_sqlexpr.ml │ └── sqlexpr_parser.ml ├── sqlexpr_concurrency.ml ├── sqlexpr_concurrency.mli ├── sqlexpr_sqlite.ml ├── sqlexpr_sqlite.mli ├── sqlexpr_sqlite_lwt.ml ├── sqlexpr_sqlite_lwt.mli ├── sqlexpr_utils.ml ├── syntax │ ├── dune │ └── pa_sql.ml └── syntax_compat │ ├── dune │ └── pa_sql.ml └── tests ├── .gitignore ├── ppx ├── OMakefile ├── dune ├── example.ml ├── t_parse.ml └── t_sqlexpr.ml └── syntax ├── OMakefile ├── example.ml ├── t_parse.ml └── t_sqlexpr.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | **/*.merlin 3 | *.install 4 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S src/ 2 | S src/syntax 3 | S tests 4 | B _build/src 5 | B _build/src/syntax 6 | B _build/tests 7 | B +threads 8 | PKG lwt 9 | PKG lwt_ppx 10 | PKG sqlite3 11 | PKG unix 12 | PKG csv 13 | PKG threads 14 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Mauricio Fernandez 2 | Josh Allmann 3 | Simon Cruanes simon[dot]cruanes[dot]2007[at]m4x[dot]org 4 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | 1.0.0 (unreleased) 2 | ================== 3 | * fix Sqlexpr_sqlite_lwt nested transaction bug: partial rollback not 4 | performed 5 | * migrate to dune (final version of jbuilder) 6 | * add more flexible "select_one_maybe_f" function 7 | * fix several compile-time warnings in code generated by ppx 8 | 9 | 0.9.0 (2018-05-12) 10 | ===== 11 | * migrate to jbuilder, move the PPX and Camlp4 extensions to separate packages 12 | ppx_sqlexpr and pa_sqlexpr (Freyr). 13 | * fix stack overflows when iterating/fold/selecting over many rows when 14 | using Sqlexpr_concurrency.Id concurrency. 15 | * multiple fixes to work with newer versions of Lwt and lwt_ppx. 16 | 17 | Backwards compatibility is provided for the time being as follows: 18 | * sqlexpr depends on ppx_sqlexpr, and a sqlexpr.ppx alias is provided 19 | * if estring was installed (required if sqlexpr.syntax was being used), 20 | sqlexpr.syntax will also be installed 21 | * installing pa_sqlexpr will also install its estring dependency, and 22 | cause a sqlexpr rebuild, so that sqlexpr.syntax is provided 23 | 24 | These mean that it is still possible to (wherever it was before) compile e.g. 25 | with 26 | 27 | ocamlfind ocamlopt -package sqlexpr,sqlexpr.syntax -syntax camlp4o -c ... 28 | 29 | but in the future the sqlexpr.syntax and sqlexpr.ppx aliases will be dropped, 30 | so it is recommended to: 31 | 32 | 1) opam install ppx_sqlexpr and/or pa_sqlexpr explicitly 33 | 2) start using the ppx_sqlexpr instead of sqlexpr.ppx and pa_sqlexpr instead 34 | of sqlexpr.syntax in your build system. 35 | 36 | 0.8.0 37 | ===== 38 | * camlp4 syntax extension now optional (Josh Allmann) 39 | 40 | 0.7.0 41 | ===== 42 | 43 | * PPX extension thanks to Josh Allmann 44 | * more efficient row iteration/selection (in batches) in Sqlexpr_sqlite_lwt 45 | * fix possible performance issue caused by the Event module 46 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | 2 | As a special exception to the GNU Library General Public License, you may link, 3 | statically or dynamically, a "work that uses the Library" with a publicly 4 | distributed version of the Library to produce an executable file containing 5 | portions of the Library, and distribute that executable file under terms of 6 | your choice, without any of the additional requirements listed in clause 6 of 7 | the GNU Library General Public License. By "a publicly distributed version of 8 | the Library", we mean either the unmodified Library as distributed by upstream 9 | author, or a modified version of the Library that is distributed under the 10 | conditions defined in clause 2 of the GNU Library General Public License. This 11 | exception does not however invalidate any other reasons why the executable file 12 | might be covered by the GNU Library General Public License. 13 | 14 | ----------------------------------------------------------------------- 15 | GNU LESSER GENERAL PUBLIC LICENSE 16 | Version 2.1, February 1999 17 | 18 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 19 | 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | Everyone is permitted to copy and distribute verbatim copies 21 | of this license document, but changing it is not allowed. 22 | 23 | [This is the first released version of the Lesser GPL. It also counts 24 | as the successor of the GNU Library Public License, version 2, hence 25 | the version number 2.1.] 26 | 27 | Preamble 28 | 29 | The licenses for most software are designed to take away your 30 | freedom to share and change it. By contrast, the GNU General Public 31 | Licenses are intended to guarantee your freedom to share and change 32 | free software--to make sure the software is free for all its users. 33 | 34 | This license, the Lesser General Public License, applies to some 35 | specially designated software packages--typically libraries--of the 36 | Free Software Foundation and other authors who decide to use it. You 37 | can use it too, but we suggest you first think carefully about whether 38 | this license or the ordinary General Public License is the better 39 | strategy to use in any particular case, based on the explanations 40 | below. 41 | 42 | When we speak of free software, we are referring to freedom of use, 43 | not price. Our General Public Licenses are designed to make sure that 44 | you have the freedom to distribute copies of free software (and charge 45 | for this service if you wish); that you receive source code or can get 46 | it if you want it; that you can change the software and use pieces of 47 | it in new free programs; and that you are informed that you can do 48 | these things. 49 | 50 | To protect your rights, we need to make restrictions that forbid 51 | distributors to deny you these rights or to ask you to surrender these 52 | rights. These restrictions translate to certain responsibilities for 53 | you if you distribute copies of the library or if you modify it. 54 | 55 | For example, if you distribute copies of the library, whether gratis 56 | or for a fee, you must give the recipients all the rights that we gave 57 | you. You must make sure that they, too, receive or can get the source 58 | code. If you link other code with the library, you must provide 59 | complete object files to the recipients, so that they can relink them 60 | with the library after making changes to the library and recompiling 61 | it. And you must show them these terms so they know their rights. 62 | 63 | We protect your rights with a two-step method: (1) we copyright the 64 | library, and (2) we offer you this license, which gives you legal 65 | permission to copy, distribute and/or modify the library. 66 | 67 | To protect each distributor, we want to make it very clear that 68 | there is no warranty for the free library. Also, if the library is 69 | modified by someone else and passed on, the recipients should know 70 | that what they have is not the original version, so that the original 71 | author's reputation will not be affected by problems that might be 72 | introduced by others. 73 | ^L 74 | Finally, software patents pose a constant threat to the existence of 75 | any free program. We wish to make sure that a company cannot 76 | effectively restrict the users of a free program by obtaining a 77 | restrictive license from a patent holder. Therefore, we insist that 78 | any patent license obtained for a version of the library must be 79 | consistent with the full freedom of use specified in this license. 80 | 81 | Most GNU software, including some libraries, is covered by the 82 | ordinary GNU General Public License. This license, the GNU Lesser 83 | General Public License, applies to certain designated libraries, and 84 | is quite different from the ordinary General Public License. We use 85 | this license for certain libraries in order to permit linking those 86 | libraries into non-free programs. 87 | 88 | When a program is linked with a library, whether statically or using 89 | a shared library, the combination of the two is legally speaking a 90 | combined work, a derivative of the original library. The ordinary 91 | General Public License therefore permits such linking only if the 92 | entire combination fits its criteria of freedom. The Lesser General 93 | Public License permits more lax criteria for linking other code with 94 | the library. 95 | 96 | We call this license the "Lesser" General Public License because it 97 | does Less to protect the user's freedom than the ordinary General 98 | Public License. It also provides other free software developers Less 99 | of an advantage over competing non-free programs. These disadvantages 100 | are the reason we use the ordinary General Public License for many 101 | libraries. However, the Lesser license provides advantages in certain 102 | special circumstances. 103 | 104 | For example, on rare occasions, there may be a special need to 105 | encourage the widest possible use of a certain library, so that it 106 | becomes a de-facto standard. To achieve this, non-free programs must 107 | be allowed to use the library. A more frequent case is that a free 108 | library does the same job as widely used non-free libraries. In this 109 | case, there is little to gain by limiting the free library to free 110 | software only, so we use the Lesser General Public License. 111 | 112 | In other cases, permission to use a particular library in non-free 113 | programs enables a greater number of people to use a large body of 114 | free software. For example, permission to use the GNU C Library in 115 | non-free programs enables many more people to use the whole GNU 116 | operating system, as well as its variant, the GNU/Linux operating 117 | system. 118 | 119 | Although the Lesser General Public License is Less protective of the 120 | users' freedom, it does ensure that the user of a program that is 121 | linked with the Library has the freedom and the wherewithal to run 122 | that program using a modified version of the Library. 123 | 124 | The precise terms and conditions for copying, distribution and 125 | modification follow. Pay close attention to the difference between a 126 | "work based on the library" and a "work that uses the library". The 127 | former contains code derived from the library, whereas the latter must 128 | be combined with the library in order to run. 129 | ^L 130 | GNU LESSER GENERAL PUBLIC LICENSE 131 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 132 | 133 | 0. This License Agreement applies to any software library or other 134 | program which contains a notice placed by the copyright holder or 135 | other authorized party saying it may be distributed under the terms of 136 | this Lesser General Public License (also called "this License"). 137 | Each licensee is addressed as "you". 138 | 139 | A "library" means a collection of software functions and/or data 140 | prepared so as to be conveniently linked with application programs 141 | (which use some of those functions and data) to form executables. 142 | 143 | The "Library", below, refers to any such software library or work 144 | which has been distributed under these terms. A "work based on the 145 | Library" means either the Library or any derivative work under 146 | copyright law: that is to say, a work containing the Library or a 147 | portion of it, either verbatim or with modifications and/or translated 148 | straightforwardly into another language. (Hereinafter, translation is 149 | included without limitation in the term "modification".) 150 | 151 | "Source code" for a work means the preferred form of the work for 152 | making modifications to it. For a library, complete source code means 153 | all the source code for all modules it contains, plus any associated 154 | interface definition files, plus the scripts used to control 155 | compilation and installation of the library. 156 | 157 | Activities other than copying, distribution and modification are not 158 | covered by this License; they are outside its scope. The act of 159 | running a program using the Library is not restricted, and output from 160 | such a program is covered only if its contents constitute a work based 161 | on the Library (independent of the use of the Library in a tool for 162 | writing it). Whether that is true depends on what the Library does 163 | and what the program that uses the Library does. 164 | 165 | 1. You may copy and distribute verbatim copies of the Library's 166 | complete source code as you receive it, in any medium, provided that 167 | you conspicuously and appropriately publish on each copy an 168 | appropriate copyright notice and disclaimer of warranty; keep intact 169 | all the notices that refer to this License and to the absence of any 170 | warranty; and distribute a copy of this License along with the 171 | Library. 172 | 173 | You may charge a fee for the physical act of transferring a copy, 174 | and you may at your option offer warranty protection in exchange for a 175 | fee. 176 | 177 | 2. You may modify your copy or copies of the Library or any portion 178 | of it, thus forming a work based on the Library, and copy and 179 | distribute such modifications or work under the terms of Section 1 180 | above, provided that you also meet all of these conditions: 181 | 182 | a) The modified work must itself be a software library. 183 | 184 | b) You must cause the files modified to carry prominent notices 185 | stating that you changed the files and the date of any change. 186 | 187 | c) You must cause the whole of the work to be licensed at no 188 | charge to all third parties under the terms of this License. 189 | 190 | d) If a facility in the modified Library refers to a function or a 191 | table of data to be supplied by an application program that uses 192 | the facility, other than as an argument passed when the facility 193 | is invoked, then you must make a good faith effort to ensure that, 194 | in the event an application does not supply such function or 195 | table, the facility still operates, and performs whatever part of 196 | its purpose remains meaningful. 197 | 198 | (For example, a function in a library to compute square roots has 199 | a purpose that is entirely well-defined independent of the 200 | application. Therefore, Subsection 2d requires that any 201 | application-supplied function or table used by this function must 202 | be optional: if the application does not supply it, the square 203 | root function must still compute square roots.) 204 | 205 | These requirements apply to the modified work as a whole. If 206 | identifiable sections of that work are not derived from the Library, 207 | and can be reasonably considered independent and separate works in 208 | themselves, then this License, and its terms, do not apply to those 209 | sections when you distribute them as separate works. But when you 210 | distribute the same sections as part of a whole which is a work based 211 | on the Library, the distribution of the whole must be on the terms of 212 | this License, whose permissions for other licensees extend to the 213 | entire whole, and thus to each and every part regardless of who wrote 214 | it. 215 | 216 | Thus, it is not the intent of this section to claim rights or contest 217 | your rights to work written entirely by you; rather, the intent is to 218 | exercise the right to control the distribution of derivative or 219 | collective works based on the Library. 220 | 221 | In addition, mere aggregation of another work not based on the Library 222 | with the Library (or with a work based on the Library) on a volume of 223 | a storage or distribution medium does not bring the other work under 224 | the scope of this License. 225 | 226 | 3. You may opt to apply the terms of the ordinary GNU General Public 227 | License instead of this License to a given copy of the Library. To do 228 | this, you must alter all the notices that refer to this License, so 229 | that they refer to the ordinary GNU General Public License, version 2, 230 | instead of to this License. (If a newer version than version 2 of the 231 | ordinary GNU General Public License has appeared, then you can specify 232 | that version instead if you wish.) Do not make any other change in 233 | these notices. 234 | ^L 235 | Once this change is made in a given copy, it is irreversible for 236 | that copy, so the ordinary GNU General Public License applies to all 237 | subsequent copies and derivative works made from that copy. 238 | 239 | This option is useful when you wish to copy part of the code of 240 | the Library into a program that is not a library. 241 | 242 | 4. You may copy and distribute the Library (or a portion or 243 | derivative of it, under Section 2) in object code or executable form 244 | under the terms of Sections 1 and 2 above provided that you accompany 245 | it with the complete corresponding machine-readable source code, which 246 | must be distributed under the terms of Sections 1 and 2 above on a 247 | medium customarily used for software interchange. 248 | 249 | If distribution of object code is made by offering access to copy 250 | from a designated place, then offering equivalent access to copy the 251 | source code from the same place satisfies the requirement to 252 | distribute the source code, even though third parties are not 253 | compelled to copy the source along with the object code. 254 | 255 | 5. A program that contains no derivative of any portion of the 256 | Library, but is designed to work with the Library by being compiled or 257 | linked with it, is called a "work that uses the Library". Such a 258 | work, in isolation, is not a derivative work of the Library, and 259 | therefore falls outside the scope of this License. 260 | 261 | However, linking a "work that uses the Library" with the Library 262 | creates an executable that is a derivative of the Library (because it 263 | contains portions of the Library), rather than a "work that uses the 264 | library". The executable is therefore covered by this License. 265 | Section 6 states terms for distribution of such executables. 266 | 267 | When a "work that uses the Library" uses material from a header file 268 | that is part of the Library, the object code for the work may be a 269 | derivative work of the Library even though the source code is not. 270 | Whether this is true is especially significant if the work can be 271 | linked without the Library, or if the work is itself a library. The 272 | threshold for this to be true is not precisely defined by law. 273 | 274 | If such an object file uses only numerical parameters, data 275 | structure layouts and accessors, and small macros and small inline 276 | functions (ten lines or less in length), then the use of the object 277 | file is unrestricted, regardless of whether it is legally a derivative 278 | work. (Executables containing this object code plus portions of the 279 | Library will still fall under Section 6.) 280 | 281 | Otherwise, if the work is a derivative of the Library, you may 282 | distribute the object code for the work under the terms of Section 6. 283 | Any executables containing that work also fall under Section 6, 284 | whether or not they are linked directly with the Library itself. 285 | ^L 286 | 6. As an exception to the Sections above, you may also combine or 287 | link a "work that uses the Library" with the Library to produce a 288 | work containing portions of the Library, and distribute that work 289 | under terms of your choice, provided that the terms permit 290 | modification of the work for the customer's own use and reverse 291 | engineering for debugging such modifications. 292 | 293 | You must give prominent notice with each copy of the work that the 294 | Library is used in it and that the Library and its use are covered by 295 | this License. You must supply a copy of this License. If the work 296 | during execution displays copyright notices, you must include the 297 | copyright notice for the Library among them, as well as a reference 298 | directing the user to the copy of this License. Also, you must do one 299 | of these things: 300 | 301 | a) Accompany the work with the complete corresponding 302 | machine-readable source code for the Library including whatever 303 | changes were used in the work (which must be distributed under 304 | Sections 1 and 2 above); and, if the work is an executable linked 305 | with the Library, with the complete machine-readable "work that 306 | uses the Library", as object code and/or source code, so that the 307 | user can modify the Library and then relink to produce a modified 308 | executable containing the modified Library. (It is understood 309 | that the user who changes the contents of definitions files in the 310 | Library will not necessarily be able to recompile the application 311 | to use the modified definitions.) 312 | 313 | b) Use a suitable shared library mechanism for linking with the 314 | Library. A suitable mechanism is one that (1) uses at run time a 315 | copy of the library already present on the user's computer system, 316 | rather than copying library functions into the executable, and (2) 317 | will operate properly with a modified version of the library, if 318 | the user installs one, as long as the modified version is 319 | interface-compatible with the version that the work was made with. 320 | 321 | c) Accompany the work with a written offer, valid for at least 322 | three years, to give the same user the materials specified in 323 | Subsection 6a, above, for a charge no more than the cost of 324 | performing this distribution. 325 | 326 | d) If distribution of the work is made by offering access to copy 327 | from a designated place, offer equivalent access to copy the above 328 | specified materials from the same place. 329 | 330 | e) Verify that the user has already received a copy of these 331 | materials or that you have already sent this user a copy. 332 | 333 | For an executable, the required form of the "work that uses the 334 | Library" must include any data and utility programs needed for 335 | reproducing the executable from it. However, as a special exception, 336 | the materials to be distributed need not include anything that is 337 | normally distributed (in either source or binary form) with the major 338 | components (compiler, kernel, and so on) of the operating system on 339 | which the executable runs, unless that component itself accompanies 340 | the executable. 341 | 342 | It may happen that this requirement contradicts the license 343 | restrictions of other proprietary libraries that do not normally 344 | accompany the operating system. Such a contradiction means you cannot 345 | use both them and the Library together in an executable that you 346 | distribute. 347 | ^L 348 | 7. You may place library facilities that are a work based on the 349 | Library side-by-side in a single library together with other library 350 | facilities not covered by this License, and distribute such a combined 351 | library, provided that the separate distribution of the work based on 352 | the Library and of the other library facilities is otherwise 353 | permitted, and provided that you do these two things: 354 | 355 | a) Accompany the combined library with a copy of the same work 356 | based on the Library, uncombined with any other library 357 | facilities. This must be distributed under the terms of the 358 | Sections above. 359 | 360 | b) Give prominent notice with the combined library of the fact 361 | that part of it is a work based on the Library, and explaining 362 | where to find the accompanying uncombined form of the same work. 363 | 364 | 8. You may not copy, modify, sublicense, link with, or distribute 365 | the Library except as expressly provided under this License. Any 366 | attempt otherwise to copy, modify, sublicense, link with, or 367 | distribute the Library is void, and will automatically terminate your 368 | rights under this License. However, parties who have received copies, 369 | or rights, from you under this License will not have their licenses 370 | terminated so long as such parties remain in full compliance. 371 | 372 | 9. You are not required to accept this License, since you have not 373 | signed it. However, nothing else grants you permission to modify or 374 | distribute the Library or its derivative works. These actions are 375 | prohibited by law if you do not accept this License. Therefore, by 376 | modifying or distributing the Library (or any work based on the 377 | Library), you indicate your acceptance of this License to do so, and 378 | all its terms and conditions for copying, distributing or modifying 379 | the Library or works based on it. 380 | 381 | 10. Each time you redistribute the Library (or any work based on the 382 | Library), the recipient automatically receives a license from the 383 | original licensor to copy, distribute, link with or modify the Library 384 | subject to these terms and conditions. You may not impose any further 385 | restrictions on the recipients' exercise of the rights granted herein. 386 | You are not responsible for enforcing compliance by third parties with 387 | this License. 388 | ^L 389 | 11. If, as a consequence of a court judgment or allegation of patent 390 | infringement or for any other reason (not limited to patent issues), 391 | conditions are imposed on you (whether by court order, agreement or 392 | otherwise) that contradict the conditions of this License, they do not 393 | excuse you from the conditions of this License. If you cannot 394 | distribute so as to satisfy simultaneously your obligations under this 395 | License and any other pertinent obligations, then as a consequence you 396 | may not distribute the Library at all. For example, if a patent 397 | license would not permit royalty-free redistribution of the Library by 398 | all those who receive copies directly or indirectly through you, then 399 | the only way you could satisfy both it and this License would be to 400 | refrain entirely from distribution of the Library. 401 | 402 | If any portion of this section is held invalid or unenforceable under 403 | any particular circumstance, the balance of the section is intended to 404 | apply, and the section as a whole is intended to apply in other 405 | circumstances. 406 | 407 | It is not the purpose of this section to induce you to infringe any 408 | patents or other property right claims or to contest validity of any 409 | such claims; this section has the sole purpose of protecting the 410 | integrity of the free software distribution system which is 411 | implemented by public license practices. Many people have made 412 | generous contributions to the wide range of software distributed 413 | through that system in reliance on consistent application of that 414 | system; it is up to the author/donor to decide if he or she is willing 415 | to distribute software through any other system and a licensee cannot 416 | impose that choice. 417 | 418 | This section is intended to make thoroughly clear what is believed to 419 | be a consequence of the rest of this License. 420 | 421 | 12. If the distribution and/or use of the Library is restricted in 422 | certain countries either by patents or by copyrighted interfaces, the 423 | original copyright holder who places the Library under this License 424 | may add an explicit geographical distribution limitation excluding those 425 | countries, so that distribution is permitted only in or among 426 | countries not thus excluded. In such case, this License incorporates 427 | the limitation as if written in the body of this License. 428 | 429 | 13. The Free Software Foundation may publish revised and/or new 430 | versions of the Lesser General Public License from time to time. 431 | Such new versions will be similar in spirit to the present version, 432 | but may differ in detail to address new problems or concerns. 433 | 434 | Each version is given a distinguishing version number. If the Library 435 | specifies a version number of this License which applies to it and 436 | "any later version", you have the option of following the terms and 437 | conditions either of that version or of any later version published by 438 | the Free Software Foundation. If the Library does not specify a 439 | license version number, you may choose any version ever published by 440 | the Free Software Foundation. 441 | ^L 442 | 14. If you wish to incorporate parts of the Library into other free 443 | programs whose distribution conditions are incompatible with these, 444 | write to the author to ask for permission. For software which is 445 | copyrighted by the Free Software Foundation, write to the Free 446 | Software Foundation; we sometimes make exceptions for this. Our 447 | decision will be guided by the two goals of preserving the free status 448 | of all derivatives of our free software and of promoting the sharing 449 | and reuse of software generally. 450 | 451 | NO WARRANTY 452 | 453 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 454 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 455 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 456 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 457 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 458 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 459 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 460 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 461 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 462 | 463 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 464 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 465 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 466 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 467 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 468 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 469 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 470 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 471 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 472 | DAMAGES. 473 | 474 | END OF TERMS AND CONDITIONS 475 | ^L 476 | How to Apply These Terms to Your New Libraries 477 | 478 | If you develop a new library, and you want it to be of the greatest 479 | possible use to the public, we recommend making it free software that 480 | everyone can redistribute and change. You can do so by permitting 481 | redistribution under these terms (or, alternatively, under the terms 482 | of the ordinary General Public License). 483 | 484 | To apply these terms, attach the following notices to the library. 485 | It is safest to attach them to the start of each source file to most 486 | effectively convey the exclusion of warranty; and each file should 487 | have at least the "copyright" line and a pointer to where the full 488 | notice is found. 489 | 490 | 491 | 492 | Copyright (C) 493 | 494 | This library is free software; you can redistribute it and/or 495 | modify it under the terms of the GNU Lesser General Public 496 | License as published by the Free Software Foundation; either 497 | version 2.1 of the License, or (at your option) any later version. 498 | 499 | This library is distributed in the hope that it will be useful, 500 | but WITHOUT ANY WARRANTY; without even the implied warranty of 501 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 502 | Lesser General Public License for more details. 503 | 504 | You should have received a copy of the GNU Lesser General Public 505 | License along with this library; if not, write to the Free Software 506 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 507 | 508 | Also add information on how to contact you by electronic and paper mail. 509 | 510 | You should also get your employer (if you work as a programmer) or 511 | your school, if any, to sign a "copyright disclaimer" for the library, 512 | if necessary. Here is a sample; alter the names: 513 | 514 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 515 | library `Frob' (a library for tweaking knobs) written by James 516 | Random Hacker. 517 | 518 | , 1 April 1990 519 | Ty Coon, President of Vice 520 | 521 | That's all there is to it! 522 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build @install @runtest 3 | 4 | clean: 5 | dune clean 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **ocaml-sqlexpr** is a simple library and syntax extension for type-safe, 2 | convenient execution of SQL statements, currently compatible with Sqlite3. 3 | 4 | The latest version can be found at https://github.com/mfp/ocaml-sqlexpr 5 | 6 | **ocaml-sqlexpr** features: 7 | * automated prepared statement caching, parameter binding, data extraction, error 8 | checking (including automatic statement reset to avoid BUSY/LOCKED errors in 9 | subsequent queries), statement finalization on database close, etc. 10 | * higher order functions like *iter*, *fold*, *transaction* 11 | * support for different concurrency models: everything is functorized over a 12 | THREAD monad, so you can for instance do concurrent treatmments with Lwt 13 | * support for SQL statement syntax checks and some extra semantic checking (column 14 | names, etc.) 15 | 16 | **ocaml-sqlexpr** is used as follows: 17 | 18 | ```ocaml 19 | module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) 20 | module S = Sqlexpr 21 | 22 | let () = 23 | let db = S.open_db "foo.db" in 24 | S.iter db 25 | (fun (n, p) -> Printf.printf "User %S, password %S\n" n p) 26 | sqlc"SELECT @s{login}, @s{password} FROM users"; 27 | List.iter 28 | (fun (n, p) -> S.execute db sqlc"INSERT INTO users VALUES(%s, %s)" n p) 29 | [ 30 | "coder24", "badpass"; 31 | "tokyo3", "12345" 32 | ] 33 | ``` 34 | 35 | See also the example file `example.ml`. 36 | 37 | 38 | ## Dependencies 39 | 40 | * cppo 41 | * csv 42 | * lwt (>= 2.2.0) 43 | * lwt.syntax 44 | * lwt.unix 45 | * ppx_tools 46 | * re 47 | * sqlite3 48 | * threads 49 | * unix 50 | 51 | ## Optional Dependencies 52 | 53 | * camlp4 54 | * estring 55 | 56 | The optional dependencies allow building of the Camlp4 syntax extension. 57 | 58 | ## Camlp4 syntax extension 59 | 60 | **ocaml-sqlexpr** includes a syntax extension to build type-safe SQL 61 | statements and expressions: 62 | 63 | 64 | - `sql"..."` denotes a SQL statement or expression 65 | - `sqlc"..."` denotes a SQL statement or expression that is to be cached 66 | - `sql_check"sqlite"` returns a tuple of functions to initialize, check the 67 | validity of the SQL statements or expressions and 68 | check against an auto-initialized temporary database. 69 | - `sqlinit"..."` is equivalent to `sql"..."`, but the statement will be added 70 | to the list of statements to be executed in the automatically 71 | generated initialization function 72 | 73 | `sql_check"sqlite"` is used as follows: 74 | 75 | ```ocaml 76 | let auto_init_db, check_db, auto_check_db = sql_check"sqlite" 77 | ``` 78 | 79 | which creates 3 functions 80 | 81 | ```ocaml 82 | val auto_init_db : Sqlite3.db -> Format.formatter -> bool 83 | val check_db : Sqlite3.db -> Format.formatter -> bool 84 | val auto_check_db : Format.formatter -> bool 85 | ``` 86 | 87 | each of them returns `false` on error, and writes the error messages to the 88 | provided formatter. 89 | 90 | 91 | ## PPX syntax extension 92 | 93 | In addition to the camlp4-based syntax extension, **ocaml-sqlexpr** includes a 94 | syntax extension using extension points (ppx). The conversion from camlp4 to 95 | ppx is as follows: 96 | 97 | - `[%sql "..."]` corresponds to `sql"..."` 98 | - `[%sqlc "..."]` corresponds to `sqlc"..."` 99 | - `[%sqlcheck "sqlite"]` corresponds to `sql_check"sqlite"` 100 | - `[%sqlinit "..."]` corresponds to `sqlinit"..."` 101 | 102 | 103 | ## SQL statement/expression syntax 104 | 105 | Literals marked with `sql` or `sqlc` are similar to Printf's format strings and their precise 106 | types depend on their contents. They accept input parameters (similarly to 107 | Printf) and, in the case of SQL expressions, their execution will yield a 108 | tuple whose type is determined by the output parameters. 109 | 110 | Input parameters are denoted with `%X` where `X` is one of: 111 | 112 | Input parameter | OCaml type 113 | -----------------|----------- 114 | %d | int 115 | %l | Int32.t 116 | %L | Int64.t 117 | %s | string 118 | %S | string (handled as BLOB by SQLite) 119 | %f | float 120 | %b | bool 121 | %a | ('a -> string) (resulting string handled as BLOB by SQLite) 122 | 123 | A literal `%` is denoted with `%%`. 124 | 125 | A parameter is made nullable (turning the OCaml type into a `_ option`) by 126 | appending a `?`, e.g. `%d?`. 127 | 128 | Output parameters are denoted with `@X{SQL expression}` where `X` is one of: 129 | 130 | Output parameter | OCaml type 131 | ---------------- | ---------- 132 | @d | int 133 | @l | Int32.t 134 | @L | Int64.t 135 | @s | string 136 | @S | string (handled as BLOB by SQLite) 137 | @f | float 138 | @b | bool 139 | 140 | A literal `@` is denoted with `@@` 141 | As in the case of input parameters, output parameters can be made nullable by 142 | appending a `?`. 143 | 144 | A `sql"..."` or `sqlc"..."` literal is of type `_ statement` if it has no output 145 | parameters, and of type `_ expression` if it has at least one. 146 | 147 | 148 | ### Examples 149 | 150 | ```ocaml 151 | sql"SELECT @s{name} FROM users" is an expression 152 | sql"SELECT @s{name} FROM users WHERE id = %d" is an expression 153 | sql"SELECT @s{name}, @s{email} FROM users" is an expression 154 | sql"DELETE FROM users WHERE id = %d" is a statement 155 | ``` 156 | 157 | Statements are executed with `execute` or `insert` (which returns the id of 158 | the new row); expressions are “selected” with a function from the `select*` 159 | family or a higher order function like `iter` or `fold`. 160 | 161 | 162 | ### Examples 163 | 164 | ```ocaml 165 | module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) 166 | module S = Sqlexpr 167 | 168 | let insert_user_stmt = 169 | sqlc"INSERT INTO users(login, password, email) VALUES(%s, %s, %s?)" 170 | 171 | let insert_user db ~login ?email ~password = 172 | S.execute db insert_user_stmt login password email 173 | 174 | (* insert user and return ID; we use partial application here *) 175 | let new_user_id db = S.insert db insert_user_stmt 176 | 177 | let get_password db = 178 | S.select_one db sqlc"SELECT @s{password} FROM users WHERE login = %s" 179 | 180 | let get_email db = 181 | S.select_one db sqlc"SELECT @s?{email} FROM users WHERE login = %s" 182 | 183 | let iter_users db f = 184 | S.iter db f sqlc"SELECT @L{id}, @s{login}, @s{password}, @s?{email} 185 | FROM users" 186 | ``` 187 | 188 | ### Test and Sample Build Instructions 189 | 190 | Example Camlp4 Code: 191 | ``` 192 | ocamlfind ocamlc -package sqlexpr,pa_sqlexpr -syntax camlp4o -linkpkg -thread -o sqlexpr_camlp4 tests/syntax/example.ml 193 | ``` 194 | 195 | Example PPX Code 196 | ``` 197 | ocamlfind ocamlc -package sqlexpr.ppx -linkpkg -thread -o sqlexpr_ppx tests/ppx/example.ml 198 | ``` 199 | or 200 | ``` 201 | dune build tests/ppx/example.exe 202 | ``` 203 | 204 | Camlp4 based tests: 205 | ``` 206 | ocamlfind ocamlc -package sqlexpr,pa_sqlexpr,lwt.syntax,oUnit -syntax camlp4o -linkpkg -thread -o sqlexpr_camlp4_test tests/syntax/t_sqlexpr.ml 207 | ``` 208 | 209 | PPX based tests: 210 | ``` 211 | ocamlfind ocamlc -package sqlexpr.ppx,lwt_ppx,oUnit -ppxopt lwt_ppx,-no-debug -linkpkg -thread -o sqlexpr_ppx_test tests/ppx/t_sqlexpr.ml 212 | ``` 213 | or 214 | ``` 215 | dune runtest ./tests/ppx 216 | ``` 217 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | -------------------------------------------------------------------------------- /pa_sqlexpr.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "mfp@acm.org" 3 | authors: ["Mauricio Fernandez "] 4 | license: "LGPL-2.1 with OCaml linking exception" 5 | homepage: "http://github.com/mfp/ocaml-sqlexpr" 6 | dev-repo: "https://github.com/mfp/ocaml-sqlexpr.git" 7 | bug-reports: "https://github.com/mfp/ocaml-sqlexpr/issues" 8 | build: [ 9 | [ "dune" "build" "-p" name "-j" jobs ] 10 | ] 11 | depends: [ 12 | "dune" {build & >= "1.1.1"} 13 | "sqlexpr" 14 | "estring" 15 | "camlp4" 16 | ] 17 | -------------------------------------------------------------------------------- /ppx_sqlexpr.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "mfp@acm.org" 3 | authors: ["Mauricio Fernandez "] 4 | license: "LGPL-2.1 with OCaml linking exception" 5 | homepage: "http://github.com/mfp/ocaml-sqlexpr" 6 | dev-repo: "https://github.com/mfp/ocaml-sqlexpr.git" 7 | bug-reports: "https://github.com/mfp/ocaml-sqlexpr/issues" 8 | doc: "doc" 9 | build: [ 10 | [ "dune" "build" "-p" name "-j" jobs ] 11 | ] 12 | build-test: [["dune" "runtest" "-p" name "-j" jobs]] 13 | depends: [ 14 | "dune" {build & >= "1.1.1"} 15 | "ppx_tools_versioned" 16 | "ppx_core" 17 | "ocaml-migrate-parsetree" 18 | "base-unix" 19 | "re" {build & >= "1.7.2"} 20 | "ounit" {test} 21 | "lwt" {test} 22 | ] 23 | -------------------------------------------------------------------------------- /sqlexpr.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "mfp@acm.org" 3 | authors: ["Mauricio Fernandez "] 4 | license: "LGPL-2.1 with OCaml linking exception" 5 | homepage: "http://github.com/mfp/ocaml-sqlexpr" 6 | dev-repo: "https://github.com/mfp/ocaml-sqlexpr.git" 7 | bug-reports: "https://github.com/mfp/ocaml-sqlexpr/issues" 8 | available: ocaml-version >= "4.02.0" 9 | build: [ 10 | [ "env" "ESTRING=%{estring:enable}%" "dune" "build" "-p" name "-j" jobs ] 11 | ] 12 | depends: [ 13 | "dune" {build & >= "1.1.1"} 14 | "csv" 15 | "lwt" {>= "2.2.0"} 16 | "lwt_ppx" {build} 17 | ("sqlite3" {>= "2.0.4"} | "sqlite3" {= "2.0.3"}) 18 | "base-unix" 19 | "ppx_sqlexpr" 20 | ] 21 | depopts: [ "estring" ] 22 | 23 | messages: [ 24 | "For the PPX syntax extension, install package ppx_sqlexpr" 25 | {!ppx_sqlexpr:installed} 26 | "For the Camlp4 syntax extension, install package pa_sqlexpr" 27 | {!pa_sqlexpr:installed} 28 | ] 29 | post-messages: [ 30 | "The sqlexpr.ppx and sqlexpr.syntax package aliases have been dropped. 31 | Switch to ppx_sqlexpr and pa_sqlexpr." 32 | ] 33 | -------------------------------------------------------------------------------- /sqlexpr.syntax.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "mfp@acm.org" 3 | authors: ["Mauricio Fernandez "] 4 | license: "LGPL-2.1 with OCaml linking exception" 5 | homepage: "http://github.com/mfp/ocaml-sqlexpr" 6 | dev-repo: "https://github.com/mfp/ocaml-sqlexpr.git" 7 | bug-reports: "https://github.com/mfp/ocaml-sqlexpr/issues" 8 | build: [ 9 | [ "env" "ESTRING=%{estring:enable}%" "dune" "build" "-p" name "-j" jobs ] 10 | ] 11 | depends: [ 12 | "dune" {build & >= "1.1.1"} 13 | "csv" 14 | "lwt" {>= "2.2.0"} 15 | ("sqlite3" {>= "2.0.4"} | "sqlite3" {= "2.0.3"}) 16 | "base-unix" 17 | ] 18 | 19 | messages: [ 20 | "For the PPX syntax extension, install package ppx_sqlexpr" 21 | {!ppx_sqlexpr:installed} 22 | "For the Camlp4 syntax extension, install package pa_sqlexpr" 23 | {!pa_sqlexpr:installed} 24 | ] 25 | -------------------------------------------------------------------------------- /src/OMakefile: -------------------------------------------------------------------------------- 1 | .SUBDIRS: syntax 2 | unsetenv(OCAMLFIND_TOOLCHAIN) 3 | OCAMLFINDFLAGS = -syntax camlp4o 4 | NATIVE_ENABLED = false 5 | OCAMLPACKS[] = estring camlp4.quotations 6 | pa_sql.cmi pa_sql.cmo: pa_sql.ml 7 | 8 | .SUBDIRS: ppx 9 | BYTE_ENABLED = false 10 | unsetenv(OCAMLFIND_TOOLCHAIN) 11 | OCAMLPACKS[] = compiler-libs.common ocaml-migrate-parsetree ppx_tools_versioned ppx_core re.pcre unix ppx_tools_versioned.metaquot_403 12 | OCAML_LINK_FLAGS += $(shell $(OCAMLFIND) query -predicates "archive,native" -a-format ocaml-migrate-parsetree.driver-main) 13 | OCamlProgram(ppx_sqlexpr, sqlexpr_parser ppx_sqlexpr) 14 | 15 | .SCANNER: scan-ocaml-%.ml: %.ml syntax/pa_sql.cmo 16 | .SCANNER: scan-ocaml-%.mli: %.mli syntax/pa_sql.cmo 17 | 18 | OCamlLibrary(sqlexpr, sqlexpr_utils sqlexpr_concurrency sqlexpr_sqlite sqlexpr_sqlite_lwt) 19 | 20 | .DEFAULT: syntax/pa_sql.cmo ppx/ppx_sqlexpr sqlexpr.cma sqlexpr.cmxa 21 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name sqlexpr) 3 | (public_name sqlexpr) 4 | (synopsis "SQLite database access.") 5 | (wrapped false) 6 | (flags (:standard -w -9-3)) 7 | (libraries csv sqlite3 lwt lwt.unix unix threads) 8 | (preprocess (pps lwt_ppx))) 9 | -------------------------------------------------------------------------------- /src/ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_sqlexpr) 3 | (public_name ppx_sqlexpr) 4 | (synopsis "Sqlexpr PPX syntax extension") 5 | (wrapped false) 6 | (kind ppx_rewriter) 7 | (flags (:standard -w -9)) 8 | (libraries ppx_core unix re.pcre compiler-libs.common 9 | ocaml-migrate-parsetree ppx_tools_versioned) 10 | (preprocess (pps ppx_tools_versioned.metaquot_403))) 11 | -------------------------------------------------------------------------------- /src/ppx/ppx_sqlexpr.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree 2 | open OCaml_403.Ast 3 | open Ast_mapper 4 | open Ast_helper 5 | open Asttypes 6 | open Parsetree 7 | 8 | module AC = Ast_convenience_403 9 | 10 | let new_id = 11 | let n = ref 0 in 12 | fun () -> 13 | incr n; 14 | Printf.sprintf "__ppx_sql_%d" !n 15 | 16 | let gen_stmt ~cacheable sql inp = 17 | let mkapply s args = 18 | let txt = Longident.(Ldot (Ldot (Lident "Sqlexpr", "Directives"), s)) in 19 | let fn = Exp.ident { txt; loc = !default_loc } in 20 | AC.app fn args in 21 | 22 | let k = new_id () in 23 | let st = new_id () in 24 | let id = 25 | let signature = 26 | Printf.sprintf "%d-%f-%d-%S" 27 | Unix.(getpid ()) (Unix.gettimeofday ()) (Random.int 0x3FFFFFF) sql 28 | in Digest.to_hex (Digest.string signature) in 29 | let stmt_id = 30 | if cacheable 31 | then [%expr Some [%e AC.str id ]] 32 | else [%expr None] in 33 | let exp = List.fold_right (fun elem dir -> 34 | let typ = Sqlexpr_parser.in_type2str elem in 35 | [%expr [%e mkapply typ [dir]]]) 36 | inp 37 | [%expr [%e AC.evar k]] in 38 | let dir = [%expr fun [%p AC.pvar k] -> fun [%p AC.pvar st] -> 39 | [%e exp] [%e AC.evar st] 40 | ] in 41 | [%expr { 42 | Sqlexpr.sql_statement = [%e AC.str sql]; 43 | stmt_id = [%e stmt_id]; 44 | directive = [%e dir]; 45 | }] 46 | 47 | let gen_expr ~cacheable sql inp outp = 48 | let stmt = gen_stmt ~cacheable sql inp in 49 | let id = new_id () in 50 | let conv s = Longident.(Ldot (Ldot (Lident "Sqlexpr", "Conversion"), s)) in 51 | let conv_exprs = List.mapi (fun i elem -> 52 | let txt = conv (Sqlexpr_parser.out_type2str elem) in 53 | let fn = Exp.ident {txt; loc=(!default_loc)} in 54 | let args = [%expr Array.get [%e AC.evar id] [%e AC.int i]] in 55 | AC.app fn [args]) outp in 56 | let tuple_func = 57 | let e = match conv_exprs with 58 | [] -> assert false 59 | | [x] -> x 60 | | _ -> Exp.tuple conv_exprs in 61 | [%expr fun [%p AC.pvar id] -> [%e e]] in 62 | [%expr { 63 | Sqlexpr.statement = [%e stmt]; 64 | get_data = ([%e AC.int (List.length outp)], [%e tuple_func]); 65 | }] 66 | 67 | let stmts = ref [] 68 | let init_stmts = ref [] 69 | 70 | let gen_sql ?(init=false) ?(cacheable=false) str = 71 | let (sql, inp, outp) = Sqlexpr_parser.parse str in 72 | 73 | (* accumulate statements *) 74 | if init 75 | then init_stmts := sql :: !init_stmts 76 | else stmts := sql :: !stmts; 77 | 78 | if [] = outp 79 | then gen_stmt ~cacheable sql inp 80 | else gen_expr ~cacheable sql inp outp 81 | 82 | let sqlcheck_sqlite () = 83 | let mkstr s = Exp.constant (Pconst_string (s, None)) in 84 | let statement_check = [%expr 85 | try ignore(Sqlite3.prepare db stmt) 86 | with Sqlite3.Error s -> 87 | ret := false; 88 | Format.fprintf fmt "Error in statement %S: %s\n" stmt s 89 | ] in 90 | let stmt_expr_f acc elem = [%expr [%e mkstr elem] :: [%e acc]] in 91 | let stmt_exprs = List.fold_left stmt_expr_f [%expr []] !stmts in 92 | let init_exprs = List.fold_left stmt_expr_f [%expr []] !init_stmts in 93 | let check_db_expr = [%expr fun db fmt -> 94 | let ret = ref true in 95 | List.iter (fun stmt -> [%e statement_check]) [%e stmt_exprs]; 96 | !ret 97 | ] in 98 | let init_db_expr = [%expr fun db fmt -> 99 | let ret = ref true in 100 | List.iter (fun stmt -> match Sqlite3.exec db stmt with 101 | | Sqlite3.Rc.OK -> () 102 | | _rc -> begin 103 | ret := false; 104 | Format.fprintf fmt "Error in init. SQL statement (%s)@ %S@\n" 105 | (Sqlite3.errmsg db) stmt 106 | end) [%e init_exprs]; 107 | !ret 108 | ] in 109 | let in_mem_check_expr = [%expr fun fmt -> 110 | let db = Sqlite3.db_open ":memory:" in 111 | init_db db fmt && check_db db fmt 112 | ] in 113 | [%expr 114 | let init_db = [%e init_db_expr] in 115 | let check_db = [%e check_db_expr] in 116 | let in_mem_check = [%e in_mem_check_expr] in 117 | (init_db, check_db, in_mem_check) 118 | ] 119 | 120 | let call fn loc = function 121 | | PStr [ {pstr_desc = Pstr_eval ( 122 | { pexp_desc = Pexp_constant(Pconst_string(sym, _))}, _)} ] -> 123 | with_default_loc loc (fun () -> fn sym) 124 | | _ -> raise (Location.Error(Location.error ~loc ( 125 | "sqlexpr extension accepts a string"))) 126 | 127 | let call_sqlcheck loc = function 128 | | PStr [ {pstr_desc = Pstr_eval ({ pexp_desc = 129 | Pexp_constant(Pconst_string("sqlite", None))}, _)}] -> 130 | with_default_loc loc sqlcheck_sqlite 131 | | _ -> raise (Location.Error(Location.error ~loc ( 132 | "sqlcheck extension accepts \"sqlite\""))) 133 | 134 | let shared_exprs = Hashtbl.create 25 135 | 136 | let shared_expr_id = function 137 | | Pexp_ident {txt} -> 138 | let id = Longident.last txt in 139 | if Hashtbl.mem shared_exprs id then Some id else None 140 | | _ -> None 141 | 142 | let register_shared_expr = 143 | let n = ref 0 in 144 | fun expr -> 145 | let id = "__ppx_sqlexpr_shared_" ^ string_of_int !n in 146 | incr n; 147 | Hashtbl.add shared_exprs id expr; 148 | id 149 | 150 | let get_shared_expr = Hashtbl.find shared_exprs 151 | 152 | (* We replace Ppx_core.Ast_traverse.fold with this inelegant fold for 153 | * compatibility with 4.02. *) 154 | let shared_exprs expr = 155 | let ret = ref [] in 156 | let mapper = 157 | { 158 | Ast_mapper.default_mapper with 159 | expr = begin fun mapper expr -> 160 | let x = default_mapper.Ast_mapper.expr mapper expr in 161 | begin match shared_expr_id expr.pexp_desc with 162 | | Some id -> ret := id :: !ret 163 | | None -> () 164 | end; 165 | x 166 | end; 167 | } 168 | in 169 | ignore (mapper.expr mapper expr); 170 | !ret 171 | 172 | let map_expr mapper loc expr = 173 | let expr = mapper.Ast_mapper.expr mapper expr in 174 | let ids = shared_exprs expr in 175 | with_default_loc loc (fun () -> 176 | List.fold_left (fun acc id -> 177 | [%expr let [%p AC.pvar id] = [%e get_shared_expr id] in [%e acc]]) 178 | expr ids) 179 | 180 | let sqlexpr_mapper = 181 | Ast_mapper.({ 182 | default_mapper with 183 | expr = (fun mapper expr -> 184 | match expr with 185 | (* is this an extension node? *) 186 | | {pexp_desc = Parsetree.Pexp_extension ({txt = "sql"; loc}, pstr)} -> 187 | call gen_sql loc pstr 188 | | {pexp_desc = Parsetree.Pexp_extension ({txt = "sqlc"; loc}, pstr)} -> 189 | let expr = call (gen_sql ~cacheable:true) loc pstr in 190 | let id = register_shared_expr expr in 191 | Exp.ident ~loc {txt=Longident.Lident id; loc} 192 | | {pexp_desc = Parsetree.Pexp_extension ({txt = "sqlinit"; loc}, pstr)} -> 193 | call (gen_sql ~init:true) loc pstr 194 | | {pexp_desc = Parsetree.Pexp_extension ({txt = "sqlcheck"; loc}, pstr)} -> 195 | call_sqlcheck loc pstr 196 | (* Delegate to the default mapper *) 197 | | x -> default_mapper.expr mapper x); 198 | structure_item = (fun mapper structure_item -> 199 | match structure_item with 200 | | {pstr_desc = Pstr_value (rec_flag, value_bindings); pstr_loc} -> 201 | (* since structure_item gets mapped before expr, need to preemptively 202 | * apply our expr mapping to the value_bindings to resolve extensions *) 203 | let es = List.map (fun x -> map_expr mapper pstr_loc x.pvb_expr) value_bindings in 204 | let vbs = List.map2 (fun x y -> {x with pvb_expr = y}) value_bindings es in 205 | { structure_item with pstr_desc = Pstr_value (rec_flag, vbs)} 206 | | x -> default_mapper.structure_item mapper x); 207 | }) 208 | 209 | let () = 210 | Random.self_init (); 211 | Driver.register ~name:"ppx_sqlexpr" 212 | Versions.ocaml_403 213 | (fun _ _ -> sqlexpr_mapper) 214 | -------------------------------------------------------------------------------- /src/ppx/sqlexpr_parser.ml: -------------------------------------------------------------------------------- 1 | type typ = Int | Int32 | Int64 | Float | Text | Blob | Bool | Any 2 | type input = typ * bool 3 | type output = string * typ * bool 4 | 5 | let str2typ = function 6 | | "d" -> Int 7 | | "l" -> Int32 8 | | "L" -> Int64 9 | | "f" -> Float 10 | | "s" -> Text 11 | | "S" -> Blob 12 | | "b" -> Bool 13 | | "a" -> Any 14 | | _ -> failwith "Invalid type" 15 | 16 | let typ2str = function 17 | | Int -> "int" 18 | | Int32 -> "int32" 19 | | Int64 -> "int64" 20 | | Float -> "float" 21 | | Text -> "text" 22 | | Blob -> "blob" 23 | | Bool -> "bool" 24 | | Any -> "any" 25 | 26 | let in_type2str ((typ, optional) : input) = 27 | let typ = typ2str typ in 28 | if optional then "maybe_" ^ typ else typ 29 | 30 | let out_type2str ((_, typ, optional) : output) = 31 | in_type2str (typ, optional) 32 | 33 | let parse str = 34 | (* grievous hack to escape everything within quotes *) 35 | (* what about ignoring \' or \" ? " *) 36 | (* manually escape "" because {| ... |} notation breaks syntax highlighting *) 37 | let escrgx = Re.Pcre.regexp "('[^']*')|(\"[^\"]*\")" in 38 | let esc_list = ref [] in 39 | let esc_str = "" in 40 | let esc_subst substrings = 41 | let mtch = Re.get substrings 0 in 42 | esc_list := mtch :: !esc_list; 43 | esc_str in 44 | 45 | let escaped = Re.replace ~f:esc_subst escrgx str in 46 | esc_list := List.rev !esc_list; 47 | 48 | (* logic to extract inputs and outputs *) 49 | let inrgx = Re.Pcre.regexp {|%([dlLfsSba])(\?)?|} in 50 | let outrgx = Re.Pcre.regexp {|@([dlLfsSba])(\?)?\{([^}]+)\}|} in 51 | let getin (acc : input list) s = 52 | let groups = Re.get_all s in 53 | let typ = Array.get groups 1 |> str2typ in 54 | let optional = "?" = Array.get groups 2 in 55 | let res = typ, optional in 56 | res::acc in 57 | let getout (acc : output list) s = 58 | let groups = Re.get_all s in 59 | let typ = Array.get groups 1 |> str2typ in 60 | let optional = "?" = Array.get groups 2 in 61 | let name = Array.get groups 3 |> String.trim in 62 | let res = name, typ, optional in 63 | res::acc in 64 | 65 | (* execute extractions *) 66 | let ins = Re.all inrgx escaped |> List.fold_left getin [] |> List.rev in 67 | let outs = Re.all outrgx escaped |> List.fold_left getout [] |> List.rev in 68 | 69 | (* replace input and output params with regular SQL *) 70 | let in_subst _substrs = "?" in 71 | 72 | let rep_count_out = ref 0 in 73 | let out_subst _substrs = 74 | let (name, _,_) = List.nth outs !rep_count_out in 75 | incr rep_count_out; 76 | name in 77 | 78 | (* now restore the escaped strings *) 79 | let rep_esc_count = ref 0 in 80 | let unesc_subst _substrs = 81 | let restore = List.nth !esc_list !rep_esc_count in 82 | incr rep_esc_count; 83 | restore in 84 | 85 | (* generate final sql *) 86 | let sql = 87 | Re.replace ~f:out_subst outrgx escaped 88 | |> Re.replace ~f:in_subst inrgx 89 | |> Re.replace ~f:unesc_subst (Re.Pcre.regexp esc_str) in 90 | 91 | (* final return *) 92 | (sql, ins, outs) 93 | -------------------------------------------------------------------------------- /src/sqlexpr_concurrency.ml: -------------------------------------------------------------------------------- 1 | 2 | module type THREAD_LOCAL_STATE = 3 | sig 4 | type 'a t 5 | type 'a key 6 | val new_key : unit -> 'a key 7 | val get : 'a key -> 'a option 8 | val with_value : 'a key -> 'a option -> (unit -> 'b t) -> 'b t 9 | end 10 | 11 | module type THREAD = 12 | sig 13 | type 'a t 14 | val return : 'a -> 'a t 15 | val bind : 'a t -> ('a -> 'b t) -> 'b t 16 | val try_bind: (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t 17 | val fail : exn -> 'a t 18 | val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t 19 | val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t 20 | val sleep : float -> unit t 21 | val auto_yield : float -> (unit -> unit t) 22 | 23 | val backtrace_bind: (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t 24 | val backtrace_catch: (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t 25 | val backtrace_finalize: (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t 26 | val backtrace_try_bind: (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t 27 | 28 | type mutex 29 | 30 | val create_recursive_mutex : unit -> mutex 31 | val with_lock : mutex -> (unit -> 'a t) -> 'a t 32 | 33 | val register_finaliser : ('a -> unit t) -> 'a -> unit 34 | 35 | include THREAD_LOCAL_STATE with type 'a t := 'a t 36 | end 37 | 38 | module Id = 39 | struct 40 | type 'a t = 'a 41 | let return x = x 42 | let bind x f = f x 43 | let fail = raise 44 | 45 | let catch f g = try f () with e -> g e 46 | 47 | let finalize f g = 48 | match try `Ok (f ()) with e -> `Exn e with 49 | `Ok x -> g (); x 50 | | `Exn e -> g (); raise e 51 | 52 | let sleep dt = let _, _, _ = Unix.select [] [] [] dt in () 53 | 54 | let auto_yield _ = (fun () -> ()) 55 | 56 | type mutex = unit 57 | let create_recursive_mutex () = () 58 | let with_lock () f = f () 59 | 60 | type 'a key = 'a Lwt.key 61 | 62 | let new_key = Lwt.new_key 63 | let get = Lwt.get 64 | let with_value = Lwt.with_value 65 | 66 | let try_bind f f' catch = 67 | match f () with 68 | | exception e -> catch e 69 | | x -> f' x 70 | 71 | let backtrace_bind g x f = 72 | try f x 73 | with e -> raise (g e) 74 | 75 | let backtrace_catch g f catch = 76 | try f () 77 | with e -> catch (g e) 78 | 79 | let backtrace_finalize g f finally = 80 | match f () with 81 | | exception e -> finally (); raise (g e) 82 | | x -> 83 | finally (); 84 | x 85 | 86 | let backtrace_try_bind g f f' catch = 87 | match f () with 88 | | exception e -> catch (g e) 89 | | x -> f' x 90 | 91 | let register_finaliser f x = 92 | (* FIXME: should run finalisers sequentially in separate thread *) 93 | Gc.finalise f x 94 | end 95 | 96 | 97 | module Lwt = 98 | struct 99 | include Lwt 100 | let auto_yield = Lwt_unix.auto_yield 101 | let sleep = Lwt_unix.sleep 102 | 103 | type mutex = { id : int; m : Lwt_mutex.t } 104 | 105 | let new_id = let n = ref 0 in (fun () -> incr n; !n) 106 | 107 | module LOCKS = Set.Make(struct 108 | type t = int 109 | let compare (x : int) y = 110 | if x < y then -1 else if x > y then 1 else 0 111 | end) 112 | let locks = Lwt.new_key () 113 | 114 | let create_recursive_mutex () = { id = new_id (); m = Lwt_mutex.create () } 115 | 116 | let with_lock m f = 117 | match Lwt.get locks with 118 | None -> 119 | Lwt_mutex.with_lock m.m 120 | (fun () -> Lwt.with_value locks (Some (LOCKS.singleton m.id)) f) 121 | | Some s when LOCKS.mem m.id s -> f () 122 | | Some s -> 123 | Lwt_mutex.with_lock m.m 124 | (fun () -> Lwt.with_value locks (Some (LOCKS.add m.id s)) f) 125 | 126 | let register_finaliser = Lwt_gc.finalise 127 | 128 | let fail e = fail (try raise e with exn -> exn) 129 | end 130 | 131 | -------------------------------------------------------------------------------- /src/sqlexpr_concurrency.mli: -------------------------------------------------------------------------------- 1 | (** Concurrency monad. *) 2 | 3 | (** Thread local state. *) 4 | module type THREAD_LOCAL_STATE = 5 | sig 6 | type 'a t 7 | type 'a key 8 | val new_key : unit -> 'a key 9 | val get : 'a key -> 'a option 10 | val with_value : 'a key -> 'a option -> (unit -> 'b t) -> 'b t 11 | end 12 | 13 | (** The THREAD monad. *) 14 | module type THREAD = 15 | sig 16 | type 'a t 17 | val return : 'a -> 'a t 18 | val bind : 'a t -> ('a -> 'b t) -> 'b t 19 | val try_bind: (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t 20 | val fail : exn -> 'a t 21 | val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t 22 | val finalize : (unit -> 'a t) -> (unit -> unit t) -> 'a t 23 | val sleep : float -> unit t 24 | val auto_yield : float -> unit -> unit t 25 | 26 | val backtrace_bind: (exn -> exn) -> 'a t -> ('a -> 'b t) -> 'b t 27 | val backtrace_catch: (exn -> exn) -> (unit -> 'a t) -> (exn -> 'a t) -> 'a t 28 | val backtrace_finalize: (exn -> exn) -> (unit -> 'a t) -> (unit -> unit t) -> 'a t 29 | val backtrace_try_bind: (exn -> exn) -> (unit -> 'a t) -> ('a -> 'b t) -> (exn -> 'b t) -> 'b t 30 | 31 | type mutex 32 | 33 | (** Create a recursive mutex that can be locked recursively by the same 34 | * thread; i.e., unlike a regular mutex, 35 | * [with_lock m (fun () -> ... with_lock m (fun () -> ... ))] 36 | * will not block. *) 37 | val create_recursive_mutex : unit -> mutex 38 | 39 | (* [with_lock m f] blocks until the [m] mutex can be locked, runs [f ()] and 40 | * unlocks the mutex (also if [f ()] raises an exception) *) 41 | val with_lock : mutex -> (unit -> 'a t) -> 'a t 42 | 43 | val register_finaliser : ('a -> unit t) -> 'a -> unit 44 | 45 | include THREAD_LOCAL_STATE with type 'a t := 'a t 46 | end 47 | 48 | (** Identity concurrency monad. Note that [Id.mutex] is a dummy type that 49 | * doesn't actually work like a mutex (i.e., [Id.with_lock m f] is equivalent 50 | * to [f ()]. This is so because in ocaml-sqlexpr's context [Sqlite] handles 51 | * can only be used from the thread where they were created, so there's no 52 | * need for mutual exclusion because trying to use the same handle from 53 | * different threads would be an error anyway. *) 54 | module Id : THREAD with type 'a t = 'a and type 'a key = 'a Lwt.key 55 | 56 | (** Lwt concurrency monad. *) 57 | module Lwt : THREAD with type 'a t = 'a Lwt.t and type 'a key = 'a Lwt.key 58 | -------------------------------------------------------------------------------- /src/sqlexpr_sqlite.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | 4 | module Option = Sqlexpr_utils.Option 5 | exception Error of string * exn 6 | exception Sqlite_error of string * Sqlite3.Rc.t 7 | 8 | let tx_id_counter = ref 0 9 | 10 | let curr_thread_id () = Thread.id (Thread.self ()) 11 | 12 | let raise_thread_error ?msg expected = 13 | let actual = curr_thread_id () in 14 | let s = 15 | sprintf 16 | "Trying to run Sqlite3 function in different thread \ 17 | than the one where the db was created \ 18 | (expected %d, got %d)%s." 19 | expected 20 | actual 21 | (Option.map_default ((^) " ") "" msg) 22 | in raise (Error (s, (Failure s))) 23 | 24 | module Stmt = 25 | struct 26 | type t = { thread_id : int; dbhandle : Sqlite3.db; handle : Sqlite3.stmt; } 27 | 28 | let check_thread t = 29 | if curr_thread_id () <> t.thread_id then 30 | raise_thread_error ~msg:"in Stmt" t.thread_id 31 | 32 | let wrap f t = check_thread t; f t.handle 33 | 34 | let prepare dbhandle sql = 35 | { thread_id = curr_thread_id (); dbhandle = dbhandle; 36 | handle = Sqlite3.prepare dbhandle sql; } 37 | 38 | let db_handle t = t.dbhandle 39 | 40 | let finalize t = ignore (wrap Sqlite3.finalize t) 41 | let reset = wrap Sqlite3.reset 42 | let step = wrap Sqlite3.step 43 | let bind t n v = check_thread t; Sqlite3.bind t.handle n v 44 | let row_data = wrap Sqlite3.row_data 45 | end 46 | 47 | module Types = 48 | struct 49 | (* (params, nparams, sql, stmt_id) *) 50 | type st = (Sqlite3.Data.t list * int * string * string option) 51 | 52 | type 'a row_batch = 53 | | Batch_complete of 'a list 54 | | Batch_partial of 'a list 55 | | Batch_error of 'a list * exn 56 | end 57 | 58 | include Types 59 | 60 | let () = 61 | Printexc.register_printer 62 | (function 63 | | Error (s, exn) -> 64 | Some (sprintf "Sqlexpr_sqlite.Error (%S, %s)" s (Printexc.to_string exn)) 65 | | Sqlite_error (s, rc) -> 66 | Some (sprintf "Sqlexpr_sqlite.Sqlite_error (%S, %s)" 67 | s (Sqlite3.Rc.to_string rc)) 68 | | _ -> None) 69 | 70 | let new_id = 71 | let n = ref 0 in 72 | fun () -> incr n; !n 73 | 74 | module Stmt_cache = 75 | struct 76 | module H = Hashtbl.Make 77 | (struct 78 | type t = string 79 | let hash s = 80 | Char.code (String.unsafe_get s 0) + 81 | Char.code (String.unsafe_get s 1) lsl 8 + 82 | Char.code (String.unsafe_get s 2) lsl 16 + 83 | Char.code (String.unsafe_get s 3) lsl 24 84 | let equal (s1 : string) s2 = s1 = s2 85 | end) 86 | 87 | type t = Stmt.t H.t 88 | 89 | let create () = H.create 13 90 | 91 | let flush_stmts t = H.clear t 92 | 93 | let find_remove_stmt t id = 94 | try 95 | let r = H.find t id in 96 | H.remove t id; 97 | Some r 98 | with Not_found -> None 99 | 100 | let add_stmt t id stmt = H.add t id stmt 101 | end 102 | 103 | module type THREAD = Sqlexpr_concurrency.THREAD 104 | 105 | let prettify_sql_stmt sql = 106 | let b = Buffer.create 80 in 107 | let last_was_space = ref false in 108 | for i = 0 to String.length sql - 1 do 109 | match sql.[i] with 110 | '\r' | '\n' | '\t' | ' ' -> 111 | if not !last_was_space then Buffer.add_char b ' '; 112 | last_was_space := true 113 | | c -> Buffer.add_char b c; 114 | last_was_space := false 115 | done; 116 | (Buffer.contents b) 117 | 118 | let string_of_param = function 119 | Sqlite3.Data.NONE -> "NONE" 120 | | Sqlite3.Data.NULL -> "NULL" 121 | | Sqlite3.Data.INT n -> Int64.to_string n 122 | | Sqlite3.Data.FLOAT f -> string_of_float f 123 | | Sqlite3.Data.TEXT s | Sqlite3.Data.BLOB s -> sprintf "%S" s 124 | 125 | let string_of_params l = String.concat ", " (List.map string_of_param l) 126 | 127 | module Directives = 128 | struct 129 | module D = Sqlite3.Data 130 | 131 | type ('a, 'b) statement = 132 | { 133 | sql_statement : string; 134 | stmt_id : string option; 135 | directive : ('a, 'b) directive 136 | } 137 | 138 | and ('a, 'b) directive = (st -> 'b) -> st -> 'a 139 | 140 | let literal _x k st = k st 141 | 142 | let param f k (params, nparams, sql, prep) x = 143 | k (f x :: params, nparams + 1, sql, prep) 144 | 145 | let int k st n = param (fun n -> D.INT (Int64.of_int n)) k st n 146 | 147 | let int64 k st n = param (fun n -> D.INT n) k st n 148 | 149 | let int32 k st n = param (fun n -> D.INT (Int64.of_int32 n)) k st n 150 | 151 | let text k st s = param (fun s -> D.TEXT s) k st s 152 | 153 | let blob k st s = param (fun s -> D.BLOB s) k st s 154 | 155 | let float k st f = param (fun f -> D.FLOAT f) k st f 156 | 157 | let bool k st b = param (fun b -> D.INT (if b then 1L else 0L)) k st b 158 | 159 | let any k st f x = blob k st (f x) 160 | 161 | let maybe_int k st n = 162 | param (Option.map_default (fun n -> D.INT (Int64.of_int n)) D.NULL) k st n 163 | 164 | let maybe_int32 k st n = 165 | param (Option.map_default (fun n -> D.INT (Int64.of_int32 n)) D.NULL) k st n 166 | 167 | let maybe_int64 k st n = 168 | param (Option.map_default (fun n -> D.INT n) D.NULL) k st n 169 | 170 | let maybe_text k st s = 171 | param (Option.map_default (fun s -> D.TEXT s) D.NULL) k st s 172 | 173 | let maybe_blob k st s = 174 | param (Option.map_default (fun s -> D.BLOB s) D.NULL) k st s 175 | 176 | let maybe_float k st f = 177 | param (Option.map_default (fun f -> D.FLOAT f) D.NULL) k st f 178 | 179 | let maybe_bool k st b = 180 | param (Option.map_default (fun b -> D.INT (if b then 1L else 0L)) D.NULL) k st b 181 | 182 | let maybe_any k st f x = maybe_blob k st (Option.map f x) 183 | end 184 | 185 | module Conversion = 186 | struct 187 | open Sqlite3.Data 188 | 189 | let failwithfmt fmt = ksprintf failwith fmt 190 | 191 | let error s x = 192 | failwithfmt "Sqlexpr_sqlite error: bad data (expected %s but got %s)" 193 | s (Sqlite3.Data.to_string_debug x) 194 | 195 | let text = function 196 | TEXT s | BLOB s -> s 197 | | INT n -> Int64.to_string n 198 | | FLOAT f -> string_of_float f 199 | | x -> error "text" x 200 | 201 | let blob = function BLOB s | TEXT s -> s | x -> error "blob" x 202 | 203 | let int = function INT n -> Int64.to_int n | x -> error "int" x 204 | let int32 = function INT n -> Int64.to_int32 n | x -> error "int" x 205 | let int64 = function INT n -> n | x -> error "int" x 206 | 207 | let bool = function INT 0L -> false | INT _ -> true | x -> error "int" x 208 | 209 | let float = function 210 | INT n -> Int64.to_float n 211 | | FLOAT n -> n 212 | | x -> error "float" x 213 | 214 | let maybe f = function 215 | NULL -> None 216 | | x -> Some (f x) 217 | 218 | let maybe_text = maybe text 219 | let maybe_blob = maybe blob 220 | let maybe_int = maybe int 221 | let maybe_int32 = maybe int32 222 | let maybe_int64 = maybe int64 223 | let maybe_float = maybe float 224 | let maybe_bool = maybe bool 225 | end 226 | 227 | type 'a ret = Ret of 'a | Exn of exn 228 | 229 | let profile_ch = 230 | try 231 | Some (open_out_gen [Open_append; Open_creat; Open_binary] 0o644 232 | (Unix.getenv "OCAML_SQLEXPR_PROFILE")) 233 | with Not_found -> None 234 | 235 | let raw_profile_ch = 236 | try 237 | Some (open_out_gen [Open_append; Open_creat; Open_binary] 0o644 238 | (Unix.getenv "OCAML_SQLEXPR_LOG")) 239 | with Not_found -> None 240 | 241 | let profile_uuid = 242 | let uuid = 243 | sprintf "%s %d %d %g %s %g" 244 | (Unix.gethostname ()) 245 | (Unix.getpid ()) 246 | (try Unix.getppid () with _ -> -1) 247 | (Unix.gettimeofday ()) 248 | Sys.executable_name 249 | ((Unix.times ()).Unix.tms_utime) 250 | in Digest.to_hex (Digest.string uuid) 251 | 252 | (* pgocaml_prof wants to see a connect entry *) 253 | let () = 254 | Option.may 255 | (fun ch -> 256 | let detail = 257 | [ 258 | "user"; ""; 259 | "database"; ""; 260 | "host"; ""; 261 | "port"; "0"; 262 | "prog"; Sys.executable_name 263 | ] 264 | in Csv.save_out ch [[ "1"; profile_uuid; "connect"; "0"; "ok" ] @ detail]; 265 | flush ch) 266 | profile_ch 267 | 268 | module Error(M : THREAD) = 269 | struct 270 | let raise_exn ?(msg="") exn = M.fail (Error (msg, exn)) 271 | let failwithfmt fmt = Printf.ksprintf (fun s -> M.fail (Error (s, Failure s))) fmt 272 | end 273 | 274 | module Profile(Lwt : Sqlexpr_concurrency.THREAD) = 275 | struct 276 | open Lwt 277 | let profile_op ?(uuid = profile_uuid) op detail f = 278 | match profile_ch with 279 | None -> f () 280 | | Some ch -> 281 | let t0 = Unix.gettimeofday () in 282 | let%lwt ret = 283 | try%lwt 284 | let%lwt y = f () in 285 | return (Ret y) 286 | with e -> return (Exn e) 287 | in 288 | let dt = Unix.gettimeofday () -. t0 in 289 | let elapsed_time_us = int_of_float (1e6 *. dt) in 290 | (* the format used by PGOcaml *) 291 | let ret_txt = match ret with 292 | Ret _ -> "ok" 293 | | Exn e -> Printexc.to_string e in 294 | let row = 295 | [ "1"; uuid; op; string_of_int elapsed_time_us; ret_txt] @ 296 | detail 297 | in Csv.save_out ch [row]; 298 | flush ch; 299 | match ret with 300 | Ret r -> return r 301 | | Exn e -> Lwt.fail e 302 | 303 | (* accept a reversed list of params *) 304 | let profile_execute_sql sql ?(params = []) f = 305 | ignore params; (* TODO: use params or remove it. *) 306 | match profile_ch with 307 | None -> f () 308 | | Some _ch -> 309 | let details = 310 | [ "name"; Digest.to_hex (Digest.string sql); "portal"; " " ] 311 | in profile_op "execute" details f 312 | 313 | let profile_execute_sql sql ?(full_sql=sql) ?params f = 314 | Option.may 315 | (fun ch -> 316 | let param_str = match params with 317 | None -> "" 318 | | Some l -> String.concat "\t" (List.rev_map string_of_param l) 319 | in 320 | fprintf ch "%s\t%s\n%!" (String.escaped full_sql) param_str) 321 | raw_profile_ch; 322 | profile_execute_sql sql ?params f 323 | 324 | let profile_prepare_stmt sql f = 325 | match profile_ch with 326 | None -> f () 327 | | Some _ch -> 328 | let details = 329 | [ "query"; sql; "name"; Digest.to_hex (Digest.string sql) ] 330 | in profile_op "prepare" details f 331 | end 332 | 333 | module type POOL = 334 | sig 335 | type 'a result 336 | 337 | module TLS : Sqlexpr_concurrency.THREAD_LOCAL_STATE with type 'a t := 'a result 338 | 339 | type db 340 | type stmt 341 | 342 | val set_retry_on_busy : bool -> unit 343 | val get_retry_on_busy : unit -> bool 344 | 345 | val open_db : ?init:(Sqlite3.db -> unit) -> string -> db 346 | val close_db : db -> unit 347 | val prepare : 348 | db -> (stmt -> string -> Sqlite3.Data.t list -> 'a result) -> st -> 'a result 349 | val step : 350 | ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Sqlite3.Rc.t result 351 | val step_with_last_insert_rowid : 352 | ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Int64.t result 353 | val reset : stmt -> unit result 354 | val row_data : stmt -> Sqlite3.Data.t array result 355 | val raise_error : 356 | stmt -> ?sql:string -> ?params:Sqlite3.Data.t list -> ?errmsg:string -> 357 | Sqlite3.Rc.t -> 'a result 358 | 359 | val unsafe_execute : db -> ?retry_on_busy:bool -> string -> unit result 360 | val borrow_worker : db -> (db -> 'a result) -> 'a result 361 | val steal_worker : db -> (db -> 'a result) -> 'a result 362 | 363 | val transaction_key : db -> unit TLS.key 364 | 365 | val read_rows : 366 | (fname:string -> stmt -> sql:string -> Sqlite3.Data.t list -> 367 | ?batch:int -> cols:int -> (Sqlite3.Data.t array -> 'b) -> 'b row_batch result) option 368 | end 369 | 370 | module WT = Weak.Make(struct 371 | type t = Stmt.t 372 | let hash = Hashtbl.hash 373 | let equal = (==) 374 | end) 375 | 376 | type single_worker_db = 377 | { 378 | handle : Sqlite3.db; 379 | thread_id : int; 380 | id : int; 381 | stmts : WT.t; 382 | stmt_cache : Stmt_cache.t; 383 | } 384 | 385 | let identity_pool_transaction_key_table = Hashtbl.create 13 386 | 387 | module IdentityPool(M: THREAD with type 'a key = 'a Lwt.key) = 388 | struct 389 | module Lwt = M 390 | open Lwt 391 | 392 | include Profile(M) 393 | include Error(M) 394 | 395 | type db = single_worker_db 396 | type stmt = Stmt.t 397 | type 'a result = 'a Lwt.t 398 | 399 | let get_handle db = db.handle 400 | 401 | let retry_on_busy = ref false 402 | 403 | let set_retry_on_busy b = retry_on_busy := b 404 | let get_retry_on_busy () = !retry_on_busy 405 | 406 | let transaction_key = 407 | let t = identity_pool_transaction_key_table in 408 | (fun db -> 409 | try 410 | Hashtbl.find t db.id 411 | with Not_found -> 412 | let k = M.new_key () in 413 | Hashtbl.add t db.id k; 414 | register_finaliser (fun db -> Hashtbl.remove t db.id; return ()) db; 415 | k) 416 | 417 | let handle db = 418 | if db.thread_id <> curr_thread_id () then 419 | Lwt.catch 420 | (fun () -> raise_thread_error ~msg:"in IdentityPool.handle" db.thread_id) 421 | Lwt.fail 422 | else return db.handle 423 | 424 | let close_db db = 425 | try 426 | WT.iter 427 | (fun stmt -> Stmt.finalize stmt) 428 | db.stmts; 429 | Stmt_cache.flush_stmts db.stmt_cache; 430 | ignore begin 431 | try%lwt 432 | let%lwt db = handle db in 433 | ignore (Sqlite3.db_close db); 434 | return () 435 | with _ -> (* FIXME: log? *) return () 436 | end 437 | with Sqlite3.Error _ -> () (* FIXME: raise? *) 438 | 439 | let mutex_tbl = Hashtbl.create 13 440 | 441 | let get_db_mutex db = 442 | (* different modules having the same type db = single_worker_db will have 443 | * different mutex_tbl tables, so must create the mutex lazily *) 444 | let id = db.id in 445 | try 446 | Hashtbl.find mutex_tbl id 447 | with Not_found -> 448 | let m = M.create_recursive_mutex () in 449 | Hashtbl.add mutex_tbl id m; 450 | M.register_finaliser 451 | (fun _ -> Hashtbl.remove mutex_tbl id; return ()) db; 452 | m 453 | 454 | let make handle = 455 | let id = new_id () in 456 | { 457 | handle = handle; id = id; stmts = WT.create 13; 458 | thread_id = Thread.id (Thread.self ()); 459 | stmt_cache = Stmt_cache.create (); 460 | } 461 | 462 | let open_db ?(init = fun _ -> ()) fname = 463 | let handle = Sqlite3.db_open fname in 464 | init handle; 465 | make handle 466 | 467 | let raise_error db ?sql ?params ?(errmsg = Sqlite3.errmsg db) errcode = 468 | let msg = Sqlite3.Rc.to_string errcode ^ " " ^ errmsg in 469 | let msg = match sql with 470 | None -> msg 471 | | Some sql -> sprintf "%s in %s" msg (prettify_sql_stmt sql) in 472 | let msg = match params with 473 | None | Some [] -> msg 474 | | Some params -> 475 | sprintf "%s with params %s" msg (string_of_params (List.rev params)) 476 | in M.fail (Error (msg, Sqlite_error (msg, errcode))) 477 | 478 | let rec run ?(retry_on_busy = !retry_on_busy) ?stmt ?sql ?params db f x = match f x with 479 | Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r 480 | | Sqlite3.Rc.BUSY when retry_on_busy -> 481 | let%lwt () = M.sleep 0.010 in 482 | run ~retry_on_busy ?sql ?stmt ?params db f x 483 | | code -> 484 | let errmsg = Sqlite3.errmsg db in 485 | Option.may (fun stmt -> ignore (Stmt.reset stmt)) stmt; 486 | raise_error db ?sql ?params ~errmsg code 487 | 488 | let check_ok ?retry_on_busy ?stmt ?sql ?params db f x = 489 | let%lwt _ = run ?retry_on_busy ?stmt ?sql ?params db f x in return () 490 | 491 | let prepare db f (params, nparams, sql, stmt_id) = 492 | let%lwt dbh = handle db in 493 | let%lwt stmt = 494 | try%lwt 495 | match stmt_id with 496 | None -> 497 | profile_prepare_stmt sql 498 | (fun () -> 499 | let stmt = Stmt.prepare dbh sql in 500 | WT.add db.stmts stmt; 501 | return stmt) 502 | | Some id -> 503 | match Stmt_cache.find_remove_stmt db.stmt_cache id with 504 | Some stmt -> 505 | let%lwt () = begin try%lwt 506 | check_ok ~stmt dbh Stmt.reset stmt 507 | with e -> 508 | (* drop the stmt *) 509 | Stmt.finalize stmt; 510 | fail e 511 | end in 512 | return stmt 513 | | None -> 514 | profile_prepare_stmt sql 515 | (fun () -> 516 | let stmt = Stmt.prepare dbh sql in 517 | WT.add db.stmts stmt; 518 | return stmt) 519 | with e -> 520 | let msg = 521 | sprintf "Error with SQL statement %S:\n%s" sql (Printexc.to_string e) 522 | in raise_exn ~msg e in 523 | let rec iteri ?(i = 0) f = function 524 | [] -> return () 525 | | hd :: tl -> let%lwt () = f i hd in iteri ~i:(i + 1) f tl 526 | in 527 | (* the list of params is reversed *) 528 | let%lwt () = iteri 529 | (fun n v -> check_ok ~sql ~stmt dbh (Stmt.bind stmt (nparams - n)) v) 530 | params 531 | in 532 | profile_execute_sql ~full_sql:sql sql ~params 533 | (fun () -> 534 | (f stmt sql params)[%finally 535 | match stmt_id with 536 | Some id -> Stmt_cache.add_stmt db.stmt_cache id stmt; return () 537 | | None -> return () 538 | ]) 539 | 540 | let borrow_worker db f = f db 541 | 542 | let steal_worker db f = M.with_lock (get_db_mutex db) (fun () -> f db) 543 | 544 | let prepare db f (params, nparams, sql, stmt_id) = 545 | steal_worker db 546 | (fun db -> prepare db f (params, nparams, sql, stmt_id)) 547 | 548 | let step ?sql ?params stmt = 549 | run ?sql ?params ~stmt (Stmt.db_handle stmt) Stmt.step stmt 550 | 551 | let step_with_last_insert_rowid ?sql ?params stmt = 552 | let%lwt _ = step ?sql ?params stmt in 553 | return (Sqlite3.last_insert_rowid (Stmt.db_handle stmt)) 554 | 555 | let reset stmt = ignore (Stmt.reset stmt); return () 556 | let row_data stmt = return (Stmt.row_data stmt) 557 | 558 | let unsafe_execute db ?retry_on_busy sql = 559 | let%lwt dbh = handle db in 560 | check_ok ?retry_on_busy ~sql dbh (Sqlite3.exec dbh) sql 561 | 562 | let raise_error stmt ?sql ?params ?errmsg errcode = 563 | raise_error (Stmt.db_handle stmt) ?sql ?params ?errmsg errcode 564 | 565 | module TLS = M 566 | 567 | let read_rows = None 568 | end 569 | 570 | module type S = 571 | sig 572 | type 'a result 573 | 574 | type ('a, 'b) statement = 575 | { 576 | sql_statement : string; 577 | stmt_id : string option; 578 | directive : (st -> 'b) -> st -> 'a; 579 | } 580 | 581 | type ('a, 'b, 'c) expression = 582 | { 583 | statement : ('a, 'c) statement; 584 | get_data : int * (Sqlite3.Data.t array -> 'b); 585 | } 586 | 587 | type db 588 | 589 | exception Error of string * exn 590 | exception Sqlite_error of string * Sqlite3.Rc.t 591 | 592 | val set_retry_on_busy : bool -> unit 593 | val get_retry_on_busy : unit -> bool 594 | 595 | val open_db : ?init:(Sqlite3.db -> unit) -> string -> db 596 | val close_db : db -> unit 597 | val borrow_worker : db -> (db -> 'a result) -> 'a result 598 | val steal_worker : db -> (db -> 'a result) -> 'a result 599 | val execute : db -> ('a, unit result) statement -> 'a 600 | val insert : db -> ('a, int64 result) statement -> 'a 601 | 602 | val select : db -> ?batch:int -> ('c, 'a, 'a list result) expression -> 'c 603 | val select_f : db -> ?batch:int -> ('a -> 'b result) -> ('c, 'a, 'b list result) expression -> 'c 604 | val select_one : db -> ('c, 'a, 'a result) expression -> 'c 605 | val select_one_maybe : db -> ('c, 'a, 'a option result) expression -> 'c 606 | val select_one_f : db -> ('a -> 'b result) -> ('c, 'a, 'b result) expression -> 'c 607 | val select_one_f_maybe : db -> ('a -> 'b result) -> ('c, 'a, 'b option result) expression -> 'c 608 | val select_one_maybe_f : db -> ('a option -> 'b result) -> ('c, 'a, 'b result) expression -> 'c 609 | 610 | val transaction : 611 | db -> ?kind:[`DEFERRED | `IMMEDIATE | `EXCLUSIVE] -> 612 | (db -> 'a result) -> 'a result 613 | 614 | val fold : 615 | db -> ?batch:int -> ('a -> 'b -> 'a result) -> 'a -> ('c, 'b, 'a result) expression -> 'c 616 | 617 | val iter : db -> ?batch:int -> ('a -> unit result) -> ('b, 'a, unit result) expression -> 'b 618 | 619 | module Directives : 620 | sig 621 | type ('a, 'b) directive = (st -> 'b) -> st -> 'a 622 | 623 | val literal : string -> ('a, 'a) directive 624 | val int : (int -> 'a, 'a) directive 625 | val text : (string -> 'a, 'a) directive 626 | val blob : (string -> 'a, 'a) directive 627 | val float : (float -> 'a, 'a) directive 628 | val int32 : (int32 -> 'a, 'a) directive 629 | val int64 : (int64 -> 'a, 'a) directive 630 | val bool : (bool -> 'a, 'a) directive 631 | val any : (('b -> string) -> 'b -> 'a, 'a) directive 632 | 633 | val maybe_int : (int option -> 'a, 'a) directive 634 | val maybe_text : (string option -> 'a, 'a) directive 635 | val maybe_blob : (string option -> 'a, 'a) directive 636 | val maybe_float : (float option -> 'a, 'a) directive 637 | val maybe_int32 : (int32 option -> 'a, 'a) directive 638 | val maybe_int64 : (int64 option -> 'a, 'a) directive 639 | val maybe_bool : (bool option -> 'a, 'a) directive 640 | val maybe_any : (('b -> string) -> 'b option -> 'a, 'a) directive 641 | end 642 | 643 | module Conversion : 644 | sig 645 | val text : Sqlite3.Data.t -> string 646 | val blob : Sqlite3.Data.t -> string 647 | val int : Sqlite3.Data.t -> int 648 | val int32 : Sqlite3.Data.t -> int32 649 | val int64 : Sqlite3.Data.t -> int64 650 | val float : Sqlite3.Data.t -> float 651 | val bool : Sqlite3.Data.t -> bool 652 | val maybe : (Sqlite3.Data.t -> 'a) -> Sqlite3.Data.t -> 'a option 653 | val maybe_text : Sqlite3.Data.t -> string option 654 | val maybe_blob : Sqlite3.Data.t -> string option 655 | val maybe_int : Sqlite3.Data.t -> int option 656 | val maybe_int32 : Sqlite3.Data.t -> int32 option 657 | val maybe_int64 : Sqlite3.Data.t -> int64 option 658 | val maybe_float : Sqlite3.Data.t -> float option 659 | val maybe_bool : Sqlite3.Data.t -> bool option 660 | end 661 | end 662 | 663 | module Make_gen(M : THREAD)(POOL : POOL with type 'a result = 'a M.t) = 664 | struct 665 | module Lwt = M 666 | open Lwt 667 | include Error(M) 668 | include Profile(M) 669 | 670 | module Directives = Directives 671 | module Conversion = Conversion 672 | 673 | open Directives 674 | 675 | let (>>=) = bind 676 | type 'a result = 'a M.t 677 | 678 | type ('a, 'b) statement = ('a, 'b) Directives.statement = 679 | { 680 | sql_statement : string; 681 | stmt_id : string option; 682 | directive : ('a, 'b) directive 683 | } 684 | 685 | type ('a, 'b, 'c) expression = { 686 | statement : ('a, 'c) statement; 687 | get_data : int * (Sqlite3.Data.t array -> 'b); 688 | } 689 | 690 | type db = POOL.db 691 | 692 | exception Error = Error 693 | exception Sqlite_error = Sqlite_error 694 | 695 | let set_retry_on_busy = POOL.set_retry_on_busy 696 | let get_retry_on_busy = POOL.get_retry_on_busy 697 | 698 | let open_db = POOL.open_db 699 | let close_db = POOL.close_db 700 | 701 | let borrow_worker = POOL.borrow_worker 702 | let steal_worker = POOL.steal_worker 703 | 704 | let do_select f db p = 705 | p.directive (POOL.prepare db f) ([], 0, p.sql_statement, p.stmt_id) 706 | 707 | let ensure_reset_stmt stmt f x = 708 | (f x) 709 | [%finally POOL.reset stmt] 710 | 711 | let execute db (p : ('a, _ M.t) statement) = 712 | do_select 713 | (fun stmt sql params -> 714 | ensure_reset_stmt stmt 715 | (fun () -> let%lwt _ = POOL.step ~sql ~params stmt in return ()) ()) 716 | db p 717 | 718 | let insert db p = 719 | do_select 720 | (fun stmt sql params -> 721 | ensure_reset_stmt stmt 722 | (fun () -> POOL.step_with_last_insert_rowid ~sql ~params stmt) ()) 723 | db p 724 | 725 | let check_num_cols s _stmt expr data = 726 | let expected = fst expr.get_data in 727 | let actual = Array.length data in 728 | if expected = actual then return () 729 | else 730 | failwithfmt 731 | "Sqlexpr_sqlite.%s: wrong number of columns \ 732 | (expected %d, got %d) in SQL: %s" s expected actual 733 | expr.statement.sql_statement 734 | 735 | let rec iter_s f = function 736 | | [] -> return () 737 | | x :: tl -> let%lwt () = f x in iter_s f tl 738 | 739 | let rec fold_left_s f acc = function 740 | | [] -> return acc 741 | | x :: tl -> 742 | let%lwt acc = f acc x in 743 | fold_left_s f acc tl 744 | 745 | let select_f db ?batch:_ f expr = 746 | do_select 747 | (fun stmt sql params -> 748 | let auto_yield = M.auto_yield 0.01 in 749 | let rec loop l = 750 | auto_yield () >>= fun () -> 751 | POOL.step stmt >>= function 752 | Sqlite3.Rc.ROW -> 753 | POOL.row_data stmt >>= fun data -> 754 | check_num_cols "select" stmt expr data >>= fun () -> 755 | Lwt.try_bind 756 | (fun () -> f (snd expr.get_data data)) 757 | (fun x -> loop (x :: l)) 758 | Lwt.fail 759 | | Sqlite3.Rc.DONE -> return (List.rev l) 760 | | rc -> POOL.raise_error ~sql ~params stmt rc 761 | in ensure_reset_stmt stmt loop []) 762 | db 763 | expr.statement 764 | 765 | let select_f = match POOL.read_rows with 766 | | None -> select_f 767 | | Some read_rows -> fun db ?batch f expr -> 768 | do_select 769 | (fun stmt sql params -> 770 | let f acc x = 771 | let%lwt y = f x in 772 | return (y :: acc) in 773 | 774 | let rec loop_fold acc = 775 | match%lwt 776 | read_rows 777 | ~fname:"select_f" stmt ~sql params 778 | ?batch ~cols:(fst expr.get_data) (snd expr.get_data) 779 | with 780 | | Batch_complete l -> 781 | fold_left_s f acc l >>= fun l -> return (List.rev l) 782 | | Batch_partial l -> fold_left_s f acc l >>= loop_fold 783 | | Batch_error (l, exn) -> 784 | fold_left_s f acc l >>= fun _ -> 785 | fail exn 786 | in 787 | ensure_reset_stmt stmt loop_fold []) 788 | db 789 | expr.statement 790 | 791 | let select db ?batch expr = select_f db ?batch (fun x -> return x) expr 792 | 793 | let select_one_f_aux db f not_found expr = 794 | do_select 795 | (fun stmt sql params -> 796 | ensure_reset_stmt stmt begin fun () -> 797 | POOL.step stmt >>= function 798 | Sqlite3.Rc.ROW -> 799 | let%lwt data = POOL.row_data stmt in 800 | Lwt.catch (fun () -> f (snd expr.get_data data)) Lwt.fail 801 | | Sqlite3.Rc.DONE -> not_found () 802 | | rc -> POOL.raise_error ~sql ~params stmt rc 803 | end ()) 804 | db 805 | expr.statement 806 | 807 | let select_one db expr = 808 | select_one_f_aux db (fun x -> return x) (fun () -> M.fail Not_found) expr 809 | 810 | let select_one_f db f expr = 811 | select_one_f_aux db f (fun () -> M.fail Not_found) expr 812 | 813 | let select_one_maybe db expr = 814 | select_one_f_aux db (fun x -> return (Some x)) (fun () -> return None) expr 815 | 816 | let select_one_f_maybe db f expr = 817 | select_one_f_aux db 818 | (fun x -> let%lwt y = f x in return (Some y)) (fun () -> return None) expr 819 | 820 | let select_one_maybe_f db f expr = 821 | select_one_f_aux db (fun x -> f (Some x)) (fun () -> f None) expr 822 | 823 | let new_tx_id = 824 | let pid = Unix.getpid () in 825 | fun () -> 826 | (* No allocation here, so cannot have a context change until the 827 | * sprintf, at least in native code. *) 828 | let n = !tx_id_counter in 829 | incr tx_id_counter; 830 | if !tx_id_counter < 0 then tx_id_counter := 0; 831 | sprintf "__sqlexpr_sqlite_tx_%d_%d" pid n 832 | 833 | let unsafe_execute_prof text db ?retry_on_busy fmt = 834 | ksprintf 835 | (fun sql -> 836 | let%lwt () = profile_prepare_stmt text (fun () -> return ()) in 837 | profile_execute_sql ~full_sql:sql text (fun () -> POOL.unsafe_execute db ?retry_on_busy sql)) 838 | fmt 839 | 840 | (* wrap in BEGIN/COMMIT only for outermost txs *) 841 | let outer_transaction_wrap ~kind f db = 842 | match POOL.TLS.get (POOL.transaction_key db) with 843 | Some _ -> f db 844 | | None -> 845 | let tx_kind = match kind with 846 | `DEFERRED -> "DEFERRED" 847 | | `IMMEDIATE -> "IMMEDIATE" 848 | | `EXCLUSIVE -> "EXCLUSIVE" 849 | in 850 | let%lwt () = unsafe_execute_prof ~retry_on_busy:true "BEGIN" db "BEGIN %s" tx_kind in 851 | match%lwt 852 | try%lwt 853 | let%lwt x = POOL.TLS.with_value 854 | (POOL.transaction_key db) (Some ()) (fun () -> f db) 855 | in 856 | return (`OK x) 857 | with exn -> return (`EXN exn) 858 | with 859 | | `OK x -> let%lwt () = unsafe_execute_prof ~retry_on_busy:true 860 | "COMMIT" db "COMMIT" in return x 861 | | `EXN exn -> let%lwt () = unsafe_execute_prof "ROLLBACK" db "ROLLBACK" in fail exn 862 | 863 | let transaction db ?(kind = `DEFERRED) f = 864 | let txid = new_tx_id () in 865 | POOL.steal_worker db 866 | (outer_transaction_wrap ~kind begin fun db -> 867 | let%lwt () = unsafe_execute_prof "SAVEPOINT" db "SAVEPOINT %s" txid in 868 | try%lwt 869 | let%lwt x = f db in 870 | let%lwt () = unsafe_execute_prof "RELEASE" db "RELEASE %s" txid in 871 | return x 872 | with e -> 873 | let%lwt () = unsafe_execute_prof "ROLLBACK" db "ROLLBACK TO %s" txid in 874 | let%lwt () = unsafe_execute_prof "RELEASE" db "RELEASE %s" txid in 875 | fail e 876 | end) 877 | 878 | let fold db ?batch:_ f init expr = 879 | do_select 880 | (fun stmt sql params -> 881 | let auto_yield = M.auto_yield 0.01 in 882 | let rec loop acc = 883 | auto_yield () >>= fun () -> 884 | POOL.step stmt >>= function 885 | Sqlite3.Rc.ROW -> 886 | Lwt.try_bind 887 | (fun () -> 888 | POOL.row_data stmt >>= fun data -> 889 | check_num_cols "fold" stmt expr data >>= fun () -> 890 | f acc (snd expr.get_data data)) 891 | loop 892 | Lwt.fail 893 | | Sqlite3.Rc.DONE -> return acc 894 | | rc -> POOL.raise_error ~sql ~params stmt rc 895 | in ensure_reset_stmt stmt loop init) 896 | db 897 | expr.statement 898 | 899 | let fold = match POOL.read_rows with 900 | | None -> fold 901 | | Some read_rows -> fun db ?batch f init expr -> 902 | do_select 903 | (fun stmt sql params -> 904 | let rec loop_fold acc = 905 | match%lwt 906 | read_rows 907 | ~fname:"fold" stmt ~sql params 908 | ?batch ~cols:(fst expr.get_data) (snd expr.get_data) 909 | with 910 | | Batch_complete l -> fold_left_s f acc l 911 | | Batch_partial l -> fold_left_s f acc l >>= loop_fold 912 | | Batch_error (l, exn) -> 913 | let%lwt _ = fold_left_s f acc l in 914 | fail exn 915 | in 916 | ensure_reset_stmt stmt loop_fold init) 917 | db 918 | expr.statement 919 | 920 | let iter db ?batch:_ f expr = 921 | do_select 922 | (fun stmt sql params -> 923 | let auto_yield = M.auto_yield 0.01 in 924 | let rec loop () = 925 | auto_yield () >>= fun () -> 926 | POOL.step stmt >>= function 927 | Sqlite3.Rc.ROW -> 928 | Lwt.try_bind 929 | (fun () -> 930 | POOL.row_data stmt >>= fun data -> 931 | check_num_cols "iter" stmt expr data >>= fun () -> 932 | f (snd expr.get_data data)) 933 | loop 934 | Lwt.fail 935 | | Sqlite3.Rc.DONE -> return () 936 | | rc -> POOL.raise_error stmt ~sql ~params rc 937 | in ensure_reset_stmt stmt loop ()) 938 | db 939 | expr.statement 940 | 941 | let iter = match POOL.read_rows with 942 | | None -> iter 943 | | Some read_rows -> fun db ?batch f expr -> 944 | do_select 945 | (fun stmt sql params -> 946 | let rec loop_iter () = 947 | match%lwt 948 | read_rows 949 | ~fname:"iter" stmt ~sql params 950 | ?batch ~cols:(fst expr.get_data) (snd expr.get_data) 951 | with 952 | | Batch_complete l -> iter_s f l 953 | | Batch_partial l -> iter_s f l >>= loop_iter 954 | | Batch_error (l, exn) -> 955 | let%lwt () = iter_s f l in 956 | fail exn 957 | in 958 | ensure_reset_stmt stmt loop_iter ()) 959 | db 960 | expr.statement 961 | end 962 | 963 | module Make(M : THREAD with type 'a key = 'a Lwt.key) = struct 964 | module Id = IdentityPool(M) 965 | include Make_gen(M)(Id) 966 | let make = Id.make 967 | let sqlite_db db = Id.get_handle db 968 | end 969 | -------------------------------------------------------------------------------- /src/sqlexpr_sqlite.mli: -------------------------------------------------------------------------------- 1 | (** Sqlexpr access to SQLite databases. *) 2 | 3 | (**/**) 4 | module Types : sig 5 | (** Type used internally. *) 6 | type st = Sqlite3.Data.t list * int * string * string option 7 | 8 | type 'a row_batch = 9 | | Batch_complete of 'a list 10 | | Batch_partial of 'a list 11 | | Batch_error of 'a list * exn 12 | end 13 | 14 | type st = Types.st 15 | (**/**) 16 | 17 | (** All the exceptions raised by the code in {Sqlexpr_sqlite} are wrapped in 18 | Error except when indicated otherwise. *) 19 | exception Error of string * exn 20 | 21 | (** Errors reported by SQLite are converted into [Sqlite_error _] exceptions, 22 | so they can be matched with 23 | [try ... with Sqlexpr.Error (_, Sqlexpr.sqlite_error _)] *) 24 | exception Sqlite_error of string * Sqlite3.Rc.t 25 | 26 | (** *) 27 | module type S = 28 | sig 29 | (** Concurrency monad value. *) 30 | type 'a result 31 | 32 | (** Type of SQL statements (no output parameters). *) 33 | type ('a, 'b) statement = 34 | { 35 | sql_statement : string; 36 | stmt_id : string option; 37 | directive : (st -> 'b) -> st -> 'a; 38 | } 39 | 40 | (** Type of SQL expressions (output parameters). *) 41 | type ('a, 'b, 'c) expression = 42 | { 43 | statement : ('a, 'c) statement; 44 | get_data : int * (Sqlite3.Data.t array -> 'b); 45 | } 46 | 47 | (** Database type *) 48 | type db 49 | 50 | (** Exception identical to the toplevel [Error], provided for convenience. 51 | Note that [Sqlexpr_sqlite.Error _] matches this exception. *) 52 | exception Error of string * exn 53 | 54 | (** Exception identical to the toplevel [Sqlite_error], provided for 55 | convenience. Note that [Sqlexpr_sqlite.Sqlite_error _] matches this 56 | exception. *) 57 | exception Sqlite_error of string * Sqlite3.Rc.t 58 | 59 | 60 | (** Specify whether to retry operations by default when SQLite3 returns 61 | * BUSY. (As of 0.6.0, the modules supplied with sqlexpr use false as their 62 | * default value; will likely be changed to true in a subsequent release.) *) 63 | val set_retry_on_busy : bool -> unit 64 | 65 | (** Returns whether operations are retried by default when SQLite3 returns 66 | * BUSY. (As of 0.6.0, the modules supplied with sqlexpr use false as their 67 | * default value; will likely be changed to true in a subsequent release.) *) 68 | val get_retry_on_busy : unit -> bool 69 | 70 | (** Open the DB whose filename is given. [":memory:"] refers to an in-mem DB. 71 | * 72 | * @param init function to be applied to [Sqlite3.db] handle(s) before 73 | * they are used (can be used to register functions or initialize schema in 74 | * in-mem tables. *) 75 | val open_db : ?init:(Sqlite3.db -> unit) -> string -> db 76 | 77 | (** Close the DB and finalize all the associated prepared statements. *) 78 | val close_db : db -> unit 79 | 80 | (** [borrow_worker db f] evaluates [f db'] where [db'] borrows a 'worker' 81 | * from [db] and [db'] is only valid inside [f]. All the operations on 82 | * [db'] will use the same worker. Use this e.g. if you have an in-mem 83 | * database and a number of operations that must go against the same 84 | * instance (since data is not shared across different [:memory:] 85 | * databases). [db'] will not spawn new workers and will be closed and 86 | * invalidated automatically. *) 87 | val borrow_worker : db -> (db -> 'a result) -> 'a result 88 | 89 | (** [steal_worker db f] is similar to [borrow_worker db f], but ensures 90 | * that [f] is given exclusive access to the worker while it is being 91 | * evaluated. *) 92 | val steal_worker : db -> (db -> 'a result) -> 'a result 93 | 94 | (** Execute a SQL statement. *) 95 | val execute : db -> ('a, unit result) statement -> 'a 96 | 97 | (** Execute an INSERT SQL statement and return the last inserted row id. 98 | Example: 99 | [insert db sqlc"INSERT INTO users(name, pass) VALUES(%s, %s)" name pass] 100 | *) 101 | val insert : db -> ('a, int64 result) statement -> 'a 102 | 103 | (** "Select" a SELECT SQL expression and return a list of tuples; e.g. 104 | [select db sqlc"SELECT \@s\{name\}, \@s\{pass\} FROM users"] 105 | [select db sqlc"SELECT \@s\{pass\} FROM users WHERE id = %L" user_id] 106 | 107 | If [batch] is not [1], some worker pool implementations might choose to 108 | read multiple rows at a time to make the operation faster. 109 | *) 110 | val select : db -> ?batch:int -> ('c, 'a, 'a list result) expression -> 'c 111 | 112 | (** [select_f db f expr ...] is similar to [select db expr ...] but maps the 113 | results using the provided [f] function. 114 | 115 | If [batch] is not [1], some worker pool implementations might choose to 116 | read multiple rows at a time to make the operation faster. 117 | *) 118 | val select_f : db -> ?batch:int -> ('a -> 'b result) -> ('c, 'a, 'b list result) expression -> 'c 119 | 120 | (** [select_one db expr ...] takes the first result from 121 | [select db expr ...]. 122 | @raise Not_found if no row is found. *) 123 | val select_one : db -> ('c, 'a, 'a result) expression -> 'c 124 | 125 | (** [select_one_maybe db expr ...] takes the first result from 126 | [select db expr ...]. 127 | @return None if no row is found. *) 128 | val select_one_maybe : db -> ('c, 'a, 'a option result) expression -> 'c 129 | 130 | (** [select_one_f db f expr ...] returns the first result from 131 | [select_f db f expr ...]. 132 | @raise Not_found if no row is found. *) 133 | val select_one_f : db -> ('a -> 'b result) -> ('c, 'a, 'b result) expression -> 'c 134 | 135 | (** [select_one_f_maybe db expr ...] takes the first result from 136 | [select_f db f expr ...]. 137 | @return None if no row is found. *) 138 | val select_one_f_maybe : db -> ('a -> 'b result) -> 139 | ('c, 'a, 'b option result) expression -> 'c 140 | 141 | (** [select_one_maybe_f db f expr ...] returns [f (Some x)], where [x] is 142 | the first row returned by [select db expr ...], or [f None] if there 143 | is none. 144 | *) 145 | val select_one_maybe_f : db -> ('a option -> 'b result) -> 146 | ('c, 'a, 'b result) expression -> 'c 147 | 148 | (** Run the provided function in a DB transaction. A rollback is performed 149 | if an exception is raised inside the transaction. 150 | 151 | If the BEGIN or COMMIT SQL statements from the outermost transaction fail 152 | with [SQLITE_BUSY], they will be retried until they can be executed. 153 | A [SQLITE_BUSY] (or any other) error code in any other operation inside 154 | a transaction will result in an [Error (_, Sqlite_error (code, _))] 155 | exception being thrown, and a rollback performed. 156 | Refer to {!set_retry_on_busy}. 157 | 158 | One consequence of this is that concurrency control is very simple if 159 | you use [`EXCLUSIVE] transactions: the code can be written 160 | straightforwardly as [S.transaction db (fun db -> ...)], and their 161 | execution will be serialized (across both threads and processes). 162 | Note that, for [`IMMEDIATE] and [`DEFERRED] transactions, you will 163 | have to retry manually if an 164 | [Error (_, Sqlite_error (Sqlite3.Rc.Busy, _))] is raised. 165 | 166 | All SQL operations performed within a transaction will use the same 167 | worker. This worker is used exclusively by only one thread per 168 | instantiated module (see {!steal_worker}). 169 | That is, given 170 | {[ 171 | module S1 = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) 172 | module S2 = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Lwt) 173 | let db = S1.open_db somefile 174 | ]} 175 | there is no exclusion between functions from [S1] and those from [S2]. 176 | 177 | @param kind transaction kind, only meaningful for outermost transaction 178 | (default [`DEFERRED]) 179 | *) 180 | val transaction : 181 | db -> ?kind:[`DEFERRED | `IMMEDIATE | `EXCLUSIVE] -> 182 | (db -> 'a result) -> 'a result 183 | 184 | (** [fold db f a expr ...] is 185 | * [f (... (f (f a r1) r2) ...) rN] 186 | * where [rN] is the n-th row returned for the SELECT expression [expr]. 187 | * If [batch] is not [1], some worker pool implementations might choose to 188 | * read multiple rows at a time to make this operation faster. 189 | * *) 190 | val fold : 191 | db -> ?batch:int -> ('a -> 'b -> 'a result) -> 'a -> ('c, 'b, 'a result) expression -> 'c 192 | 193 | (** Iterate through the rows returned for the supplied expression. 194 | * If [batch] is not [1], some worker pool implementations might choose to 195 | * read multiple rows at a time to make this operation faster. 196 | * *) 197 | val iter : db -> ?batch:int -> ('a -> unit result) -> ('b, 'a, unit result) expression -> 'b 198 | 199 | (** Module used by the code generated for SQL literals. *) 200 | module Directives : 201 | sig 202 | type ('a, 'b) directive = (st -> 'b) -> st -> 'a 203 | 204 | val literal : string -> ('a, 'a) directive 205 | val int : (int -> 'a, 'a) directive 206 | val text : (string -> 'a, 'a) directive 207 | val blob : (string -> 'a, 'a) directive 208 | val float : (float -> 'a, 'a) directive 209 | val int32 : (int32 -> 'a, 'a) directive 210 | val int64 : (int64 -> 'a, 'a) directive 211 | val bool : (bool -> 'a, 'a) directive 212 | val any : (('b -> string) -> 'b -> 'a, 'a) directive 213 | 214 | val maybe_int : (int option -> 'a, 'a) directive 215 | val maybe_text : (string option -> 'a, 'a) directive 216 | val maybe_blob : (string option -> 'a, 'a) directive 217 | val maybe_float : (float option -> 'a, 'a) directive 218 | val maybe_int32 : (int32 option -> 'a, 'a) directive 219 | val maybe_int64 : (int64 option -> 'a, 'a) directive 220 | val maybe_bool : (bool option -> 'a, 'a) directive 221 | val maybe_any : (('b -> string) -> 'b option -> 'a, 'a) directive 222 | end 223 | 224 | (** Module used by the code generated for SQL literals. *) 225 | module Conversion : 226 | sig 227 | val text : Sqlite3.Data.t -> string 228 | val blob : Sqlite3.Data.t -> string 229 | val int : Sqlite3.Data.t -> int 230 | val int32 : Sqlite3.Data.t -> int32 231 | val int64 : Sqlite3.Data.t -> int64 232 | val float : Sqlite3.Data.t -> float 233 | val bool : Sqlite3.Data.t -> bool 234 | val maybe : (Sqlite3.Data.t -> 'a) -> Sqlite3.Data.t -> 'a option 235 | val maybe_text : Sqlite3.Data.t -> string option 236 | val maybe_blob : Sqlite3.Data.t -> string option 237 | val maybe_int : Sqlite3.Data.t -> int option 238 | val maybe_int32 : Sqlite3.Data.t -> int32 option 239 | val maybe_int64 : Sqlite3.Data.t -> int64 option 240 | val maybe_float : Sqlite3.Data.t -> float option 241 | val maybe_bool : Sqlite3.Data.t -> bool option 242 | end 243 | end 244 | 245 | (** [db] type shared by single-worker ("identity pool") {!S} implementations. *) 246 | type single_worker_db 247 | 248 | module Make : functor (M : Sqlexpr_concurrency.THREAD with type 'a key = 'a Lwt.key) -> 249 | sig 250 | include S with type 'a result = 'a M.t and type db = single_worker_db 251 | 252 | val make : Sqlite3.db -> db 253 | 254 | (** Return the [Sqlite3.db] handle from a [db]. *) 255 | val sqlite_db : db -> Sqlite3.db 256 | end 257 | 258 | module type POOL = 259 | sig 260 | type 'a result 261 | 262 | module TLS : Sqlexpr_concurrency.THREAD_LOCAL_STATE with type 'a t := 'a result 263 | 264 | type db 265 | type stmt 266 | 267 | val set_retry_on_busy : bool -> unit 268 | val get_retry_on_busy : unit -> bool 269 | 270 | val open_db : ?init:(Sqlite3.db -> unit) -> string -> db 271 | val close_db : db -> unit 272 | 273 | val prepare : 274 | db -> (stmt -> string -> Sqlite3.Data.t list -> 'a result) -> st -> 'a result 275 | val step : 276 | ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Sqlite3.Rc.t result 277 | val step_with_last_insert_rowid : 278 | ?sql:string -> ?params:Sqlite3.Data.t list -> stmt -> Int64.t result 279 | val reset : stmt -> unit result 280 | val row_data : stmt -> Sqlite3.Data.t array result 281 | val raise_error : 282 | stmt -> ?sql:string -> ?params:Sqlite3.Data.t list -> ?errmsg:string -> 283 | Sqlite3.Rc.t -> 'a result 284 | val unsafe_execute : db -> ?retry_on_busy:bool -> string -> unit result 285 | val borrow_worker : db -> (db -> 'a result) -> 'a result 286 | val steal_worker : db -> (db -> 'a result) -> 'a result 287 | 288 | val transaction_key : db -> unit TLS.key 289 | 290 | val read_rows : 291 | (fname:string -> stmt -> sql:string -> Sqlite3.Data.t list -> 292 | ?batch:int -> cols:int -> (Sqlite3.Data.t array -> 'b) -> 'b Types.row_batch result) option 293 | end 294 | 295 | module Make_gen : 296 | functor (M : Sqlexpr_concurrency.THREAD) -> 297 | functor(P : POOL with type 'a result = 'a M.t) -> 298 | S with type 'a result = 'a M.t 299 | 300 | (**/**) 301 | val prettify_sql_stmt : string -> string 302 | val string_of_param : Sqlite3.Data.t -> string 303 | val string_of_params : Sqlite3.Data.t list -> string 304 | 305 | module Stmt : 306 | sig 307 | type t 308 | val prepare : Sqlite3.db -> string -> t 309 | val db_handle : t -> Sqlite3.db 310 | val finalize : t -> unit 311 | val reset : t -> Sqlite3.Rc.t 312 | val step : t -> Sqlite3.Rc.t 313 | val bind : t -> int -> Sqlite3.Data.t -> Sqlite3.Rc.t 314 | val row_data : t -> Sqlite3.Data.t array 315 | end 316 | 317 | module Stmt_cache : 318 | sig 319 | type t 320 | val create : unit -> t 321 | val flush_stmts : t -> unit 322 | val find_remove_stmt : t -> string -> Stmt.t option 323 | val add_stmt : t -> string -> Stmt.t -> unit 324 | end 325 | 326 | module Profile : functor (M : Sqlexpr_concurrency.THREAD) -> 327 | sig 328 | val profile_execute_sql : 329 | string -> ?full_sql:string -> ?params:Sqlite3.Data.t list -> 330 | (unit -> 'b M.t) -> 'b M.t 331 | val profile_prepare_stmt : string -> (unit -> 'a M.t) -> 'a M.t 332 | end 333 | 334 | (**/**) 335 | -------------------------------------------------------------------------------- /src/sqlexpr_sqlite_lwt.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Sqlexpr_sqlite 3 | open Lwt 4 | 5 | module Option = Sqlexpr_utils.Option 6 | module CONC = Sqlexpr_concurrency.Lwt 7 | 8 | (* Total number of threads currently running: *) 9 | let thread_count = ref 0 10 | 11 | (* Max allowed number of threads *) 12 | let max_threads = ref 4 13 | let set_max_threads n = max_threads := max n !thread_count; !max_threads 14 | 15 | module POOL = 16 | struct 17 | include Sqlexpr_sqlite.Profile(CONC) 18 | 19 | module WT = Weak.Make(struct 20 | type t = Stmt.t 21 | let hash = Hashtbl.hash 22 | let equal = (==) 23 | end) 24 | module rec Ty : 25 | sig 26 | type db = { 27 | id : int; 28 | file : string; 29 | mutable db_finished : bool; 30 | mutable max_workers : int; 31 | mutable worker_count : int; 32 | init_func : Sqlite3.db -> unit; 33 | mutable workers : worker list; 34 | free_workers : WSet.t; 35 | db_waiters : worker Lwt.u Lwt_sequence.t; 36 | tx_key : unit Lwt.key; 37 | } 38 | 39 | and thread = { 40 | mutable thread : Thread.t; 41 | pmutex : Mutex.t; 42 | cv : Condition.t; 43 | mutable tasks : (int * (unit -> unit)) list; 44 | mutex : Lwt_mutex.t; 45 | } 46 | 47 | and worker = 48 | { 49 | worker_id : int; 50 | mutable handle : Sqlite3.db; 51 | stmts : WT.t; 52 | stmt_cache : Stmt_cache.t; 53 | worker_thread : thread; 54 | db : db; 55 | } 56 | end = Ty 57 | 58 | and WSet : sig 59 | type t 60 | val create : unit -> t 61 | val is_empty : t -> bool 62 | val add : t -> Ty.worker -> unit 63 | val take : t -> Ty.worker 64 | val remove : t -> Ty.worker -> unit 65 | end = struct 66 | module S = 67 | Set.Make(struct 68 | type t = Ty.worker 69 | let compare w1 w2 = w1.Ty.worker_id - w2.Ty.worker_id 70 | end) 71 | type t = S.t ref 72 | 73 | let create () = ref S.empty 74 | let is_empty t = S.is_empty !t 75 | let add t x = t := S.add x !t 76 | let remove t x = t := S.remove x !t 77 | 78 | let take t = 79 | let x = S.min_elt !t in 80 | remove t x; 81 | x 82 | end 83 | 84 | include Ty 85 | 86 | type stmt = worker * Stmt.t 87 | type 'a result = 'a Lwt.t 88 | 89 | module TLS = Lwt 90 | 91 | let retry_on_busy = ref false 92 | 93 | let set_retry_on_busy b = retry_on_busy := b 94 | let get_retry_on_busy () = !retry_on_busy 95 | 96 | (* Pool of threads: *) 97 | let threads : thread Queue.t = Queue.create () 98 | 99 | (* Queue of clients waiting for a thread to be available: *) 100 | let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create () 101 | 102 | (* will be set to [detach] later, done this way to avoid cumbersome gigantic 103 | * let rec definition *) 104 | let do_detach = ref (fun _ _ _ -> return ()) 105 | 106 | let rec close_db db = 107 | db.db_finished <- true; 108 | List.iter close_worker db.workers 109 | 110 | and close_worker w = 111 | Stmt_cache.flush_stmts w.stmt_cache; 112 | (* must run Stmt.finalize and Sqlite3.db_close in the same thread where 113 | * the handles were created! *) 114 | ignore ( 115 | try%lwt 116 | !do_detach w 117 | (fun handle () -> 118 | WT.iter (fun stmt -> Stmt.finalize stmt) w.stmts; 119 | ignore (Sqlite3.db_close handle)) 120 | () 121 | with _ -> return () (* FIXME: log? *) 122 | ) 123 | 124 | let new_id = 125 | let n = ref 0 in 126 | fun () -> incr n; !n 127 | 128 | let transaction_key db = db.tx_key 129 | 130 | let open_db ?(init = fun _ -> ()) file = 131 | let id = new_id () in 132 | let r = 133 | { 134 | id = id; file = file; init_func = init; max_workers = !max_threads; 135 | worker_count = 0; workers = []; 136 | free_workers = WSet.create (); 137 | db_waiters = Lwt_sequence.create (); 138 | db_finished = false; 139 | tx_key = Lwt.new_key (); 140 | } 141 | in 142 | Lwt_gc.finalise (fun db -> close_db db; return ()) r; 143 | r 144 | 145 | let rec thread_loop thread = 146 | 147 | let rec wait_for_task thread = 148 | match thread.tasks with 149 | | [] -> 150 | Condition.wait thread.cv thread.pmutex; 151 | wait_for_task thread 152 | | x :: tasks -> 153 | thread.tasks <- tasks; 154 | Mutex.unlock thread.pmutex; 155 | x 156 | in 157 | Mutex.lock thread.pmutex; 158 | let id, task = wait_for_task thread in 159 | task (); 160 | Lwt_unix.send_notification id; 161 | thread_loop thread 162 | 163 | let make_thread () = 164 | let t = 165 | { 166 | thread = Thread.self (); 167 | pmutex = Mutex.create (); 168 | cv = Condition.create (); 169 | tasks = []; 170 | mutex = Lwt_mutex.create (); 171 | } in 172 | t.thread <- Thread.create thread_loop t; 173 | incr thread_count; 174 | t 175 | 176 | let check_worker_finished worker = 177 | if worker.db.db_finished then 178 | failwith (sprintf "db %d:%S is closed" worker.db.id worker.db.file) 179 | 180 | let detach worker f args = 181 | let result = ref `Nothing in 182 | let task dbh () = 183 | try 184 | result := `Success (f dbh args) 185 | with exn -> 186 | result := `Failure exn in 187 | let waiter, wakener = wait () in 188 | let id = 189 | Lwt_unix.make_notification ~once:true 190 | (fun () -> 191 | match !result with 192 | | `Nothing -> 193 | wakeup_exn wakener (Failure "Sqlexpr_sqlite.detach") 194 | | `Success value -> 195 | wakeup wakener value 196 | | `Failure exn -> 197 | wakeup_exn wakener exn) in 198 | let thread = worker.worker_thread in 199 | ( 200 | WSet.remove worker.db.free_workers worker; 201 | let%lwt () = 202 | Lwt_mutex.with_lock thread.mutex 203 | (fun () -> 204 | try%lwt 205 | check_worker_finished worker; 206 | (* Send the id and the task to the worker: *) 207 | Mutex.lock thread.pmutex; 208 | thread.tasks <- (id, task worker.handle) :: thread.tasks; 209 | Mutex.unlock thread.pmutex; 210 | Condition.signal thread.cv; 211 | return () 212 | with e -> wakeup_exn wakener e; return ()) 213 | in 214 | waiter 215 | )[%finally 216 | WSet.add worker.db.free_workers worker; 217 | return () 218 | ] 219 | 220 | let () = do_detach := detach 221 | 222 | (* Add a thread to the pool: *) 223 | let add_thread thread = 224 | match Lwt_sequence.take_opt_l waiters with 225 | | None -> Queue.add thread threads 226 | | Some t -> wakeup t thread 227 | 228 | (* Add a worker to the pool: *) 229 | let add_worker db worker = 230 | match Lwt_sequence.take_opt_l db.db_waiters with 231 | | None -> WSet.add db.free_workers worker 232 | | Some w -> wakeup w worker 233 | 234 | (* Wait for thread to be available, then return it: *) 235 | let get_thread () = 236 | if not (Queue.is_empty threads) then 237 | return (Queue.take threads) 238 | else if !thread_count < !max_threads then 239 | return (make_thread ()) 240 | else begin 241 | let (res, w) = Lwt.task () in 242 | let node = Lwt_sequence.add_r w waiters in 243 | Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); 244 | res 245 | end 246 | 247 | let make_worker db = 248 | db.worker_count <- db.worker_count + 1; 249 | let%lwt thread = get_thread () in 250 | (try%lwt 251 | let worker = 252 | { 253 | db = db; 254 | worker_id = new_id (); 255 | handle = Sqlite3.db_open ":memory:"; 256 | stmts = WT.create 13; 257 | stmt_cache = Stmt_cache.create (); 258 | worker_thread = thread; 259 | } in 260 | let%lwt handle = 261 | detach worker 262 | (fun _ () -> 263 | let handle = Sqlite3.db_open db.file in 264 | db.init_func handle; 265 | handle) 266 | () 267 | in worker.handle <- handle; 268 | db.workers <- worker :: db.workers; 269 | add_worker db worker; 270 | return worker 271 | with e -> 272 | db.worker_count <- db.worker_count - 1; 273 | Lwt.fail e 274 | ) 275 | [%finally 276 | add_thread thread; 277 | return () 278 | ] 279 | 280 | let do_raise_error ?sql ?params ?errmsg errcode = 281 | let msg = Sqlite3.Rc.to_string errcode ^ Option.map_default ((^) " ") "" errmsg in 282 | let msg = match sql with 283 | None -> msg 284 | | Some sql -> sprintf "%s in %s" msg (prettify_sql_stmt sql) in 285 | let msg = match params with 286 | None | Some [] -> msg 287 | | Some params -> 288 | sprintf "%s with params %s" msg (string_of_params (List.rev params)) 289 | in raise (Error (msg, Sqlite_error (msg, errcode))) 290 | 291 | let raise_error worker ?sql ?params ?errmsg errcode = 292 | let%lwt errmsg = match errmsg with 293 | Some e -> return e 294 | | None -> detach worker (fun dbh () -> Sqlite3.errmsg dbh) () 295 | in 296 | Lwt.catch 297 | (fun () -> do_raise_error ?sql ?params ~errmsg errcode) 298 | Lwt.fail 299 | 300 | let rec run ?(retry_on_busy = !retry_on_busy) ?stmt ?sql ?params worker f x = 301 | detach worker f x >>= function 302 | Sqlite3.Rc.OK | Sqlite3.Rc.ROW | Sqlite3.Rc.DONE as r -> return r 303 | | Sqlite3.Rc.BUSY when retry_on_busy -> 304 | let%lwt () = Lwt_unix.sleep 0.010 in run ~retry_on_busy ?sql ?stmt ?params worker f x 305 | | code -> 306 | let%lwt errmsg = detach worker (fun dbh () -> Sqlite3.errmsg dbh) () in 307 | let%lwt () = begin match stmt with 308 | None -> return () 309 | | Some stmt -> let%lwt _ = detach worker (fun _dbh -> Stmt.reset) stmt in return () 310 | end in 311 | raise_error worker ?sql ?params ~errmsg code 312 | 313 | let check_ok ?retry_on_busy ?stmt ?sql ?params worker f x = 314 | let%lwt _ = run ?retry_on_busy ?stmt ?sql ?params worker f x in return () 315 | 316 | (* Wait for worker to be available, then return it: *) 317 | let get_worker db = 318 | if not (WSet.is_empty db.free_workers) then 319 | return (WSet.take db.free_workers) 320 | else if db.worker_count < db.max_workers then 321 | make_worker db 322 | else begin 323 | let (res, w) = Lwt.task () in 324 | let node = Lwt_sequence.add_r w db.db_waiters in 325 | Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); 326 | res 327 | end 328 | 329 | let prepare db f (params, nparams, sql, stmt_id) = 330 | let%lwt worker = get_worker db in 331 | let%lwt () = 332 | try%lwt 333 | return (check_worker_finished worker) 334 | with exn -> Lwt.fail exn 335 | in 336 | let%lwt stmt = 337 | try%lwt 338 | match stmt_id with 339 | None -> 340 | profile_prepare_stmt sql 341 | (fun () -> 342 | let%lwt stmt = detach worker Stmt.prepare sql in 343 | WT.add worker.stmts stmt; 344 | return stmt) 345 | | Some id -> 346 | match Stmt_cache.find_remove_stmt worker.stmt_cache id with 347 | Some stmt -> 348 | let%lwt () = 349 | begin try%lwt 350 | check_ok ~stmt worker (fun _ -> Stmt.reset) stmt 351 | with e -> 352 | (* drop the stmt *) 353 | let%lwt () = detach worker (fun _ -> Stmt.finalize) stmt in 354 | Lwt.fail e 355 | end 356 | in 357 | return stmt 358 | | None -> 359 | profile_prepare_stmt sql 360 | (fun () -> 361 | let%lwt stmt = detach worker Stmt.prepare sql in 362 | WT.add worker.stmts stmt; 363 | return stmt) 364 | with e -> 365 | add_worker db worker; 366 | let s = sprintf "Error with SQL statement %s" sql in 367 | Lwt.fail (Error (s, e)) in 368 | 369 | let%lwt () = 370 | (* the list of params is reversed *) 371 | ( detach worker 372 | (fun _dbh stmt -> 373 | let n = ref nparams in 374 | List.iter 375 | (fun v -> match Stmt.bind stmt !n v with 376 | Sqlite3.Rc.OK -> decr n 377 | | code -> do_raise_error ~sql ~params code) 378 | params) 379 | stmt 380 | )[%finally 381 | add_worker db worker; 382 | return () 383 | ] 384 | in 385 | profile_execute_sql sql ~params 386 | (fun () -> 387 | (f (worker, stmt) sql params) 388 | [%finally 389 | match stmt_id with 390 | Some id -> Stmt_cache.add_stmt worker.stmt_cache id stmt; return () 391 | | None -> return () 392 | ] 393 | ) 394 | 395 | let borrow_worker db f = 396 | let db' = 397 | { (open_db ~init:db.init_func db.file) with 398 | max_workers = 1; 399 | worker_count = 1; 400 | tx_key = db.tx_key; 401 | } in 402 | let%lwt worker = get_worker db in 403 | add_worker db' { worker with db = db' } ; 404 | add_worker db worker; 405 | (f db') 406 | [%finally 407 | db'.workers <- []; 408 | close_db db'; 409 | return () 410 | ] 411 | 412 | let steal_worker db f = 413 | let db' = 414 | { (open_db ~init:db.init_func db.file) with 415 | max_workers = 1; 416 | worker_count = 1; 417 | tx_key = db.tx_key; 418 | } in 419 | let%lwt worker = get_worker db in 420 | add_worker db' { worker with db = db' } ; 421 | (f db') 422 | [%finally 423 | db'.workers <- []; 424 | close_db db'; 425 | add_worker db worker; 426 | return () 427 | ] 428 | 429 | let step ?sql ?params (worker, stmt) = 430 | run ?sql ?params ~stmt worker (fun _ -> Stmt.step) stmt 431 | 432 | let step_with_last_insert_rowid ?sql ?params ((worker, _) as stmt) = 433 | let%lwt _ = step ?sql ?params stmt in 434 | detach worker (fun dbh () -> Sqlite3.last_insert_rowid dbh) () 435 | 436 | let reset_with_errcode (worker, stmt) = 437 | detach worker (fun _ -> Stmt.reset) stmt 438 | 439 | let reset x = let%lwt _ = reset_with_errcode x in return () 440 | 441 | let row_data (worker, stmt) = detach worker (fun _ -> Stmt.row_data) stmt 442 | 443 | let unsafe_execute db ?retry_on_busy sql = 444 | let%lwt worker = get_worker db in 445 | (check_ok ?retry_on_busy ~sql worker (fun dbh sql -> Sqlite3.exec dbh sql) sql) 446 | [%finally 447 | add_worker db worker; 448 | return () 449 | ] 450 | 451 | let raise_error (worker, _) ?sql ?params ?errmsg errcode = 452 | raise_error worker ?sql ?params ?errmsg errcode 453 | 454 | type 'a ret = OK of 'a | Error of exn 455 | 456 | let bad_maxrows fname batch = 457 | Invalid_argument (sprintf "Sqlexpr_sqlite.%s: bad batch size (%d)" fname batch) 458 | 459 | let read_rows ~fname (worker, stmt) ~sql params ?(batch = 1000) ~cols read = 460 | let open Sqlexpr_sqlite.Types in 461 | 462 | if batch < 0 then fail @@ bad_maxrows fname batch else 463 | 464 | detach worker 465 | (fun dbh () -> 466 | let rec read_rows_loop n l = 467 | if n <= 0 then Batch_partial (List.rev l) 468 | else 469 | match Stmt.step stmt with 470 | | Sqlite3.Rc.ROW -> begin 471 | let data = Stmt.row_data stmt in 472 | let cols' = Array.length data in 473 | if cols' <> cols then 474 | let msg = 475 | sprintf 476 | "Sqlexpr_sqlite.%s: wrong number of columns \ 477 | (expected %d, got %d) in SQL: %s" fname cols cols' sql 478 | in 479 | Batch_error (List.rev l, Failure msg) 480 | else 481 | match try OK (read data) with exn -> Error exn with 482 | | OK row -> read_rows_loop (n - 1) (row :: l) 483 | | Error exn -> Batch_error (List.rev l, exn) 484 | end 485 | | Sqlite3.Rc.DONE -> Batch_complete (List.rev l) 486 | | rc -> 487 | let errmsg = Sqlite3.errmsg dbh in 488 | let exn = 489 | try 490 | let _ = do_raise_error ~sql ~params ~errmsg rc in Exit 491 | with exn -> exn 492 | in 493 | Batch_error (List.rev l, exn) 494 | in 495 | read_rows_loop batch []) 496 | () 497 | 498 | let read_rows = Some read_rows 499 | end 500 | 501 | include Sqlexpr_sqlite.Make_gen(CONC)(POOL) 502 | 503 | -------------------------------------------------------------------------------- /src/sqlexpr_sqlite_lwt.mli: -------------------------------------------------------------------------------- 1 | (** {!Sqlexpr_sqlite.S} implementation for the Lwt monad that uses thread 2 | * pools to avoid blocking on sqlite3 API calls. *) 3 | 4 | include Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t 5 | 6 | (** [set_max_threads n] sets the maximum number of threads to 7 | * [max n current_thread_count] and returns the new limit *) 8 | val set_max_threads : int -> int 9 | -------------------------------------------------------------------------------- /src/sqlexpr_utils.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | module Option = struct 4 | let may f = function None -> () | Some x -> f x 5 | let map f = function None -> None | Some x -> Some (f x) 6 | let map_default f d o = match o with 7 | | None -> d 8 | | Some x -> f x 9 | end 10 | 11 | module List = struct 12 | let init n f = 13 | let rec init i = 14 | if i=n then [] 15 | else f i :: init (i+1) 16 | in init 0 17 | end 18 | -------------------------------------------------------------------------------- /src/syntax/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let jbuild = {str| 4 | (library 5 | (name pa_sql) 6 | (public_name pa_sqlexpr) 7 | (synopsis "Camlp4 syntax for sqlexpr") 8 | (libraries camlp4 camlp4.quotations.r estring) 9 | (library_flags -linkall) 10 | (preprocess (action (run camlp4orf ${<}))))) 11 | |str} 12 | 13 | let safe_string = 14 | try 15 | List.assoc "safe_string" Jbuild_plugin.V1.ocamlc_config = "true" || 16 | List.assoc "default_safe_string" Jbuild_plugin.V1.ocamlc_config = "true" 17 | with Not_found -> false 18 | 19 | let estring = 20 | try 21 | Sys.getenv "ESTRING" = "enable" 22 | with Not_found -> false 23 | 24 | let () = 25 | Jbuild_plugin.V1.send @@ if estring then jbuild else "" 26 | -------------------------------------------------------------------------------- /src/syntax/pa_sql.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | open Camlp4.PreCast 4 | open Pa_estring 5 | 6 | type output_type = 7 | [ `Int | `Text | `Blob | `Float | `Int32 | `Int64 | `Bool] 8 | 9 | type input_type = [output_type | `Any] 10 | 11 | type no_output_element = [ `Literal of string | `Input of input_type * bool ] 12 | 13 | type sql_element = 14 | [ no_output_element 15 | | `Output of no_output_element list * output_type * bool (* nullable *) ] 16 | 17 | let collected_statements = ref [] 18 | let collected_init_statements = ref [] 19 | 20 | (* [parse_without_output_exprs continuation acc llist] 21 | * parse %x(?) and %%, but don't recognize @x{} expressions, passing a list 22 | * of no_output_elements to the continuation (used for open recursion). *) 23 | let rec parse_without_output_exprs k acc = function 24 | Cons (_, '%', Cons (_, 'd', l)) -> do_parse_in k acc `Int l 25 | | Cons (_, '%', Cons (_, 'l', l)) -> do_parse_in k acc `Int32 l 26 | | Cons (_, '%', Cons (_, 'L', l)) -> do_parse_in k acc `Int64 l 27 | | Cons (_, '%', Cons (_, 's', l)) -> do_parse_in k acc `Text l 28 | | Cons (_, '%', Cons (_, 'S', l)) -> do_parse_in k acc `Blob l 29 | | Cons (_, '%', Cons (_, 'f', l)) -> do_parse_in k acc `Float l 30 | | Cons (_, '%', Cons (_, 'b', l)) -> do_parse_in k acc `Bool l 31 | | Cons (_, '%', Cons (_, 'a', l)) -> do_parse_in k acc `Any l 32 | | Cons (_, '%', Cons (_, '%', l)) -> begin 33 | match acc with 34 | `Literal s :: tl -> k (`Literal (s ^ "%") :: tl) l 35 | | tl -> k (`Literal "%" :: tl) l 36 | end 37 | | Cons (_, '%', Cons (loc, c, l)) -> 38 | Loc.raise loc (Failure (sprintf "Unknown input directive %C" c)) 39 | | Cons (_, c, l) -> begin match acc with 40 | `Literal s :: tl -> k (`Literal (s ^ String.make 1 c) :: tl) l 41 | | tl -> k (`Literal (String.make 1 c) :: tl) l 42 | end 43 | | Nil _ -> List.rev acc 44 | 45 | (* complete the `Input sql_element, recognizing the ? that indicates it's 46 | * nullable, if present *) 47 | and do_parse_in k acc kind = function 48 | | Cons (_, '?', l) -> k (`Input (kind, true) :: acc) l 49 | | l -> k (`Input (kind, false) :: acc) l 50 | 51 | (* @return list of [sql_elements] given a llist *) 52 | let rec parse l : sql_element list = do_parse [] l 53 | 54 | and do_parse acc l = parse_with_output_exprs acc l 55 | 56 | (* like [parse_with_output_exprs] but also recognize @x{...}, returning 57 | * a list of [sql_element]s. Need not use open recursion here, because the 58 | * continuation will always be [do_parse]. *) 59 | and parse_with_output_exprs acc = function 60 | | Cons (_, '@', Cons (_, 'd', l)) -> do_parse_out `Int acc l 61 | | Cons (_, '@', Cons (_, 'l', l)) -> do_parse_out `Int32 acc l 62 | | Cons (_, '@', Cons (_, 'L', l)) -> do_parse_out `Int64 acc l 63 | | Cons (_, '@', Cons (_, 's', l)) -> do_parse_out `Text acc l 64 | | Cons (_, '@', Cons (_, 'S', l)) -> do_parse_out `Blob acc l 65 | | Cons (_, '@', Cons (_, 'f', l)) -> do_parse_out `Float acc l 66 | | Cons (_, '@', Cons (_, 'b', l)) -> do_parse_out `Bool acc l 67 | | Cons (_, '@', Cons (_, '@', l)) -> begin match acc with 68 | `Literal s :: tl -> do_parse (`Literal (s ^ "@") :: tl) l 69 | | tl -> do_parse (`Literal "@" :: tl) l 70 | end 71 | | Cons (_, '@', Cons (loc, c, l)) -> 72 | Loc.raise loc (Failure (sprintf "Unknown output directive %C" c)) 73 | | l -> parse_without_output_exprs do_parse acc l 74 | 75 | (* read the trailing ? and { after a @x output expression delimiter, then read 76 | * the expression up to the next } *) 77 | and do_parse_out kind acc = function 78 | Cons (_, '?', Cons (loc, '{', l)) -> 79 | read_expr acc loc true kind l 80 | | Cons (loc, '{', l) -> 81 | read_expr acc loc false kind l 82 | | Cons (loc, _, _) | Nil loc -> 83 | Loc.raise loc (Failure "Missing expression for output directive") 84 | 85 | (* read the output expression up to the trailing '}'. Disallow output 86 | * expressions when parsing the inner expression. *) 87 | and read_expr acc loc ?(text = "") nullable kind = function 88 | Cons (_, '}', l) -> 89 | let rec parse_output_expr acc l = 90 | parse_without_output_exprs parse_output_expr acc l in 91 | let elms : no_output_element list = parse_output_expr [] (unescape loc text) in 92 | do_parse (`Output (elms, kind, nullable) :: acc) l 93 | | Cons (_, c, l) -> read_expr acc loc ~text:(sprintf "%s%c" text c) nullable kind l 94 | | Nil _ -> 95 | Loc.raise loc (Failure "Unterminated output directive expression") 96 | 97 | let new_id = 98 | let n = ref 0 in 99 | fun () -> 100 | incr n; 101 | sprintf "__pa_sql_%d" !n 102 | 103 | let input_directive_id kind nullable = 104 | let s = match kind with 105 | `Int -> "int" 106 | | `Int32 -> "int32" 107 | | `Int64 -> "int64" 108 | | `Text -> "text" 109 | | `Blob -> "blob" 110 | | `Float -> "float" 111 | | `Bool -> "bool" 112 | | `Any -> "any" 113 | in if nullable then "maybe_" ^ s else s 114 | 115 | let directive_expr ?(_loc = Loc.ghost) = function 116 | `Input (kind, nullable) -> 117 | let id = input_directive_id kind nullable in 118 | <:expr< Sqlexpr.Directives.$lid:id$ >> 119 | | `Literal s -> <:expr< Sqlexpr.Directives.literal $str:s$ >> 120 | 121 | let sql_statement l = 122 | let b = Buffer.create 10 in 123 | let rec append_text = function 124 | `Input _ -> Buffer.add_char b '?' 125 | | `Literal s -> Buffer.add_string b s 126 | in 127 | List.iter append_text l; 128 | Buffer.contents b 129 | 130 | let concat_map f l = List.concat (List.map f l) 131 | 132 | let expand_output_elms = function 133 | | `Output (l, _, _) -> l 134 | | #no_output_element as d -> [d] 135 | 136 | let create_sql_statement _loc ~cacheable sql_elms = 137 | let sql_elms = concat_map expand_output_elms sql_elms in 138 | let k = new_id () in 139 | let st = new_id () in 140 | let exp = 141 | List.fold_right 142 | (fun dir e -> <:expr< $directive_expr dir$ $e$ >>) sql_elms <:expr< $lid:k$ >> in 143 | let id = 144 | let signature = 145 | sprintf "%d-%f-%d-%S" 146 | (Unix.getpid ()) (Unix.gettimeofday ()) (Random.int 0x3FFFFFF) 147 | (sql_statement sql_elms) 148 | in Digest.to_hex (Digest.string signature) in 149 | let stmt_id = 150 | if cacheable then <:expr< Some $str:id$ >> else <:expr< None >> 151 | in 152 | <:expr< 153 | { 154 | Sqlexpr.sql_statement = $str:sql_statement sql_elms$; 155 | stmt_id = $stmt_id$; 156 | directive = (fun [$lid:k$ -> fun [$lid:st$ -> $exp$ $lid:st$]]) 157 | } >> 158 | 159 | let create_sql_expression _loc ~cacheable (sql_elms : sql_element list) = 160 | let statement = create_sql_statement _loc ~cacheable sql_elms in 161 | 162 | let conv_expr kind nullable e = 163 | let expr x = 164 | let name = (if nullable then "maybe_" else "") ^ x in 165 | <:expr< Sqlexpr.Conversion.$lid:name$ $e$ >> 166 | in 167 | match kind with 168 | `Int -> expr "int" 169 | | `Int32 -> expr "int32" 170 | | `Int64 -> expr "int64" 171 | | `Bool -> expr "bool" 172 | | `Float -> expr "float" 173 | | `Text -> expr "text" 174 | | `Blob -> expr "blob" in 175 | 176 | let id = new_id () in 177 | let conv_exprs = 178 | let n = ref 0 in 179 | concat_map 180 | (fun dir -> match dir with 181 | `Output (_, kind, nullable) -> 182 | let i = string_of_int !n in 183 | incr n; 184 | [ conv_expr kind nullable <:expr< $lid:id$.($int:i$) >> ] 185 | | _ -> []) 186 | sql_elms in 187 | let tuple_func = 188 | let e = match conv_exprs with 189 | [] -> assert false 190 | | [x] -> x 191 | | hd :: tl -> <:expr< ( $hd$, $Ast.exCom_of_list tl$ ) >> 192 | in <:expr< fun [$lid:id$ -> $e$] >> 193 | in 194 | <:expr< 195 | { 196 | Sqlexpr.statement = $statement$; 197 | get_data = ($int:string_of_int (List.length conv_exprs)$, 198 | $tuple_func$); 199 | } 200 | >> 201 | 202 | let expand_sql_literal ?(is_init = false) ~cacheable ctx _loc str = 203 | let sql_elms = parse (unescape _loc str) in 204 | let sql_stmt_text = 205 | let no_output = concat_map expand_output_elms sql_elms in 206 | sql_statement no_output in 207 | let push l = l := !l @ [sql_stmt_text] in 208 | push (if is_init then collected_init_statements else collected_statements); 209 | if List.exists (function `Output _ -> true | _ -> false) sql_elms then 210 | create_sql_expression _loc ~cacheable sql_elms 211 | else 212 | create_sql_statement _loc ~cacheable sql_elms 213 | 214 | let string_list_expr ?(_loc = Loc.ghost) = function 215 | [] -> <:expr< [] >> 216 | | l -> 217 | List.fold_left 218 | (fun l e -> <:expr< [ $e$ :: $l$ ] >>) 219 | <:expr< [] >> 220 | (List.rev_map (fun s -> <:expr< $str:s$ >>) l) 221 | 222 | let expand_sqlite_check_functions ctx _loc = 223 | let statement_check = 224 | <:expr< 225 | try 226 | ignore (Sqlite3.prepare db stmt) 227 | with [Sqlite3.Error s -> 228 | do { 229 | ret.val := False; 230 | Format.fprintf fmt "Error in statement %S: %s\n" stmt s 231 | } 232 | ] 233 | >> in 234 | let stmt_list = string_list_expr ~_loc !collected_statements in 235 | let check_in_db_expr = 236 | <:expr< fun db fmt -> 237 | let ret = ref True in 238 | do { 239 | List.iter (fun stmt -> $statement_check$) $stmt_list$; 240 | ret.val; 241 | } 242 | >> in 243 | let init_stmts = string_list_expr ~_loc !collected_init_statements in 244 | let init_db_expr = 245 | <:expr< fun db fmt -> 246 | let ret = ref True in 247 | do { 248 | List.iter 249 | (fun stmt -> 250 | match Sqlite3.exec db stmt with 251 | [ 252 | Sqlite3.Rc.OK -> () 253 | | rc -> do { 254 | ret.val := False; 255 | Format.fprintf fmt "Error in init. SQL statement (%s)@ %S@\n" 256 | (Sqlite3.errmsg db) stmt 257 | } 258 | ]) 259 | $init_stmts$; 260 | ret.val 261 | } >> in 262 | let in_mem_check_expr = 263 | <:expr< 264 | fun fmt -> 265 | let db = Sqlite3.db_open ":memory:" in 266 | init_db db fmt && check_db db fmt 267 | >> 268 | in <:expr< 269 | let init_db = $init_db_expr$ in 270 | let check_db = $check_in_db_expr$ in 271 | let in_mem_check = $in_mem_check_expr$ in 272 | (init_db, check_db, in_mem_check) 273 | >> 274 | 275 | let _ = 276 | Random.self_init (); 277 | register_expr_specifier "sql" 278 | (fun ctx _loc str -> expand_sql_literal ~cacheable:false ctx _loc str); 279 | register_expr_specifier "sqlinit" 280 | (fun ctx _loc str -> 281 | expand_sql_literal ~is_init:true ~cacheable:true ctx _loc str); 282 | register_expr_specifier "sqlc" 283 | (fun ctx _loc str -> 284 | let expr = expand_sql_literal ~cacheable:true ctx _loc str in 285 | let id = register_shared_expr ctx expr in 286 | <:expr< $id:id$ >>); 287 | register_expr_specifier "sql_check" 288 | (fun ctx _loc -> function 289 | "sqlite" -> expand_sqlite_check_functions ctx _loc 290 | | _ -> <:expr< () >>) 291 | 292 | -------------------------------------------------------------------------------- /src/syntax_compat/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let jbuild = {str| 4 | (library 5 | (name pa_sql_) 6 | (public_name sqlexpr.syntax) 7 | (synopsis "Camlp4 syntax for sqlexpr") 8 | (libraries camlp4 camlp4.quotations.r estring) 9 | (library_flags -linkall) 10 | (preprocess (action (run camlp4orf ${<}))))) 11 | |str} 12 | 13 | let safe_string = 14 | try 15 | List.assoc "safe_string" Jbuild_plugin.V1.ocamlc_config = "true" || 16 | List.assoc "default_safe_string" Jbuild_plugin.V1.ocamlc_config = "true" 17 | with Not_found -> false 18 | 19 | let estring = 20 | try 21 | Sys.getenv "ESTRING" = "enable" 22 | with Not_found -> false 23 | 24 | let () = 25 | Jbuild_plugin.V1.send @@ if estring then jbuild else "" 26 | -------------------------------------------------------------------------------- /src/syntax_compat/pa_sql.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | open Camlp4.PreCast 4 | open Pa_estring 5 | 6 | type output_type = 7 | [ `Int | `Text | `Blob | `Float | `Int32 | `Int64 | `Bool] 8 | 9 | type input_type = [output_type | `Any] 10 | 11 | type no_output_element = [ `Literal of string | `Input of input_type * bool ] 12 | 13 | type sql_element = 14 | [ no_output_element 15 | | `Output of no_output_element list * output_type * bool (* nullable *) ] 16 | 17 | let collected_statements = ref [] 18 | let collected_init_statements = ref [] 19 | 20 | (* [parse_without_output_exprs continuation acc llist] 21 | * parse %x(?) and %%, but don't recognize @x{} expressions, passing a list 22 | * of no_output_elements to the continuation (used for open recursion). *) 23 | let rec parse_without_output_exprs k acc = function 24 | Cons (_, '%', Cons (_, 'd', l)) -> do_parse_in k acc `Int l 25 | | Cons (_, '%', Cons (_, 'l', l)) -> do_parse_in k acc `Int32 l 26 | | Cons (_, '%', Cons (_, 'L', l)) -> do_parse_in k acc `Int64 l 27 | | Cons (_, '%', Cons (_, 's', l)) -> do_parse_in k acc `Text l 28 | | Cons (_, '%', Cons (_, 'S', l)) -> do_parse_in k acc `Blob l 29 | | Cons (_, '%', Cons (_, 'f', l)) -> do_parse_in k acc `Float l 30 | | Cons (_, '%', Cons (_, 'b', l)) -> do_parse_in k acc `Bool l 31 | | Cons (_, '%', Cons (_, 'a', l)) -> do_parse_in k acc `Any l 32 | | Cons (_, '%', Cons (_, '%', l)) -> begin 33 | match acc with 34 | `Literal s :: tl -> k (`Literal (s ^ "%") :: tl) l 35 | | tl -> k (`Literal "%" :: tl) l 36 | end 37 | | Cons (_, '%', Cons (loc, c, l)) -> 38 | Loc.raise loc (Failure (sprintf "Unknown input directive %C" c)) 39 | | Cons (_, c, l) -> begin match acc with 40 | `Literal s :: tl -> k (`Literal (s ^ String.make 1 c) :: tl) l 41 | | tl -> k (`Literal (String.make 1 c) :: tl) l 42 | end 43 | | Nil _ -> List.rev acc 44 | 45 | (* complete the `Input sql_element, recognizing the ? that indicates it's 46 | * nullable, if present *) 47 | and do_parse_in k acc kind = function 48 | | Cons (_, '?', l) -> k (`Input (kind, true) :: acc) l 49 | | l -> k (`Input (kind, false) :: acc) l 50 | 51 | (* @return list of [sql_elements] given a llist *) 52 | let rec parse l : sql_element list = do_parse [] l 53 | 54 | and do_parse acc l = parse_with_output_exprs acc l 55 | 56 | (* like [parse_with_output_exprs] but also recognize @x{...}, returning 57 | * a list of [sql_element]s. Need not use open recursion here, because the 58 | * continuation will always be [do_parse]. *) 59 | and parse_with_output_exprs acc = function 60 | | Cons (_, '@', Cons (_, 'd', l)) -> do_parse_out `Int acc l 61 | | Cons (_, '@', Cons (_, 'l', l)) -> do_parse_out `Int32 acc l 62 | | Cons (_, '@', Cons (_, 'L', l)) -> do_parse_out `Int64 acc l 63 | | Cons (_, '@', Cons (_, 's', l)) -> do_parse_out `Text acc l 64 | | Cons (_, '@', Cons (_, 'S', l)) -> do_parse_out `Blob acc l 65 | | Cons (_, '@', Cons (_, 'f', l)) -> do_parse_out `Float acc l 66 | | Cons (_, '@', Cons (_, 'b', l)) -> do_parse_out `Bool acc l 67 | | Cons (_, '@', Cons (_, '@', l)) -> begin match acc with 68 | `Literal s :: tl -> do_parse (`Literal (s ^ "@") :: tl) l 69 | | tl -> do_parse (`Literal "@" :: tl) l 70 | end 71 | | Cons (_, '@', Cons (loc, c, l)) -> 72 | Loc.raise loc (Failure (sprintf "Unknown output directive %C" c)) 73 | | l -> parse_without_output_exprs do_parse acc l 74 | 75 | (* read the trailing ? and { after a @x output expression delimiter, then read 76 | * the expression up to the next } *) 77 | and do_parse_out kind acc = function 78 | Cons (_, '?', Cons (loc, '{', l)) -> 79 | read_expr acc loc true kind l 80 | | Cons (loc, '{', l) -> 81 | read_expr acc loc false kind l 82 | | Cons (loc, _, _) | Nil loc -> 83 | Loc.raise loc (Failure "Missing expression for output directive") 84 | 85 | (* read the output expression up to the trailing '}'. Disallow output 86 | * expressions when parsing the inner expression. *) 87 | and read_expr acc loc ?(text = "") nullable kind = function 88 | Cons (_, '}', l) -> 89 | let rec parse_output_expr acc l = 90 | parse_without_output_exprs parse_output_expr acc l in 91 | let elms : no_output_element list = parse_output_expr [] (unescape loc text) in 92 | do_parse (`Output (elms, kind, nullable) :: acc) l 93 | | Cons (_, c, l) -> read_expr acc loc ~text:(sprintf "%s%c" text c) nullable kind l 94 | | Nil _ -> 95 | Loc.raise loc (Failure "Unterminated output directive expression") 96 | 97 | let new_id = 98 | let n = ref 0 in 99 | fun () -> 100 | incr n; 101 | sprintf "__pa_sql_%d" !n 102 | 103 | let input_directive_id kind nullable = 104 | let s = match kind with 105 | `Int -> "int" 106 | | `Int32 -> "int32" 107 | | `Int64 -> "int64" 108 | | `Text -> "text" 109 | | `Blob -> "blob" 110 | | `Float -> "float" 111 | | `Bool -> "bool" 112 | | `Any -> "any" 113 | in if nullable then "maybe_" ^ s else s 114 | 115 | let directive_expr ?(_loc = Loc.ghost) = function 116 | `Input (kind, nullable) -> 117 | let id = input_directive_id kind nullable in 118 | <:expr< Sqlexpr.Directives.$lid:id$ >> 119 | | `Literal s -> <:expr< Sqlexpr.Directives.literal $str:s$ >> 120 | 121 | let sql_statement l = 122 | let b = Buffer.create 10 in 123 | let rec append_text = function 124 | `Input _ -> Buffer.add_char b '?' 125 | | `Literal s -> Buffer.add_string b s 126 | in 127 | List.iter append_text l; 128 | Buffer.contents b 129 | 130 | let concat_map f l = List.concat (List.map f l) 131 | 132 | let expand_output_elms = function 133 | | `Output (l, _, _) -> l 134 | | #no_output_element as d -> [d] 135 | 136 | let create_sql_statement _loc ~cacheable sql_elms = 137 | let sql_elms = concat_map expand_output_elms sql_elms in 138 | let k = new_id () in 139 | let st = new_id () in 140 | let exp = 141 | List.fold_right 142 | (fun dir e -> <:expr< $directive_expr dir$ $e$ >>) sql_elms <:expr< $lid:k$ >> in 143 | let id = 144 | let signature = 145 | sprintf "%d-%f-%d-%S" 146 | (Unix.getpid ()) (Unix.gettimeofday ()) (Random.int 0x3FFFFFF) 147 | (sql_statement sql_elms) 148 | in Digest.to_hex (Digest.string signature) in 149 | let stmt_id = 150 | if cacheable then <:expr< Some $str:id$ >> else <:expr< None >> 151 | in 152 | <:expr< 153 | { 154 | Sqlexpr.sql_statement = $str:sql_statement sql_elms$; 155 | stmt_id = $stmt_id$; 156 | directive = (fun [$lid:k$ -> fun [$lid:st$ -> $exp$ $lid:st$]]) 157 | } >> 158 | 159 | let create_sql_expression _loc ~cacheable (sql_elms : sql_element list) = 160 | let statement = create_sql_statement _loc ~cacheable sql_elms in 161 | 162 | let conv_expr kind nullable e = 163 | let expr x = 164 | let name = (if nullable then "maybe_" else "") ^ x in 165 | <:expr< Sqlexpr.Conversion.$lid:name$ $e$ >> 166 | in 167 | match kind with 168 | `Int -> expr "int" 169 | | `Int32 -> expr "int32" 170 | | `Int64 -> expr "int64" 171 | | `Bool -> expr "bool" 172 | | `Float -> expr "float" 173 | | `Text -> expr "text" 174 | | `Blob -> expr "blob" in 175 | 176 | let id = new_id () in 177 | let conv_exprs = 178 | let n = ref 0 in 179 | concat_map 180 | (fun dir -> match dir with 181 | `Output (_, kind, nullable) -> 182 | let i = string_of_int !n in 183 | incr n; 184 | [ conv_expr kind nullable <:expr< $lid:id$.($int:i$) >> ] 185 | | _ -> []) 186 | sql_elms in 187 | let tuple_func = 188 | let e = match conv_exprs with 189 | [] -> assert false 190 | | [x] -> x 191 | | hd :: tl -> <:expr< ( $hd$, $Ast.exCom_of_list tl$ ) >> 192 | in <:expr< fun [$lid:id$ -> $e$] >> 193 | in 194 | <:expr< 195 | { 196 | Sqlexpr.statement = $statement$; 197 | get_data = ($int:string_of_int (List.length conv_exprs)$, 198 | $tuple_func$); 199 | } 200 | >> 201 | 202 | let expand_sql_literal ?(is_init = false) ~cacheable ctx _loc str = 203 | let sql_elms = parse (unescape _loc str) in 204 | let sql_stmt_text = 205 | let no_output = concat_map expand_output_elms sql_elms in 206 | sql_statement no_output in 207 | let push l = l := !l @ [sql_stmt_text] in 208 | push (if is_init then collected_init_statements else collected_statements); 209 | if List.exists (function `Output _ -> true | _ -> false) sql_elms then 210 | create_sql_expression _loc ~cacheable sql_elms 211 | else 212 | create_sql_statement _loc ~cacheable sql_elms 213 | 214 | let string_list_expr ?(_loc = Loc.ghost) = function 215 | [] -> <:expr< [] >> 216 | | l -> 217 | List.fold_left 218 | (fun l e -> <:expr< [ $e$ :: $l$ ] >>) 219 | <:expr< [] >> 220 | (List.rev_map (fun s -> <:expr< $str:s$ >>) l) 221 | 222 | let expand_sqlite_check_functions ctx _loc = 223 | let statement_check = 224 | <:expr< 225 | try 226 | ignore (Sqlite3.prepare db stmt) 227 | with [Sqlite3.Error s -> 228 | do { 229 | ret.val := False; 230 | Format.fprintf fmt "Error in statement %S: %s\n" stmt s 231 | } 232 | ] 233 | >> in 234 | let stmt_list = string_list_expr ~_loc !collected_statements in 235 | let check_in_db_expr = 236 | <:expr< fun db fmt -> 237 | let ret = ref True in 238 | do { 239 | List.iter (fun stmt -> $statement_check$) $stmt_list$; 240 | ret.val; 241 | } 242 | >> in 243 | let init_stmts = string_list_expr ~_loc !collected_init_statements in 244 | let init_db_expr = 245 | <:expr< fun db fmt -> 246 | let ret = ref True in 247 | do { 248 | List.iter 249 | (fun stmt -> 250 | match Sqlite3.exec db stmt with 251 | [ 252 | Sqlite3.Rc.OK -> () 253 | | rc -> do { 254 | ret.val := False; 255 | Format.fprintf fmt "Error in init. SQL statement (%s)@ %S@\n" 256 | (Sqlite3.errmsg db) stmt 257 | } 258 | ]) 259 | $init_stmts$; 260 | ret.val 261 | } >> in 262 | let in_mem_check_expr = 263 | <:expr< 264 | fun fmt -> 265 | let db = Sqlite3.db_open ":memory:" in 266 | init_db db fmt && check_db db fmt 267 | >> 268 | in <:expr< 269 | let init_db = $init_db_expr$ in 270 | let check_db = $check_in_db_expr$ in 271 | let in_mem_check = $in_mem_check_expr$ in 272 | (init_db, check_db, in_mem_check) 273 | >> 274 | 275 | let _ = 276 | Random.self_init (); 277 | register_expr_specifier "sql" 278 | (fun ctx _loc str -> expand_sql_literal ~cacheable:false ctx _loc str); 279 | register_expr_specifier "sqlinit" 280 | (fun ctx _loc str -> 281 | expand_sql_literal ~is_init:true ~cacheable:true ctx _loc str); 282 | register_expr_specifier "sqlc" 283 | (fun ctx _loc str -> 284 | let expr = expand_sql_literal ~cacheable:true ctx _loc str in 285 | let id = register_shared_expr ctx expr in 286 | <:expr< $id:id$ >>); 287 | register_expr_specifier "sql_check" 288 | (fun ctx _loc -> function 289 | "sqlite" -> expand_sqlite_check_functions ctx _loc 290 | | _ -> <:expr< () >>) 291 | 292 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | bm_sqlexpr_sqlite_lwt 2 | t_sqlexpr_sqlite 3 | -------------------------------------------------------------------------------- /tests/ppx/OMakefile: -------------------------------------------------------------------------------- 1 | EXTENSIONS = $(ROOT)/src/ppx/ppx_sqlexpr 2 | 3 | .SCANNER: scan-ocaml-%.ml: %.ml $(EXTENSIONS) 4 | .SCANNER: scan-ocaml-%.mli: %.mli $(EXTENSIONS) 5 | 6 | OCAMLINCLUDES += $(ROOT)/src 7 | OCAML_LIBS[] += $(ROOT)/src/sqlexpr 8 | 9 | section 10 | OCAMLPACKS[] = 11 | compiler-libs.common 12 | csv 13 | lwt 14 | lwt_ppx 15 | lwt.unix 16 | ppx_tools.metaquot 17 | re.pcre 18 | sqlite3 19 | threads 20 | oUnit 21 | unix 22 | 23 | OCAMLFINDFLAGS = -ppx $(ROOT)/src/ppx/ppx_sqlexpr -ppxopt lwt.ppx,-no-debug 24 | OCAMLDEPFLAGS = -ppx $(ROOT)/src/ppx/ppx_sqlexpr 25 | 26 | OCamlProgram(t_parse, t_parse) 27 | OCamlProgram(t_sqlexpr, t_sqlexpr) 28 | $(addsuffixes .o .cmx .cmi .cmo, t_parse t_sqlexpr): 29 | 30 | .PHONY: test 31 | test: t_sqlexpr$(EXE) t_parse$(EXE) 32 | ./t_sqlexpr 33 | ./t_parse 34 | 35 | # vim: set ts=8 expandtab sw=4: 36 | -------------------------------------------------------------------------------- /tests/ppx/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name example) 3 | (modules example) 4 | (libraries sqlexpr oUnit) 5 | (preprocess (pps ppx_sqlexpr))) 6 | 7 | (executable 8 | (name t_parse) 9 | (modules t_parse) 10 | (flags (:standard -w -33)) 11 | (libraries sqlexpr oUnit) 12 | (preprocess (pps ppx_sqlexpr))) 13 | 14 | (alias 15 | (name runtest) 16 | (package ppx_sqlexpr) 17 | (action (run %{exe:t_parse.exe}))) 18 | 19 | (executable 20 | (name t_sqlexpr) 21 | (modules t_sqlexpr) 22 | (flags (:standard -w -33)) 23 | (libraries sqlexpr oUnit lwt) 24 | (preprocess (pps ppx_sqlexpr lwt_ppx))) 25 | 26 | (alias 27 | (name runtest) 28 | (package ppx_sqlexpr) 29 | (action (run %{exe:t_sqlexpr.exe}))) 30 | 31 | -------------------------------------------------------------------------------- /tests/ppx/example.ml: -------------------------------------------------------------------------------- 1 | 2 | module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) 3 | module S = Sqlexpr 4 | 5 | let init_db db = 6 | S.execute db 7 | [%sqlinit "CREATE TABLE IF NOT EXISTS users( 8 | id INTEGER PRIMARY KEY, 9 | login TEXT UNIQUE, 10 | password TEXT NON NULL, 11 | name TEXT, 12 | email TEXT 13 | );"] 14 | 15 | let fold_users db f acc = 16 | S.fold db f acc [%sqlc "SELECT @s{login}, @s{password}, @s?{email} FROM users"] 17 | 18 | let insert_user db ~login ~password ?name ?email () = 19 | S.insert db 20 | [%sqlc"INSERT INTO users(login, password, name, email) 21 | VALUES(%s, %s, %s?, %s?)"] 22 | login password name email 23 | 24 | let auto_init_db, check_db, auto_check_db = [%sqlcheck "sqlite"] 25 | -------------------------------------------------------------------------------- /tests/ppx/t_parse.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) 4 | module S = Sqlexpr 5 | 6 | let ae = assert_equal ~printer:(fun x -> x) 7 | 8 | let pqi (d : ('a , 'b) S.statement) = d.S.sql_statement 9 | let pq (d : ('a, 'b, 'c) S.expression) = pqi d.S.statement 10 | 11 | let test_sql _ = 12 | 13 | let s = pqi [%sql "insert into values(%s{foo}, %s{bar})"] in 14 | ae "insert into values(?{foo}, ?{bar})" s; 15 | 16 | let s = pq [%sql "@d{kilroy} was @s{here}"] in 17 | ae "kilroy was here" s; 18 | 19 | (* dots in column names should be okay *) 20 | let s = pq [%sql "select @d{t1.id}, @s{t1.label} from table as t1 ..."] in 21 | ae "select t1.id, t1.label from table as t1 ..." s; 22 | 23 | (* verifies the order of regex substitution. output substitution pass runs 24 | * before the input pass to avoid injecting valid sqlexpr metacharacter '?'. 25 | * For example, given the following string, running the input pass first would 26 | * result in a valid sqlexpr string, leading to an incorrect substitiion in 27 | * the output pass. never mind that immediately adjacent inputs+outputs in 28 | * valid SQL are extremely unlikely... *) 29 | let s = pqi [%sql "@s%d{abc}"] in 30 | ae "@s?{abc}" s; 31 | 32 | (* test invalid expressions and adjacencies *) 33 | let s = pq [%sql "@s@s %d@s{abc}%d@s%d@s%d{def}%d{ghi}@s"] in 34 | ae "@s@s ?abc?@s?@s?{def}?{ghi}@s" s; 35 | 36 | (* check that outputs are preserved, even if non-alphanumeric *) 37 | (* also check that whitespace is preserved *) 38 | let s = pq [%sql "@s{:kilroy} @@was %@{here}"] in 39 | ae ":kilroy @@was %@{here}" s; 40 | 41 | (* interpolation inside outputs should be allowed *) 42 | let s = pq [%sql "select @d{%d}"] in 43 | ae "select ?" s; 44 | 45 | (* allow some other non-alphanumeric characters *) 46 | let s = pq [%sql "select @d{COUNT(*)} FROM foo"] in 47 | ae "select COUNT(*) FROM foo" s; 48 | 49 | (* allow spaces inside outputs *) 50 | let s = pq [%sql "@d{count (*)}"] in 51 | ae "count (*)" s; 52 | 53 | let s = pqi [%sql "excellent"] in 54 | ae "excellent" s 55 | 56 | 57 | let test_quotes _ = 58 | 59 | (* single quotes *) 60 | let s = pq [%sql "strftime('%s-%d', %s-%d @s{abc}%d{def} '@s{abc}%d{def}')"] in 61 | ae "strftime('%s-%d', ?-? abc?{def} '@s{abc}%d{def}')" s; 62 | 63 | (* double quotes *) 64 | let s = pq [%sql{|strftime("%s-%d", %s-%d @s{abc}%d{def} "@s{abc}%d{def}")|}] in 65 | ae {|strftime("%s-%d", ?-? abc?{def} "@s{abc}%d{def}")|} s; 66 | 67 | (* mixed quotes and nested quotes *) 68 | let s = pq [%sql {|@s{abc}"@s{def}"'@d{ghi}''%f'%f"%S"%S "'@s{jkl}%d'" '"%d'"|}] in 69 | ae {|abc"@s{def}"'@d{ghi}''%f'?"%S"? "'@s{jkl}%d'" '"%d'"|} s; 70 | 71 | (* more nested and unbalanced quotes *) 72 | let s = pqi [%sql {|"'%d'" %d '"%d"' "'%d"'|}] in 73 | ae {|"'%d'" ? '"%d"' "'%d"'|} s; 74 | 75 | (* allow a quoted 'column' name *) 76 | let s = pq [%sql {|@s{'hello'}|}] in 77 | ae {|'hello'|} s 78 | 79 | 80 | let tests = 81 | "ppx_tests">::: [ 82 | "test_sql">::test_sql; 83 | "test_quotes">::test_quotes; 84 | ] 85 | 86 | let _ = run_test_tt_main tests 87 | -------------------------------------------------------------------------------- /tests/ppx/t_sqlexpr.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | open OUnit 4 | 5 | let aeq_int = assert_equal ~printer:(sprintf "%d") 6 | let aeq_str = assert_equal ~printer:(sprintf "%S") 7 | let aeq_float = assert_equal ~printer:(sprintf "%f") 8 | let aeq_int32 = assert_equal ~printer:(sprintf "%ld") 9 | let aeq_int64 = assert_equal ~printer:(sprintf "%Ld") 10 | let aeq_bool = assert_equal ~printer:string_of_bool 11 | 12 | let aeq_list ~printer = 13 | assert_equal 14 | ~printer:(fun l -> "[ " ^ String.concat "; " (List.map printer l) ^ " ]") 15 | 16 | module Test 17 | (Lwt : sig 18 | include Sqlexpr_concurrency.THREAD 19 | val iter : ('a -> unit t) -> 'a list -> unit t 20 | val run : 'a t -> 'a 21 | end) 22 | (Sqlexpr : sig 23 | include Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t 24 | end) = 25 | struct 26 | open Lwt 27 | module S = Sqlexpr 28 | 29 | let (>|=) f g = bind f (fun x -> return (g x)) 30 | let (>>=) = Lwt.bind 31 | 32 | (* schema changes to :memory: db made by a Sqlexpr_sqlite_lwt worker are not 33 | * seen by the others, so allow to use a file by doing ~in_mem:false *) 34 | let with_db ?(in_mem = true) f x = 35 | let file = 36 | if in_mem then ":memory:" else Filename.temp_file "t_sqlexpr_sqlite_" "" in 37 | let db = S.open_db file in 38 | let%lwt () = try%lwt 39 | f db x 40 | with _ -> return () in 41 | S.close_db db; 42 | if not in_mem then Sys.remove file; 43 | return () 44 | 45 | let test_execute () = 46 | with_db 47 | (fun db () -> 48 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY)"] >>= fun () -> 49 | S.execute db [%sqlc "CREATE TABLE bar(id INTEGER PRIMARY KEY)"] >>= fun () -> 50 | return ()) 51 | () 52 | 53 | let insert_d db l = 54 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)"] >>= fun () -> 55 | iter (S.execute db [%sql "INSERT INTO foo(v) VALUES(%d)"]) l 56 | 57 | let insert_l db l = 58 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)"] >>= fun () -> 59 | iter (S.execute db [%sql "INSERT INTO foo(v) VALUES(%l)"]) l 60 | 61 | let insert_L db l = 62 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)"] >>= fun () -> 63 | iter (S.execute db [%sql "INSERT INTO foo(v) VALUES(%L)"]) l 64 | 65 | let insert_f db l = 66 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY, v FLOAT)"] >>= fun () -> 67 | iter (S.execute db [%sql "INSERT INTO foo(v) VALUES(%f)"]) l 68 | 69 | let insert_s db l = 70 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY, v TEXT)"] >>= fun () -> 71 | iter (S.execute db [%sql "INSERT INTO foo(v) VALUES(%s)"]) l 72 | 73 | let insert_S db l = 74 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY, v BLOB)"] >>= fun () -> 75 | iter (S.execute db [%sql "INSERT INTO foo(v) VALUES(%S)"]) l 76 | 77 | let insert_b db l = 78 | S.execute db [%sql "CREATE TABLE foo(id INTEGER PRIMARY KEY, v BOOLEAN)"] >>= fun () -> 79 | iter (S.execute db [%sql "INSERT INTO foo(v) VALUES(%b)"]) l 80 | 81 | let test_directive_d () = with_db insert_d [1] 82 | let test_directive_l () = with_db insert_l [1l] 83 | let test_directive_L () = with_db insert_L [1L] 84 | let test_directive_f () = with_db insert_f [3.14] 85 | let test_directive_s () = with_db insert_s ["foo"] 86 | let test_directive_S () = with_db insert_S ["blob"] 87 | let test_directive_b () = with_db insert_b [true] 88 | 89 | let test_oexpr fmt insert expr l () = 90 | with_db 91 | (fun db () -> 92 | let n = ref 1 in 93 | insert db l >>= fun () -> 94 | let l = List.map (fun x -> let i = !n in incr n; (i, x)) l in 95 | let%lwt l' = S.select db expr in 96 | let l' = List.sort compare l' in 97 | aeq_list ~printer:(fun (id, x) -> sprintf ("(%d, " ^^ fmt ^^ ")") id x) 98 | l l'; 99 | return ()) 100 | () 101 | 102 | let test_nullable_oexpr fmt insert expr l () = 103 | with_db 104 | (fun db () -> 105 | let n = ref 1 in 106 | insert db l >>= fun () -> 107 | let l = List.map (fun x -> let i = !n in incr n; (i, Some x)) l in 108 | let%lwt l' = S.select db expr in 109 | let l' = List.sort compare l' in 110 | aeq_list 111 | ~printer:(fun (id, x) -> match x with 112 | None -> sprintf "(%d, None)" id 113 | | Some x -> sprintf ("(%d, Some " ^^ fmt ^^ ")") id x) 114 | l l'; 115 | return ()) 116 | () 117 | 118 | let test_oexpr_directives = 119 | with_db 120 | (fun db () -> 121 | S.select db [%sql "SELECT @d{%d}"] 42 >|= aeq_list ~printer:(sprintf "%d") [42] >>= fun () -> 122 | S.select db [%sql "SELECT @f{%d}"] 42 >|= aeq_list ~printer:(sprintf "%f") [42.] >>= fun () -> 123 | S.select db [%sql "SELECT @s{%d}"] 42 >|= aeq_list ~printer:(sprintf "%s") ["42"]) 124 | 125 | let (>::) name f = name >:: (fun () -> run (f ())) 126 | 127 | let test_directives = 128 | [ 129 | "%d" >:: test_directive_d; 130 | "%l" >:: test_directive_l; 131 | "%L" >:: test_directive_L; 132 | "%f" >:: test_directive_f; 133 | "%s" >:: test_directive_s; 134 | "%S" >:: test_directive_S; 135 | "%b" >:: test_directive_b; 136 | ] 137 | 138 | let test_outputs = 139 | let t = test_oexpr in 140 | let tn = test_nullable_oexpr in 141 | [ 142 | "%d" >:: t "%d" insert_d [%sql "SELECT @d{id}, @d{v} FROM foo"] [1;-1;3;4]; 143 | "%l" >:: t "%ld" insert_l [%sql "SELECT @d{id}, @l{v} FROM foo"] [1l;-1l;3l;4l]; 144 | "%L" >:: t "%Ld" insert_L [%sql "SELECT @d{id}, @L{v} FROM foo"] [1L;-1L;3L;4L]; 145 | "%f" >:: t "%f" insert_f [%sql "SELECT @d{id}, @f{v} FROM foo"] [1.;-1.; 10.; 1e2]; 146 | "%s" >:: t "%s" insert_s [%sql "SELECT @d{id}, @s{v} FROM foo"] ["foo"; "bar"; "baz"]; 147 | "%S" >:: t "%S" insert_s [%sql "SELECT @d{id}, @S{v} FROM foo"] ["foo"; "bar"; "baz"]; 148 | "%b" >:: t "%b" insert_b [%sql "SELECT @d{id}, @b{v} FROM foo"] [true; false]; 149 | 150 | (* nullable *) 151 | "%d" >:: tn "%d" insert_d [%sql "SELECT @d{id}, @d?{v} FROM foo"] [1;-1;3;4]; 152 | "%l" >:: tn "%ld" insert_l [%sql "SELECT @d{id}, @l?{v} FROM foo"] [1l;-1l;3l;4l]; 153 | "%L" >:: tn "%Ld" insert_L [%sql "SELECT @d{id}, @L?{v} FROM foo"] [1L;-1L;3L;4L]; 154 | "%f" >:: tn "%f" insert_f [%sql "SELECT @d{id}, @f?{v} FROM foo"] [1.;-1.; 10.; 1e2]; 155 | "%s" >:: tn "%s" insert_s [%sql "SELECT @d{id}, @s?{v} FROM foo"] ["foo"; "bar"; "baz"]; 156 | "%S" >:: tn "%S" insert_s [%sql "SELECT @d{id}, @S?{v} FROM foo"] ["foo"; "bar"; "baz"]; 157 | "%b" >:: tn "%b" insert_b [%sql "SELECT @d{id}, @b?{v} FROM foo"] [true; false]; 158 | ] 159 | 160 | exception Cancel 161 | 162 | let test_transaction () = 163 | with_db begin fun db () -> 164 | let s_of_pair (id, data) = sprintf "(%d, %S)" id data in 165 | let get_rows db = S.select db [%sql "SELECT @d{id}, @s{data} FROM foo ORDER BY id"] in 166 | let get_one db = S.select_one db [%sql "SELECT @d{id}, @s{data} FROM foo ORDER BY id"] in 167 | let get_one' db = S.select_one db [%sqlc "SELECT @d{id}, @s{data} FROM foo ORDER BY id"] in 168 | let insert db = S.execute db [%sql "INSERT INTO foo(id, data) VALUES(%d, %s)"] in 169 | let aeq = aeq_list ~printer:s_of_pair in 170 | let aeq_one = assert_equal ~printer:s_of_pair in 171 | S.execute db [%sql "CREATE TABLE foo(id INTEGER NOT NULL, data TEXT NOT NULL)"] >>= fun () -> 172 | get_rows db >|= aeq ~msg:"Init" [] >>= fun () -> 173 | S.transaction db 174 | (fun db -> 175 | get_rows db >|= aeq [] >>= fun () -> 176 | insert db 1 "foo" >>= fun () -> 177 | get_rows db >|= aeq ~msg:"One insert in TX" [1, "foo"] >>= fun () -> 178 | get_one db >|= aeq_one ~msg:"select_one after 1 insert in TX" (1, "foo") >>= fun () -> 179 | get_one' db >|= aeq_one ~msg:"select_one (cached) after 1 insert in TX" 180 | (1, "foo") >>= fun () -> 181 | try%lwt 182 | S.transaction db 183 | (fun db -> 184 | insert db 2 "bar" >>= fun () -> 185 | get_rows db >|= aeq ~msg:"Insert in nested TX" [1, "foo"; 2, "bar";] >>= fun () -> 186 | fail Cancel) 187 | with Cancel -> 188 | get_rows db >|= aeq ~msg:"After nested TX is canceled" [1, "foo"]) >>= fun () -> 189 | get_rows db >|= aeq [1, "foo"]; 190 | end () 191 | 192 | let test_retry_begin () = 193 | 194 | let count_rows db = 195 | S.select_one db [%sqlc "SELECT @d{COUNT(*)} FROM foo"] in 196 | 197 | let insert v db = 198 | (* SELECT acquires a SHARED lock if needed *) 199 | let%lwt _ = count_rows db in 200 | Lwt.sleep 0.010 >>= fun () -> 201 | (* RESERVED lock acquired if needed *) 202 | S.insert db [%sqlc "INSERT INTO foo VALUES(%d)"] v in 203 | 204 | let fname = Filename.temp_file "t_sqlexpr_sqlite_excl_retry" "" in 205 | let db1 = S.open_db fname in 206 | let db2 = S.open_db fname in 207 | 208 | S.execute db1 [%sqlc "CREATE TABLE foo(id INTEGER PRIMARY KEY)"] >>= fun () -> 209 | (* these 2 TXs are serialized because they are EXCLUSIVE *) 210 | let%lwt _ = S.transaction ~kind:`EXCLUSIVE db1 (insert 1) 211 | and _ = S.transaction ~kind:`EXCLUSIVE db2 (insert 2) in 212 | let%lwt n = count_rows db1 in 213 | aeq_int ~msg:"number of rows inserted" 2 n; 214 | return () 215 | 216 | let test_fold_and_iter () = 217 | with_db begin fun db () -> 218 | S.execute db [%sql "CREATE TABLE foo(n INTEGER NOT NULL)"] >>= fun () -> 219 | let l = Array.to_list (Array.init 100 (fun _n -> 1 + Random.int 100000)) in 220 | iter (S.execute db [%sqlc "INSERT INTO foo(n) VALUES(%d)"]) l >>= fun () -> 221 | let sum = List.fold_left (+) 0 l in 222 | let%lwt count, sum' = 223 | S.fold db 224 | (fun (count, sum) n -> return (count + 1, sum + n)) 225 | (0, 0) [%sqlc "SELECT @d{n} FROM foo"] 226 | in 227 | aeq_int ~msg:"fold: number of elements" (List.length l) count; 228 | aeq_int ~msg:"fold: sum of elements" sum sum'; 229 | let count = ref 0 in 230 | let sum' = ref 0 in 231 | let%lwt () = 232 | S.iter db 233 | (fun n -> incr count; sum' := !sum' + n; return ()) 234 | [%sqlc "SELECT @d{n} FROM foo"] 235 | in 236 | aeq_int ~msg:"iter: number of elements" (List.length l) !count; 237 | aeq_int ~msg:"iter: sum of elements" sum !sum'; 238 | return () 239 | end () 240 | 241 | let rec do_test_nested_iter_and_fold db () = 242 | nested_iter_and_fold_write db >>= fun () -> 243 | nested_iter_and_fold_read db 244 | 245 | and nested_iter_and_fold_write db = 246 | S.execute db [%sql "CREATE TABLE foo(n INTEGER NOT NULL)"] >>= fun () -> 247 | iter (S.execute db [%sqlc "INSERT INTO foo(n) VALUES(%d)"]) [1; 2; 3] 248 | 249 | and nested_iter_and_fold_read db = 250 | let q = Queue.create () in 251 | let expected = 252 | List.rev [ 1, 3; 1, 2; 1, 1; 2, 3; 2, 2; 2, 1; 3, 3; 3, 2; 3, 1; ] in 253 | let inner = [%sqlc "SELECT @d{n} FROM foo ORDER BY n DESC"] in 254 | let outer = [%sqlc "SELECT @d{n} FROM foo ORDER BY n ASC"] in 255 | let printer (a, b) = sprintf "(%d, %d)" a b in 256 | let%lwt () = 257 | S.iter db 258 | (fun a -> S.iter db (fun b -> Queue.push (a, b) q; return ()) inner) 259 | outer 260 | in 261 | aeq_list ~printer expected (Queue.fold (fun l x -> x :: l) [] q); 262 | let%lwt l = 263 | S.fold db 264 | (fun l a -> S.fold db (fun l b -> return ((a, b) :: l)) l inner) 265 | [] 266 | outer 267 | in aeq_list ~printer expected l; 268 | return () 269 | 270 | let test_nested_iter_and_fold () = 271 | (* nested iter/folds will spawn multiple Sqlexpr_sqlite_lwt workers, so 272 | * cannot use in-mem DB, lest the table not be created in other workers 273 | * than the one where it was created *) 274 | with_db ~in_mem:false do_test_nested_iter_and_fold () 275 | 276 | let expect_missing_table tbl f = 277 | try%lwt 278 | f () >>= fun () -> 279 | assert_failure (sprintf "Expected Sqlite3.Error: missing table %s" tbl) 280 | with Sqlexpr_sqlite.Error _ -> return () 281 | 282 | let test_borrow_worker () = 283 | with_db begin fun db () -> 284 | (* we borrow a worker repeatedly, but since we're doing everything 285 | * sequentially we end up using the same one all the time *) 286 | S.borrow_worker db 287 | (fun db' -> 288 | S.borrow_worker db (fun db'' -> do_test_nested_iter_and_fold db'' ()) >>= fun () -> 289 | nested_iter_and_fold_read db') >>= fun () -> 290 | nested_iter_and_fold_read db 291 | end () 292 | 293 | let maybe_test flag f () = 294 | if flag then f () else return () 295 | 296 | (* let test_borrow_worker has_real_borrow_worker () = *) 297 | (* if has_real_borrow_worker then test_borrow_worker () else return () *) 298 | 299 | let all_tests has_real_borrow_worker = 300 | [ 301 | "Directives" >::: test_directives; 302 | "Outputs" >::: test_outputs; 303 | "Directives in output exprs" >:: test_oexpr_directives; 304 | "Transactions" >:: test_transaction; 305 | "Auto-retry BEGIN" >:: test_retry_begin; 306 | "Fold and iter" >:: test_fold_and_iter; 307 | "Nested fold and iter" >:: test_nested_iter_and_fold; 308 | "Borrow worker" >:: maybe_test has_real_borrow_worker test_borrow_worker; 309 | ] 310 | end 311 | 312 | open Lwt.Infix 313 | 314 | let test_lwt_recursive_mutex () = 315 | let module M = Sqlexpr_concurrency.Lwt in 316 | let mv = Lwt_mvar.create () in 317 | let m = M.create_recursive_mutex () in 318 | let l = ref [] in 319 | let push x = l := x :: !l; Lwt.return () in 320 | let%lwt n = M.with_lock m (fun () -> M.with_lock m (fun () -> Lwt.return 42)) in 321 | aeq_int 42 n; 322 | let t1 = M.with_lock m (fun () -> push 1 >>= fun () -> Lwt_mvar.take mv >>= fun () -> push 2) in 323 | let t2 = M.with_lock m (fun () -> push 3) in 324 | let%lwt () = Lwt.join [ t1; t2; Lwt_mvar.put mv () ] in 325 | aeq_list ~printer:string_of_int [3; 2; 1] !l; 326 | Lwt.return () 327 | 328 | module type S_LWT = Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t 329 | 330 | (* schema changes to :memory: db made by a Sqlexpr_sqlite_lwt worker are not 331 | * seen by the others, so allow to use a file by doing ~in_mem:false *) 332 | let with_db 333 | (type a) 334 | (module S : S_LWT with type db = a) 335 | ?(in_mem = true) f x = 336 | let file = 337 | if in_mem then ":memory:" else Filename.temp_file "t_sqlexpr_sqlite_" "" in 338 | let db = S.open_db file in 339 | let%lwt () = try%lwt 340 | f db x 341 | with _ -> Lwt.return () in 342 | S.close_db db; 343 | if not in_mem then Sys.remove file; 344 | Lwt.return () 345 | 346 | let test_exclusion (type a) 347 | ((module S : S_LWT with type db = a) as s) () = 348 | let module Sqlexpr = S in 349 | with_db s ~in_mem:false begin fun db () -> 350 | S.execute db [%sql "CREATE TABLE foo(n INTEGER NOT NULL)"] >>= fun () -> 351 | 352 | let exclusion_between_tx_and_single_stmt () = 353 | let t1, u1 = Lwt.wait () in 354 | let t2, u2 = Lwt.wait () in 355 | let t3, u3 = Lwt.wait () in 356 | let th1 = S.transaction db 357 | (fun db -> 358 | t1 >|= Lwt.wakeup u2 >>= fun () -> 359 | Lwt_unix.sleep 0.010 >>= fun () -> 360 | S.select_one db [%sql "SELECT @d{COUNT(*)} FROM foo"] >|= 361 | aeq_int ~msg:"number of rows (single stmt exclusion)" 0) 362 | and th2 = begin 363 | t3 >>= fun () -> 364 | S.execute db [%sql "INSERT INTO foo VALUES(1)"] 365 | end 366 | and th3 = begin 367 | Lwt.wakeup u1 (); 368 | let%lwt () = t2 in 369 | Lwt.wakeup u3 (); 370 | Lwt.return () 371 | end 372 | in 373 | th1 <&> th2 <&> th3 in 374 | 375 | let exclusion_between_txs () = 376 | let inside = ref 0 in 377 | let check _db = 378 | let%lwt () = try%lwt 379 | incr inside; 380 | if !inside > 1 then 381 | assert_failure "More than one TX in critical region at a time"; 382 | 383 | Lwt_unix.sleep 0.005 384 | with _ -> Lwt.return () in 385 | decr inside; 386 | Lwt.return () 387 | in 388 | Lwt.join (Sqlexpr_utils.List.init 1 (fun _ -> S.transaction db check)) 389 | in 390 | exclusion_between_txs () >>= fun () -> 391 | exclusion_between_tx_and_single_stmt () 392 | end () 393 | 394 | module IdConc = 395 | struct 396 | include Sqlexpr_concurrency.Id 397 | let iter = List.iter 398 | let run x = x 399 | end 400 | 401 | module LwtConc = 402 | struct 403 | include Sqlexpr_concurrency.Lwt 404 | let run x = Lwt_main.run (Lwt.pick [x; Lwt_unix.timeout 1.0]) 405 | let iter = Lwt_list.iter_s 406 | end 407 | 408 | let lwt_run f () = LwtConc.run (f ()) 409 | 410 | let all_tests = 411 | [ 412 | "Sqlexpr_concurrency.Lwt.with_lock" >:: lwt_run test_lwt_recursive_mutex; 413 | (let module M = Test(IdConc)(Sqlexpr_sqlite.Make(IdConc)) in 414 | "Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id)" >::: M.all_tests false); 415 | (let module M = Test(LwtConc)(Sqlexpr_sqlite.Make(LwtConc)) in 416 | "Sqlexpr_sqlite.Make(LwtConcurrency)" >::: M.all_tests false); 417 | (let module M = Test(LwtConc)(Sqlexpr_sqlite_lwt) in 418 | "Sqlexpr_sqlite_lwt" >::: M.all_tests true); 419 | "Sqlexpr_sqlite.Make(LwtConcurrency) exclusion" >:: 420 | lwt_run (test_exclusion (module Sqlexpr_sqlite.Make(LwtConc))); 421 | ] 422 | 423 | let _ = 424 | run_test_tt_main ("All" >::: all_tests) 425 | -------------------------------------------------------------------------------- /tests/syntax/OMakefile: -------------------------------------------------------------------------------- 1 | EXTENSIONS = $(ROOT)/src/syntax/pa_sql.cmo 2 | 3 | .SCANNER: scan-ocaml-%.ml: %.ml $(EXTENSIONS) 4 | .SCANNER: scan-ocaml-%.mli: %.mli $(EXTENSIONS) 5 | 6 | OCAMLINCLUDES += $(ROOT)/src 7 | OCAML_LIBS[] += $(ROOT)/src/sqlexpr 8 | 9 | section 10 | OCAMLPACKS[] = csv estring lwt.syntax lwt.unix oUnit sqlite3 threads 11 | OCAMLFINDFLAGS = -syntax camlp4o -ppopt $(ROOT)/src/syntax/pa_sql.cmo 12 | OCamlProgram(t_parse, t_parse) 13 | OCamlProgram(t_sqlexpr, t_sqlexpr) 14 | OCamlProgram(bm_sqlexpr_sqlite_lwt, bm_sqlexpr_sqlite_lwt) 15 | $(addsuffixes .o .cmx .cmi .cmo, bm_sqlexpr_sqlite_lwt t_sqlexpr t_parse): 16 | 17 | .PHONY: test 18 | test: t_sqlexpr$(EXE) t_parse$(EXE) 19 | ./t_sqlexpr 20 | ./t_parse 21 | 22 | # vim: set ts=8 expandtab sw=4: 23 | -------------------------------------------------------------------------------- /tests/syntax/example.ml: -------------------------------------------------------------------------------- 1 | 2 | module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) 3 | module S = Sqlexpr 4 | 5 | let init_db db = 6 | S.execute db 7 | sqlinit"CREATE TABLE IF NOT EXISTS users( 8 | id INTEGER PRIMARY KEY, 9 | login TEXT UNIQUE, 10 | password TEXT NON NULL, 11 | name TEXT, 12 | email TEXT 13 | );" 14 | 15 | let fold_users db f acc = 16 | S.fold db f acc sqlc"SELECT @s{login}, @s{password}, @s?{email} FROM users" 17 | 18 | let insert_user db ~login ~password ?name ?email () = 19 | S.insert db 20 | sqlc"INSERT INTO users(login, password, name, email) 21 | VALUES(%s, %s, %s?, %s?)" 22 | login password name email 23 | 24 | let auto_init_db, check_db, auto_check_db = sql_check"sqlite" 25 | 26 | 27 | -------------------------------------------------------------------------------- /tests/syntax/t_parse.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | open Lwt 4 | 5 | module SYNC = 6 | struct 7 | module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id) 8 | module S = Sqlexpr 9 | end 10 | 11 | let init db = 12 | let open SYNC in 13 | S.execute (S.make db) sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v TEXT)" 14 | 15 | module BM(Sqlexpr : Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t) = 16 | struct 17 | module S = Sqlexpr 18 | 19 | let run label = 20 | let db = S.open_db ~init ":memory:" in 21 | let n = ref 0 in 22 | let rows = 10_000 in 23 | let iters = 500 in 24 | for_lwt i = 1 to rows do 25 | S.execute db sqlc"INSERT INTO foo(v) VALUES(%s)" (string_of_int i) 26 | done >>= fun () -> 27 | let () = Gc.major () in 28 | let t0 = Unix.gettimeofday () in 29 | for_lwt i = 1 to iters do 30 | S.iter db (fun s -> n := !n + String.length s; return_unit) 31 | sqlc"SELECT @s{v} FROM foo" 32 | done >>= fun () -> 33 | let dt = Unix.gettimeofday () -. t0 in 34 | Lwt_io.printf "%s needed %5.2f (%.0f/s)\n" label dt 35 | (float (rows * iters) /. dt) 36 | end 37 | 38 | module DETACHED = BM(Sqlexpr_sqlite_lwt) 39 | module NORMAL = BM(Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Lwt)) 40 | 41 | let () = Lwt_main.run (NORMAL.run "normal" >>= fun () -> DETACHED.run "detached") 42 | -------------------------------------------------------------------------------- /tests/syntax/t_sqlexpr.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | open OUnit 4 | open Lwt 5 | 6 | let aeq_int = assert_equal ~printer:(sprintf "%d") 7 | let aeq_str = assert_equal ~printer:(sprintf "%S") 8 | let aeq_float = assert_equal ~printer:(sprintf "%f") 9 | let aeq_int32 = assert_equal ~printer:(sprintf "%ld") 10 | let aeq_int64 = assert_equal ~printer:(sprintf "%Ld") 11 | let aeq_bool = assert_equal ~printer:string_of_bool 12 | 13 | let aeq_list ~printer = 14 | assert_equal 15 | ~printer:(fun l -> "[ " ^ String.concat "; " (List.map printer l) ^ " ]") 16 | 17 | module Test 18 | (Lwt : sig 19 | include Sqlexpr_concurrency.THREAD 20 | val iter : ('a -> unit t) -> 'a list -> unit t 21 | val run : 'a t -> 'a 22 | end) 23 | (Sqlexpr : sig 24 | include Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t 25 | end) = 26 | struct 27 | open Lwt 28 | module S = Sqlexpr 29 | 30 | let (>|=) f g = bind f (fun x -> return (g x)) 31 | 32 | (* schema changes to :memory: db made by a Sqlexpr_sqlite_lwt worker are not 33 | * seen by the others, so allow to use a file by doing ~in_mem:false *) 34 | let with_db ?(in_mem = true) f x = 35 | let file = 36 | if in_mem then ":memory:" else Filename.temp_file "t_sqlexpr_sqlite_" "" in 37 | let db = S.open_db file in 38 | try_lwt 39 | f db x 40 | finally 41 | S.close_db db; 42 | if not in_mem then Sys.remove file; 43 | return () 44 | 45 | let test_execute () = 46 | with_db 47 | (fun db () -> 48 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY)" >>= fun () -> 49 | S.execute db sqlc"CREATE TABLE bar(id INTEGER PRIMARY KEY)") 50 | () 51 | 52 | let insert_d db l = 53 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)" >>= fun () -> 54 | iter (S.execute db sql"INSERT INTO foo(v) VALUES(%d)") l 55 | 56 | let insert_l db l = 57 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)" >>= fun () -> 58 | iter (S.execute db sql"INSERT INTO foo(v) VALUES(%l)") l 59 | 60 | let insert_L db l = 61 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v INTEGER)" >>= fun () -> 62 | iter (S.execute db sql"INSERT INTO foo(v) VALUES(%L)") l 63 | 64 | let insert_f db l = 65 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v FLOAT)" >>= fun () -> 66 | iter (S.execute db sql"INSERT INTO foo(v) VALUES(%f)") l 67 | 68 | let insert_s db l = 69 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v TEXT)" >>= fun () -> 70 | iter (S.execute db sql"INSERT INTO foo(v) VALUES(%s)") l 71 | 72 | let insert_S db l = 73 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v BLOB)" >>= fun () -> 74 | iter (S.execute db sql"INSERT INTO foo(v) VALUES(%S)") l 75 | 76 | let insert_b db l = 77 | S.execute db sql"CREATE TABLE foo(id INTEGER PRIMARY KEY, v BOOLEAN)" >>= fun () -> 78 | iter (S.execute db sql"INSERT INTO foo(v) VALUES(%b)") l 79 | 80 | let test_directive_d () = with_db insert_d [1] 81 | let test_directive_l () = with_db insert_l [1l] 82 | let test_directive_L () = with_db insert_L [1L] 83 | let test_directive_f () = with_db insert_f [3.14] 84 | let test_directive_s () = with_db insert_s ["foo"] 85 | let test_directive_S () = with_db insert_S ["blob"] 86 | let test_directive_b () = with_db insert_b [true] 87 | 88 | let test_oexpr fmt insert expr l () = 89 | with_db 90 | (fun db () -> 91 | let n = ref 1 in 92 | insert db l >>= fun () -> 93 | let l = List.map (fun x -> let i = !n in incr n; (i, x)) l in 94 | lwt l' = S.select db expr in 95 | let l' = List.sort compare l' in 96 | aeq_list ~printer:(fun (id, x) -> sprintf ("(%d, " ^^ fmt ^^ ")") id x) 97 | l l'; 98 | return ()) 99 | () 100 | 101 | let test_nullable_oexpr fmt insert expr l () = 102 | with_db 103 | (fun db () -> 104 | let n = ref 1 in 105 | insert db l >>= fun () -> 106 | let l = List.map (fun x -> let i = !n in incr n; (i, Some x)) l in 107 | lwt l' = S.select db expr in 108 | let l' = List.sort compare l' in 109 | aeq_list 110 | ~printer:(fun (id, x) -> match x with 111 | None -> sprintf "(%d, None)" id 112 | | Some x -> sprintf ("(%d, Some " ^^ fmt ^^ ")") id x) 113 | l l'; 114 | return ()) 115 | () 116 | 117 | let test_oexpr_directives = 118 | with_db 119 | (fun db () -> 120 | S.select db sql"SELECT @d{%d}" 42 >|= aeq_list ~printer:(sprintf "%d") [42] >>= fun () -> 121 | S.select db sql"SELECT @f{%d}" 42 >|= aeq_list ~printer:(sprintf "%f") [42.] >>= fun () -> 122 | S.select db sql"SELECT @s{%d}" 42 >|= aeq_list ~printer:(sprintf "%s") ["42"]) 123 | 124 | let (>::) name f = name >:: (fun () -> run (f ())) 125 | 126 | let test_directives = 127 | [ 128 | "%d" >:: test_directive_d; 129 | "%l" >:: test_directive_l; 130 | "%L" >:: test_directive_L; 131 | "%f" >:: test_directive_f; 132 | "%s" >:: test_directive_s; 133 | "%S" >:: test_directive_S; 134 | "%b" >:: test_directive_b; 135 | ] 136 | 137 | let test_outputs = 138 | let t = test_oexpr in 139 | let tn = test_nullable_oexpr in 140 | [ 141 | "%d" >:: t "%d" insert_d sql"SELECT @d{id}, @d{v} FROM foo" [1;-1;3;4]; 142 | "%l" >:: t "%ld" insert_l sql"SELECT @d{id}, @l{v} FROM foo" [1l;-1l;3l;4l]; 143 | "%L" >:: t "%Ld" insert_L sql"SELECT @d{id}, @L{v} FROM foo" [1L;-1L;3L;4L]; 144 | "%f" >:: t "%f" insert_f sql"SELECT @d{id}, @f{v} FROM foo" [1.;-1.; 10.; 1e2]; 145 | "%s" >:: t "%s" insert_s sql"SELECT @d{id}, @s{v} FROM foo" ["foo"; "bar"; "baz"]; 146 | "%S" >:: t "%S" insert_s sql"SELECT @d{id}, @S{v} FROM foo" ["foo"; "bar"; "baz"]; 147 | "%b" >:: t "%b" insert_b sql"SELECT @d{id}, @b{v} FROM foo" [true; false]; 148 | 149 | (* nullable *) 150 | "%d" >:: tn "%d" insert_d sql"SELECT @d{id}, @d?{v} FROM foo" [1;-1;3;4]; 151 | "%l" >:: tn "%ld" insert_l sql"SELECT @d{id}, @l?{v} FROM foo" [1l;-1l;3l;4l]; 152 | "%L" >:: tn "%Ld" insert_L sql"SELECT @d{id}, @L?{v} FROM foo" [1L;-1L;3L;4L]; 153 | "%f" >:: tn "%f" insert_f sql"SELECT @d{id}, @f?{v} FROM foo" [1.;-1.; 10.; 1e2]; 154 | "%s" >:: tn "%s" insert_s sql"SELECT @d{id}, @s?{v} FROM foo" ["foo"; "bar"; "baz"]; 155 | "%S" >:: tn "%S" insert_s sql"SELECT @d{id}, @S?{v} FROM foo" ["foo"; "bar"; "baz"]; 156 | "%b" >:: tn "%b" insert_b sql"SELECT @d{id}, @b?{v} FROM foo" [true; false]; 157 | ] 158 | 159 | exception Cancel 160 | 161 | let test_transaction () = 162 | with_db begin fun db () -> 163 | let s_of_pair (id, data) = sprintf "(%d, %S)" id data in 164 | let get_rows db = S.select db sql"SELECT @d{id}, @s{data} FROM foo ORDER BY id" in 165 | let get_one db = S.select_one db sql"SELECT @d{id}, @s{data} FROM foo ORDER BY id" in 166 | let get_one' db = S.select_one db sqlc"SELECT @d{id}, @s{data} FROM foo ORDER BY id" in 167 | let insert db = S.execute db sql"INSERT INTO foo(id, data) VALUES(%d, %s)" in 168 | let aeq = aeq_list ~printer:s_of_pair in 169 | let aeq_one = assert_equal ~printer:s_of_pair in 170 | S.execute db sql"CREATE TABLE foo(id INTEGER NOT NULL, data TEXT NOT NULL)" >>= fun () -> 171 | get_rows db >|= aeq ~msg:"Init" [] >>= fun () -> 172 | S.transaction db 173 | (fun db -> 174 | get_rows db >|= aeq [] >>= fun () -> 175 | insert db 1 "foo" >>= fun () -> 176 | get_rows db >|= aeq ~msg:"One insert in TX" [1, "foo"] >>= fun () -> 177 | get_one db >|= aeq_one ~msg:"select_one after 1 insert in TX" (1, "foo") >>= fun () -> 178 | get_one' db >|= aeq_one ~msg:"select_one (cached) after 1 insert in TX" 179 | (1, "foo") >>= fun () -> 180 | try_lwt 181 | S.transaction db 182 | (fun db -> 183 | insert db 2 "bar" >>= fun () -> 184 | get_rows db >|= aeq ~msg:"Insert in nested TX" [1, "foo"; 2, "bar";] >>= fun () -> 185 | fail Cancel) 186 | with Cancel -> 187 | get_rows db >|= aeq ~msg:"After nested TX is canceled" [1, "foo"]) >>= fun () -> 188 | get_rows db >|= aeq [1, "foo"]; 189 | end () 190 | 191 | let test_retry_begin () = 192 | 193 | let count_rows db = 194 | S.select_one db sqlc"SELECT @d{COUNT(*)} FROM foo" in 195 | 196 | let insert v db = 197 | (* SELECT acquires a SHARED lock if needed *) 198 | lwt _ = count_rows db in 199 | Lwt.sleep 0.010 >>= fun () -> 200 | (* RESERVED lock acquired if needed *) 201 | S.insert db sqlc"INSERT INTO foo VALUES(%d)" v in 202 | 203 | let fname = Filename.temp_file "t_sqlexpr_sqlite_excl_retry" "" in 204 | let db1 = S.open_db fname in 205 | let db2 = S.open_db fname in 206 | 207 | S.execute db1 sqlc"CREATE TABLE foo(id INTEGER PRIMARY KEY)" >>= fun () -> 208 | (* these 2 TXs are serialized because they are EXCLUSIVE *) 209 | lwt _ = S.transaction ~kind:`EXCLUSIVE db1 (insert 1) 210 | and _ = S.transaction ~kind:`EXCLUSIVE db2 (insert 2) in 211 | lwt n = count_rows db1 in 212 | aeq_int ~msg:"number of rows inserted" 2 n; 213 | return () 214 | 215 | let test_fold_and_iter () = 216 | with_db begin fun db () -> 217 | S.execute db sql"CREATE TABLE foo(n INTEGER NOT NULL)" >>= fun () -> 218 | let l = Array.to_list (Array.init 100 (fun n -> 1 + Random.int 100000)) in 219 | iter (S.execute db sqlc"INSERT INTO foo(n) VALUES(%d)") l >>= fun () -> 220 | let sum = List.fold_left (+) 0 l in 221 | lwt count, sum' = 222 | S.fold db 223 | (fun (count, sum) n -> return (count + 1, sum + n)) 224 | (0, 0) sqlc"SELECT @d{n} FROM foo" 225 | in 226 | aeq_int ~msg:"fold: number of elements" (List.length l) count; 227 | aeq_int ~msg:"fold: sum of elements" sum sum'; 228 | let count = ref 0 in 229 | let sum' = ref 0 in 230 | lwt () = 231 | S.iter db 232 | (fun n -> incr count; sum' := !sum' + n; return ()) 233 | sqlc"SELECT @d{n} FROM foo" 234 | in 235 | aeq_int ~msg:"iter: number of elements" (List.length l) !count; 236 | aeq_int ~msg:"iter: sum of elements" sum !sum'; 237 | return () 238 | end () 239 | 240 | let rec do_test_nested_iter_and_fold db () = 241 | nested_iter_and_fold_write db >>= fun () -> 242 | nested_iter_and_fold_read db 243 | 244 | and nested_iter_and_fold_write db = 245 | S.execute db sql"CREATE TABLE foo(n INTEGER NOT NULL)" >>= fun () -> 246 | iter (S.execute db sqlc"INSERT INTO foo(n) VALUES(%d)") [1; 2; 3] 247 | 248 | and nested_iter_and_fold_read db = 249 | let q = Queue.create () in 250 | let expected = 251 | List.rev [ 1, 3; 1, 2; 1, 1; 2, 3; 2, 2; 2, 1; 3, 3; 3, 2; 3, 1; ] in 252 | let inner = sqlc"SELECT @d{n} FROM foo ORDER BY n DESC" in 253 | let outer = sqlc"SELECT @d{n} FROM foo ORDER BY n ASC" in 254 | let printer (a, b) = sprintf "(%d, %d)" a b in 255 | lwt () = 256 | S.iter db 257 | (fun a -> S.iter db (fun b -> Queue.push (a, b) q; return ()) inner) 258 | outer 259 | in 260 | aeq_list ~printer expected (Queue.fold (fun l x -> x :: l) [] q); 261 | lwt l = 262 | S.fold db 263 | (fun l a -> S.fold db (fun l b -> return ((a, b) :: l)) l inner) 264 | [] 265 | outer 266 | in aeq_list ~printer expected l; 267 | return () 268 | 269 | let test_nested_iter_and_fold () = 270 | (* nested iter/folds will spawn multiple Sqlexpr_sqlite_lwt workers, so 271 | * cannot use in-mem DB, lest the table not be created in other workers 272 | * than the one where it was created *) 273 | with_db ~in_mem:false do_test_nested_iter_and_fold () 274 | 275 | let expect_missing_table tbl f = 276 | try_lwt 277 | f () >>= fun () -> 278 | assert_failure (sprintf "Expected Sqlite3.Error: missing table %s" tbl) 279 | with Sqlexpr_sqlite.Error _ -> return () 280 | 281 | let test_borrow_worker () = 282 | with_db begin fun db () -> 283 | (* we borrow a worker repeatedly, but since we're doing everything 284 | * sequentially we end up using the same one all the time *) 285 | S.borrow_worker db 286 | (fun db' -> 287 | S.borrow_worker db (fun db'' -> do_test_nested_iter_and_fold db'' ()) >>= fun () -> 288 | nested_iter_and_fold_read db') >>= fun () -> 289 | nested_iter_and_fold_read db 290 | end () 291 | 292 | let maybe_test flag f () = 293 | if flag then f () else return () 294 | 295 | (* let test_borrow_worker has_real_borrow_worker () = *) 296 | (* if has_real_borrow_worker then test_borrow_worker () else return () *) 297 | 298 | let all_tests has_real_borrow_worker = 299 | [ 300 | "Directives" >::: test_directives; 301 | "Outputs" >::: test_outputs; 302 | "Directives in output exprs" >:: test_oexpr_directives; 303 | "Transactions" >:: test_transaction; 304 | "Auto-retry BEGIN" >:: test_retry_begin; 305 | "Fold and iter" >:: test_fold_and_iter; 306 | "Nested fold and iter" >:: test_nested_iter_and_fold; 307 | "Borrow worker" >:: maybe_test has_real_borrow_worker test_borrow_worker; 308 | ] 309 | end 310 | 311 | let test_lwt_recursive_mutex () = 312 | let module M = Sqlexpr_concurrency.Lwt in 313 | let mv = Lwt_mvar.create () in 314 | let m = M.create_recursive_mutex () in 315 | let l = ref [] in 316 | let push x = l := x :: !l; return () in 317 | lwt n = M.with_lock m (fun () -> M.with_lock m (fun () -> return 42)) in 318 | aeq_int 42 n; 319 | let t1 = M.with_lock m (fun () -> push 1 >>= fun () -> Lwt_mvar.take mv >>= fun () -> push 2) in 320 | let t2 = M.with_lock m (fun () -> push 3) in 321 | lwt () = Lwt.join [ t1; t2; Lwt_mvar.put mv () ] in 322 | aeq_list ~printer:string_of_int [3; 2; 1] !l; 323 | return () 324 | 325 | module type S_LWT = Sqlexpr_sqlite.S with type 'a result = 'a Lwt.t 326 | 327 | (* schema changes to :memory: db made by a Sqlexpr_sqlite_lwt worker are not 328 | * seen by the others, so allow to use a file by doing ~in_mem:false *) 329 | let with_db 330 | (type a) 331 | (module S : S_LWT with type db = a) 332 | ?(in_mem = true) f x = 333 | let file = 334 | if in_mem then ":memory:" else Filename.temp_file "t_sqlexpr_sqlite_" "" in 335 | let db = S.open_db file in 336 | try_lwt 337 | f db x 338 | finally 339 | S.close_db db; 340 | if not in_mem then Sys.remove file; 341 | return () 342 | 343 | let test_exclusion (type a) 344 | ((module S : S_LWT with type db = a) as s) () = 345 | let module Sqlexpr = S in 346 | with_db s ~in_mem:false begin fun db () -> 347 | S.execute db sql"CREATE TABLE foo(n INTEGER NOT NULL)" >>= fun () -> 348 | 349 | let exclusion_between_tx_and_single_stmt () = 350 | let t1, u1 = Lwt.wait () in 351 | let t2, u2 = Lwt.wait () in 352 | let t3, u3 = Lwt.wait () in 353 | let th1 = S.transaction db 354 | (fun db -> 355 | t1 >|= Lwt.wakeup u2 >>= fun () -> 356 | Lwt_unix.sleep 0.010 >>= fun () -> 357 | S.select_one db sql"SELECT @d{COUNT(*)} FROM foo" >|= 358 | aeq_int ~msg:"number of rows (single stmt exclusion)" 0) 359 | and th2 = begin 360 | t3 >>= fun () -> 361 | S.execute db sql"INSERT INTO foo VALUES(1)" 362 | end 363 | and th3 = begin 364 | Lwt.wakeup u1 (); 365 | lwt () = t2 in 366 | Lwt.wakeup u3 (); 367 | return () 368 | end 369 | in 370 | th1 <&> th2 <&> th3 in 371 | 372 | let exclusion_between_txs () = 373 | let inside = ref 0 in 374 | let check db = 375 | try_lwt 376 | incr inside; 377 | if !inside > 1 then 378 | assert_failure "More than one TX in critical region at a time"; 379 | 380 | Lwt_unix.sleep 0.005 381 | finally 382 | decr inside; 383 | return () 384 | in 385 | Lwt.join (Sqlexpr_utils.List.init 1 (fun _ -> S.transaction db check)) 386 | in 387 | exclusion_between_txs () >>= fun () -> 388 | exclusion_between_tx_and_single_stmt () 389 | end () 390 | 391 | module IdConc = 392 | struct 393 | include Sqlexpr_concurrency.Id 394 | let iter = List.iter 395 | let run x = x 396 | end 397 | 398 | module LwtConc = 399 | struct 400 | include Sqlexpr_concurrency.Lwt 401 | let run x = Lwt_main.run (Lwt.pick [x; Lwt_unix.timeout 1.0]) 402 | let iter = Lwt_list.iter_s 403 | end 404 | 405 | let lwt_run f () = LwtConc.run (f ()) 406 | 407 | let all_tests = 408 | [ 409 | "Sqlexpr_concurrency.Lwt.with_lock" >:: lwt_run test_lwt_recursive_mutex; 410 | (let module M = Test(IdConc)(Sqlexpr_sqlite.Make(IdConc)) in 411 | "Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id)" >::: M.all_tests false); 412 | (let module M = Test(LwtConc)(Sqlexpr_sqlite.Make(LwtConc)) in 413 | "Sqlexpr_sqlite.Make(LwtConcurrency)" >::: M.all_tests false); 414 | (let module M = Test(LwtConc)(Sqlexpr_sqlite_lwt) in 415 | "Sqlexpr_sqlite_lwt" >::: M.all_tests true); 416 | "Sqlexpr_sqlite.Make(LwtConcurrency) exclusion" >:: 417 | lwt_run (test_exclusion (module Sqlexpr_sqlite.Make(LwtConc))); 418 | ] 419 | 420 | let _ = 421 | run_test_tt_main ("All" >::: all_tests) 422 | --------------------------------------------------------------------------------