pax_global_header00006660000000000000000000000064145035312760014520gustar00rootroot0000000000000052 comment=e33b4413489136fe131d30aab431f84439362ae5 pgocaml-4.4.0/000077500000000000000000000000001450353127600131475ustar00rootroot00000000000000pgocaml-4.4.0/.gitignore000066400000000000000000000000411450353127600151320ustar00rootroot00000000000000/_build /_opam *.install .merlin pgocaml-4.4.0/CHANGELOG.txt000066400000000000000000000074551450353127600152120ustar00rootroot00000000000000Release 4.2.1 ============= * 4.08 Ast for ppx * Add oid for UUID arrays Release 4.2 =========== * add support for type hints Release 4.1 =========== * add support for custom converters * document pretty printer for objects Release 4.0 =========== * Migrate build system to Dune * Remove Camlp4 syntax extension * Split PPX into separate OPAM package 'pgocaml_ppx' Release 3.0 =========== * a whole bunch of fixes * some new OIDs * allow custom unix socket dir as PGHOST Release 2.3 =========== * Dario Teixeira: migrate syntax extension from OCaml-pcre to OCaml-re. * Rudi Grinberg: migrate core library from OCaml-pcre to OCaml-re. * Rudi Grinberg: add unit tests for regular expressions. * Evgenii Lepikhin: add support for types UUID and JSONB. * Philippe Wang: add support for type CITEXT. Release 2.2 =========== * Jacques-Pascal Deplaix: Use Bytes instead of String when mutation is required. * Jacques-Pascal Deplaix: fix bug in AuthenticationCryptPassword. Release 2.1 =========== * Dario Teixeira: add List.iteri and List.mapi for compatibility with older versions of OCaml. Release 2.0 =========== * Dario Teixeira & Jacques-Pascal Deplaix: remove dependencies on ExtLib or Batteries. Auxilliary functions which used to be provided by Batteries are located in the newly created PGOCaml_aux module. * Dario Teixeira and Jacques-Pascal Deplaix: fixing issues with arrays. This requires all array types to change from 'a array to 'a option array, which breaks backward compatibility. * Dario Teixeira's patch making PostgreSQL's NUMERIC type be converted to/from OCaml strings. This change is not backward's compatible, requiring a bump in the major version number (though there seems to be no actual code in the wild relying on the previous behaviour). * Dario Teixeira's patch adding function 'uuid', which exposes the unique connection handle identifier. * Jacques-Pascal Deplaix's patches adding 'catch', 'transact', 'alive', 'inject', and 'alter' functions. Release 1.7.1 ============= * Fixed missing dependency in _oasis file. Release 1.7 =========== * Build system now uses OASIS. * Directory tree reorganisation. * Now using Batteries only. * Migration to Batteries 2.0. Release 1.6 =========== * Fixed Makefile: it should now work with any OCaml version. * Richard Jones patch converting all references of 'loc' into '_loc'. The former has been deprecated for a while now. Release 1.5 =========== * Dario Teixeira's patch adding support for more array types, namely bool[], int8[], text[], float4[], and float8[]. * Michael Ekstrand's patch to make PG'Ocaml work with batteries, if so requested (it still uses ExtLib by default). * Dario Teixeira's patch adding support for Hstore. * David Allsopp's patch fixing connection on Windows. * David Allsopp's patch for better reporting of nullable results. * Dario Teixeira's patch adding support for the 'hex' serialisation format introduced with PostgreSQL 9.0. * Matías Giovannini's patch adding support for cursors. * Dario Teixeira's patch adding support for the various transaction options in function 'begin_work'. Release 1.4 =========== * Boris Yakobowski's patch that replaces 'rows' and 'varname' with '_rows' and '_varname' (avoids unused variable warnings) * Support for INET type (patch by David Allsopp) * Dario Teixeira's patch for type unravelling Release 1.3 =========== * Applied (slightly modified) Vincent Bernardoff's patches for 'point' type * Large data set patch by Mykola Stryebkov Release 1.2 =========== * Jérôme Vouillon's monadic version * Updated to Calendar 2.x * Password authentication from $PGPASSWORD (by Dario Teixeira) * Syntax package now called 'syntax' instead of 'statements' Release 1.1 =========== * Added proper copyright notices to license. Release 1.0 =========== * First public release pgocaml-4.4.0/LICENSE.txt000066400000000000000000000634451450353127600150060ustar00rootroot00000000000000This library is distributed under the terms of the GNU LGPL with the OCaml linking exception. ---------------------------------------------------------------------- As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by INRIA, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ---------------------------------------------------------------------- GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place - Suite 330 Boston, MA 02111-1307, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU General Public License along with this library; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! pgocaml-4.4.0/README.md000066400000000000000000000156071450353127600144370ustar00rootroot00000000000000# PG'OCaml is a set of OCaml bindings for the PostgreSQL database. Please note that this is not the first or only PGSQL bindings for OCaml. Here are the others which you may want to consider: * [postgresql-ocaml](https://mmottl.github.io/postgresql-ocaml/) PostgreSQL-OCaml by Markus Mottl * [ocamlodbc](http://home.gna.org/ocamlodbc/) ODBC bindings by Max Guesdon which can be used to access PostgreSQL * [ocamldbi](http://download.savannah.nongnu.org/releases/modcaml/) a Perl-like DBI layer by the present author PG'OCAML is different than the above bindings: * It ISN'T just a wrapper around the C libpq library. Instead it's a pure OCaml library which talks the frontend/backend protocol directly with the database. * It has a PPX (macro) layer which lets you write SQL statements directly in your code, TYPE SAFE at compile time, with TYPE INFERENCE into the SQL, and using the full PostgreSQL SQL grammar (sub-selects, PG-specific SQL, etc.). But the flip side of this is that you need to have access to the database at _compile_ time, so the type checking magic can be done; also if you change the database schema, you will need to recompile your code to check it is still correctly typed. * (A minor point) - It requires PostgreSQL >= 7.4. The default interface (`PGOCaml`) provided is synchronous. But it also supports any asynchronous interface that implements the `PGOCaml_generic.THREAD` signature. * It doesn't work with other databases, nor will it ever work with other databases. # Usage PG'OCaml uses environment variables (or in-code parameters, which are [ill advised] (https://hackernoon.com/how-to-use-environment-variables-keep-your-secret-keys-safe-secure-8b1a7877d69c)) to connect to your database both at compile-time and at runtime. | Variable | Default | Additional information | | ------------- | ------------- | ---------------------- | | `PGHOST` | | If this starts with a `/` or is unspecified, PG'OCaml assumes you're specifying a Unix domain socket. | | `PGPORT` | `5432` | This is also the default PostgreSQL port. | | `PGUSER` | The username of the current user, or `postgres` if that can't be found. | | | `PGDATABASE` | falls back on `PGUSER` | | | `PGPASSWORD` | empty string | | | `PGPROFILING` | no profiling | Indicates the file to write profiling information to. If it doesn't exist, don't profile | | `COMMENT_SRC_LOC` | `no` | If set to `yes`, `1`, or `on`, PG'OCaml will append a comment to each query indicating where it appears in the OCaml source code. This can be useful for logging. | | `PGCUSTOM_CONVERTERS_CONFIG` | nothing | Points to a file containing custom type conversions | # Using the PPX The PPX aims to be more or less a carbon copy of the former extension. ```ocaml let () = let dbh = PGOCaml.connect () in let insert name salary = [%pgsql dbh "insert into employees (name, salary) VALUES ($name, $salary)"] in ignore(insert "Chris" 1_000.0); let get name = [%pgsql dbh "select salary from employees where name = $name"] in let () = [%pgsql dbh "execute" "CREATE TEMP TABLE IF NOT EXISTS employees ( name TEXT PRIMARY KEY, salary FLOAT)"] in let name = "Chris" in let salary = get name |> List.hd |> function | Some(x) -> x | None -> raise(Failure "The database is probably broken.") in Printf.printf "%s's salary is %.02f\n" name salary; PGOCaml.close(dbh) ``` The PPX allows you to specify that queries returning results should be returned as objects, rather than tuples. ```ocaml let%lwt res = [%pgsql.object dbh "SELECT * FROM employees"] in List.iter (fun row -> Printf.printf "%s makes $%f\n" row#name row#salary) res ``` The PPX now also supports `${...}` expansions. ```ocaml (* where [e] is a row returned by a [pgsql.object] query *) let%lwt incr_sal e = [%pgsql dbh "UPDATE employees SET salary = ${e#salary +. 1.0}"] ``` You may wish to print all the fields of an object for debugging purposes. ```ocaml let%lwt rows = [%pgsql.object dbh "show" "SELECT * FROM employees"] in List.iter (fun row -> print_endline row#show) rows ``` The above code will not work if one of the selected fields is named `show`. The PPX allows one to explicitly name the pretty-printer method as follows: ```ocaml let%lwt rows = [%pgsql.object dbh "show=pp" "SELECT * FROM employees"] in List.iter (fun row -> print_endline row#pp) rows ``` It's important to note that the `show` directive causes values to be printed in the same format used by the Postgres API, so things like `Calendar.t` values and custom converters (see below) may not work as expected. ## Custom Type Conversions Custom serializers and deserializers may be provided in a configuration file specified by `PGCUSTOM_CONVERTERS_CONFIG` (see above). An example configuration file follows: ```lisp ( ( ( Or ( (Rule (typnam userid)) ; userid is a fully abstract type (Rule (colnam userid)) ) ) ( (serialize Userid.to_string) (deserialize Userid.from_string) ) ) ( ( Or ( (Rule (typnam cash_money)) ; for strings beginning with a $ and possibly needing to be trimmed (And ; there exists a column elsewhere also named salary, but it has a different type ( (Rule (typnam float)) (Rule (colnam salary)) ) ) ) ) ( (serialize "fun x -> String.(sub x 1 (length x - 1)) |> String.trim") (deserialize "fun x -> \"$\" ^ x") ) ) ) ``` In case you're working on a large project, and don't want to write many convoluted rules to play nicely with your existing database structure, you can selectively enable custom serialization for individual queries: ```ocaml let rows = [%pgsql.object dbh "load_custom_from=tests_ppx/config.sexp" "show" "SELECT * FROM customtable"] in ... ``` PG'OCaml's PPX is not given type information by the compiler, so it will sometimes have trouble figuring the correct types for arguments. While one may find a parameter's serializer based in its name, this is not ideal, particularly when using `${...}` parameters. In cases like this, you may use a syntax similar to OCaml's native type constraint: ```ocaml let () = [%pgsql dbh "INSERT INTO users VALUES ${u : userid}"] in ... ``` Please note that the `${u : userid}` above will NOT be compiled into an OCaml type constraint. Its only effect is to supply `userid` as the `typnam` to the serializer resolver. ---------------------------------------------------------------------- PG'OCaml (C) Copyright 2005-2009 Merjis Ltd, Richard W.M. Jones (rich@annexia.org) and other authors (see CONTRIBUTORS.txt for details). This software is distributed under the GNU LGPL with OCaml linking exception. Please see the file COPYING.LIB for full license. ---------------------------------------------------------------------- For an example, please see [tests](https://github.com/darioteixeira/pgocaml/blob/master/tests/test_pgocaml_highlevel.ml) pgocaml-4.4.0/doc/000077500000000000000000000000001450353127600137145ustar00rootroot00000000000000pgocaml-4.4.0/doc/BUGS.txt000066400000000000000000000101751450353127600152210ustar00rootroot00000000000000------------------------------------------------------------------------- | Current bugs and other problems. | ------------------------------------------------------------------------- 1. LEFT OUTER JOIN and nullability of named columns [FIXED] ----------------------------------------------------------- Consider tables like: create table users ( id serial not null primary key, u.name text not null, ... ); create table adverts ( author int references users (id), -- could be null ... ); and a query like: select a.author, u.name from adverts a LEFT OUTER JOIN users u on a.author = u.id The LEFT OUTER JOIN ensures that rows are returned even if the adverts.author field is null. For example, this query can return u.name as NULL. Unfortunately our nullability heuristic doesn't work well here. The u.name column is marked as NOT NULL and so we don't expect it to come out of the database as a NULL. The current workaround is to use PGSQL(dbh) "nullable-results" "query" instead of PGSQL(dbh) "query". This disables the nullability heuristic for all columns, and so all return columns will have type "'a option". 2. CREATE TEMPORARY TABLE [FIXED] --------------------------------- Normally at compile time, statements are only prepared in the database. You wouldn't ordinarily want to run statements at compile time, since that would be dangerous. However there is one case where it is desirable to run the statement, and that is if the statement creates a temporary table. By actually creating the temporary table, we allow further statements which use the table to be checked, and since temporary tables are temporary, no harm is done by creating them, even at compile time. For this case, use PGSQL(dbh) "execute" "query" instead of PGSQL(dbh) "query". For example: PGSQL(dbh,"execute") "create temporary table employees ( id serial not null primary key, name text not null, salary int4 not null, email text )"; let insert name salary email = PGSQL(dbh) "insert into employees (name, salary, email) values ($name, $salary, $?email)" in insert "Ann" 10_000_l None; insert "Bob" 45_000_l None; insert "Jim" 20_000_l None; insert "Mary" 30_000_l (Some "mary@example.com"); Note that the CREATE TEMPORARY TABLE statement needs to come before any statements which use the table. There doesn't seem to be a good way around this. 3. Specifying lists as parameters [FIXED] ----------------------------------------- Suppose I want to select a subset of employees from my database. We'd like to be able to write: let employee_ids = [ 3; 4; 5 ] in PGSQL(dbh) "select name from employees where id in $@employee_ids" which, at runtime, would expand to: select name from employees where id in (3, 4, 5) The implementation of this is complex. At compile time we prototype the following statement: select name from employees where id in ($1) and get the type of $1 as the type of each element in the list. At runtime we then have to be careful to cache each list arity separately - quite complex if there are several lists in the statement. This doesn't work at all if the list could be empty, because "... in ()" is a syntax error in SQL. This is a problem with the SQL standard. You need to treat that as a special case. 4. Generating SQL from fragments -------------------------------- It is fairly common to construct SQL statements from string fragments, as in this pseudocode example: let order_clause = match key, reverse with | `Author, false -> "author asc" | `Author, true -> "author desc" | `Title, false -> "title asc" | `Title, true -> "title desc" let sql = "select title, author from books " ^ order_clause Such statement-building is not currently permitted by PG'OCaml, unless you ditch the PPX and use the low-level, unsafe interface. It would be nice to have some sort of "fragment constructor" operator to allow the above to be expressed in a type-safe way. However because it is not possible to compile the fragments, it doesn't look like such a constructor could be written. If anyone has any ideas about this, please contact the author. pgocaml-4.4.0/doc/CONTRIBUTORS.txt000066400000000000000000000015151450353127600164140ustar00rootroot00000000000000------------------------------------------------------------------------- | Contributors. | ------------------------------------------------------------------------- * Gabriel de Perthuis: Contributed patches to make OMakefile builds work using a '-syntax' flag. * Dario Teixeira: Tutorial, web site, miscellaneous patches, release maintenance. * Jérôme Vouillon: Code refactoring to work in a monadic fashion (for Lwt, for example). * Mykola Stryebkov: Support for large data sets. * Vincent Bernardoff: Support for "point" type. * Boris Yakobowski: Patch that replaces 'rows' and 'varname' with '_rows' and '_varname' (avoids unused variable warnings) * David Allsopp: Support for INET type, miscellaneous fixes * Michael Ekstrand: OCaml Batteries support. * Matías Giovannini: Cursor support. pgocaml-4.4.0/doc/HOW_IT_WORKS.txt000066400000000000000000000063441450353127600165020ustar00rootroot00000000000000------------------------------------------------------------------------- | How PG'OCaml works. | ------------------------------------------------------------------------- Enough people have asked me how PG'OCaml works that I am compiling this document to explain what is going on. 1. Background ------------- 1.1 PREPARE A common operation on databases is 'PREPARE statement'. What this does is to take a fixed statement and optimise it. The idea is that if you execute the same statement lots of times, instead of having the database optimise it each time (a process which can be time-consuming), you PREPARE [optimise] it once and then EXECUTE the already optimised statement. For example: PREPARE SELECT [some very complicated set of joins which take a long time to optimise] EXECUTE EXECUTE EXECUTE Most databases extend this notion with placeholders in the original statement, so: PREPARE SELECT name FROM users where id = $1 EXECUTE ($1 = 10) EXECUTE ($1 = 20) EXECUTE ($1 = 23) 1.2 DESCRIBE Recent versions of PostgreSQL added a 'DESCRIBE statement' command to the database backend. It isn't normally exposed through clients like psql or libPQ (well - that may have changed by the time you read this), but it's there if you code directly to the database frontend/backend wire protocol. 'DESCRIBE' is just an extension of 'PREPARE'. Because the optimiser has decoded the statement into some internal format, it knows already the types of the placeholders and the types of the return columns, and it can supply this information back to the caller. For example: PREPARE SELECT id, name FROM users WHERE salary > $1 DESCRIBE ==> placeholder $1 has type DECIMAL ==> 2 columns returned with types SERIAL, VARCHAR(80) 2. In OCaml ----------- On the OCaml side we like to know the type of everything, and using DESCRIBE we can extend type inference right the way through to the database. Consider some code like: let salary = 15000.00 in let rows = PGSQL(dbh) "SELECT id, name FROM users WHERE salary > $salary" in List.iter ( fun (id, name) -> printf "id = %d, name = %s\n" id name ) rows How do we know that salary (type: float) when passed to the database has the same type that the database expects? How do we know that the id and name fields have the same type as what the database returns? During compilation we can use DESCRIBE to convert this code into: let salary = 15000.00 in let rows = (*vv-- generated by macro --vv*) do_PREPARE "SELECT id, name FROM users WHERE salary > $1"; let placeholder1 = string_of_decimal salary (* placeholder $1 *) in let rows = do_EXECUTE placeholder1 in List.map ( fun (col1, col2) -> (* returned columns id, name *) (serial_of_string col1, string_of_string col2) ) rows (*^^-- generated by macro --^^*) List.iter ( fun (id, name) -> printf "id = %d, name = %s\n" id name ) rows Notes: (1) The real code generated by the macro is a lot more complicated. (2) The database actually takes and returns strings. (3) In the real macro, prepared statements are cached so they don't need to be reoptimised each time. 3. Further reading ------------------ Now go and read: BUGS.txt, pGOCaml.mli, pa_pgsql.ml4 pgocaml-4.4.0/doc/PROFILING.txt000066400000000000000000000015571450353127600160160ustar00rootroot00000000000000------------------------------------------------------------------------- | Profiling. | ------------------------------------------------------------------------- If PG'OCaml programs are started with the environment variable $PGPROFILING pointing to the name of a writable file, then profiling information about events is written to this file. This information can be analysed later by using the pgocaml_prof tool. For example: PGPROFILING=$HOME/.test_prof export PGPROFILING ./test pgocaml_prof $HOME/.test_prof | less Information currently tracked includes the running time for SQL statements and connection time. You can usually use this information to find out which statements are taking too long, and optimise them accordingly. The profile file will contain some potentially sensitive information such as database and user names (but not passwords). pgocaml-4.4.0/dune-project000066400000000000000000000000401450353127600154630ustar00rootroot00000000000000(lang dune 1.10) (name pgocaml) pgocaml-4.4.0/pgocaml.opam000066400000000000000000000020601450353127600154450ustar00rootroot00000000000000opam-version: "2.0" name: "pgocaml" version: "4.4.0" synopsis: "Native OCaml interface to PostgreSQL databases" description: """ PGOCaml provides an interface to PostgreSQL databases for OCaml applications. Note that it speaks the PostgreSQL wire protocol directly, and therefore does not need to create bindings to the PostgreSQL libpq C library. The PPX syntax extension is now packaged separately as 'pgocaml_ppx'. You will want to take a look at it if you're considering using PGOCaml. """ maintainer: "dario.teixeira@nleyten.com" authors: ["Richard W.M. Jones "] homepage: "https://github.com/darioteixeira/pgocaml" bug-reports: "https://github.com/darioteixeira/pgocaml/issues" dev-repo: "git+https://github.com/darioteixeira/pgocaml.git" license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" build: [["dune" "build" "-p" name "-j" jobs]] depends: [ "calendar" {>= "2.0"} "camlp-streams" "csv" "dune" {>= "1.10"} "hex" "ocaml" {>= "4.07"} "ppx_sexp_conv" "re" {>= "1.5.0"} "ppx_deriving" {>= "4.2"} "rresult" "sexplib" ] pgocaml-4.4.0/pgocaml_ppx.opam000066400000000000000000000017441450353127600163440ustar00rootroot00000000000000opam-version: "2.0" name: "pgocaml_ppx" version: "4.4.0" synopsis: "PPX extension for PGOCaml" description: """ PGOCaml provides an interface to PostgreSQL databases for OCaml applications. This PPX syntax extension enables one to directly embed SQL statements inside the OCaml code. The extension uses the 'describe' feature of PostgreSQL to obtain type information about the database. This allows PGOCaml to check at compile-time if the program is indeed consistent with the database structure. """ maintainer: "dario.teixeira@nleyten.com" authors: ["Richard W.M. Jones "] homepage: "https://github.com/darioteixeira/pgocaml" bug-reports: "https://github.com/darioteixeira/pgocaml/issues" dev-repo: "git+https://github.com/darioteixeira/pgocaml.git" license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" build: [["dune" "build" "-p" name "-j" jobs]] depends: [ "dune" {>= "1.10"} "ocaml" {>= "4.07"} "pgocaml" {= version} "ppxlib" {>= "0.16.0"} "ppx_optcomp" ] pgocaml-4.4.0/ppx/000077500000000000000000000000001450353127600137565ustar00rootroot00000000000000pgocaml-4.4.0/ppx/dune000066400000000000000000000002651450353127600146370ustar00rootroot00000000000000(library (name pgocaml_ppx) (public_name pgocaml_ppx) (kind ppx_rewriter) (preprocess (pps ppx_optcomp ppxlib.metaquot)) (libraries ppxlib pgocaml) (modules ppx_pgsql)) pgocaml-4.4.0/ppx/ppx_pgsql.ml000066400000000000000000000626761450353127600163460ustar00rootroot00000000000000(* PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2016 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) open PGOCaml_aux open Ppxlib open Ast_helper open Asttypes open Parsetree let nullable_name = "nullable" let unravel_name = "unravel" let typname_name = "typname" (* We need a database connection while compiling. If people use the * override flags like "database=foo", then we may connect to several * databases at once. Keep track of that here. Note that in the normal * case we have just one database handle, opened to the default * database (as controlled by environment variables such as $PGHOST, * $PGDATABASE, etc.) *) type key = PGOCaml.connection_desc let connections : (key, unit PGOCaml.t) Hashtbl.t = Hashtbl.create 16 [%%if ocaml_version < (4, 08, 0)] let exp_of_string ~loc:_ x = let lexer = Lexing.from_string x in Parse.expression lexer [%%else] let exp_of_string ~loc x = let lexer = let acc = Lexing.from_string ~with_positions:false x in acc.Lexing.lex_start_p <- loc.loc_start; acc.Lexing.lex_curr_p <- loc.loc_end; acc in Parse.expression lexer [%%endif] (** [get_connection key] Find the database connection specified by [key], * otherwise attempt to create a new one from [key] and return that (or an * error). *) let get_connection ~loc key = match Hashtbl.find_opt connections key with | Some connection -> let open Rresult in Ok connection | None -> (* Create a new connection. *) try let dbh = PGOCaml.connect ~desc:key () in (* Prepare the nullable test - see result conversions below. *) let nullable_query = "select attnotnull from pg_attribute where attrelid = $1 and attnum = $2" in PGOCaml.prepare dbh ~query:nullable_query ~name:nullable_name (); (* Prepare the unravel test. *) let unravel_query = "select typname, typtype, typbasetype from pg_type where oid = $1" in PGOCaml.prepare dbh ~query:unravel_query ~name:unravel_name (); (* Prepare the type name query. *) let typname_query = "select typname from pg_type where oid = $1" in PGOCaml.prepare dbh ~query:typname_query ~name:typname_name (); Hashtbl.add connections key dbh; Rresult.Ok dbh with | err -> Error ("Could not make the connection " ^ PGOCaml.connection_desc_to_string key ^ ", error: " ^ Printexc.to_string err , loc) (* Wrapper around [PGOCaml.name_of_type]. *) let name_of_type_wrapper dbh oid = try Some (PGOCaml.name_of_type oid) with PGOCaml.Error _ -> let params = [ Some (PGOCaml.string_of_oid oid) ] in let rows = PGOCaml.execute dbh ~name:typname_name ~params () in match rows with | [ [ Some "citext" ] ] -> Some "string" | [ [ Some "hstore" ] ] -> Some "hstore" | _ -> None (* By using CREATE DOMAIN, the user may define types which are essentially aliases * for existing types. If the original type is not recognised by PG'OCaml, this * functions recurses through the pg_type table to see if it happens to be an alias * for a type which we do know how to handle. *) let unravel_type dbh ?load_custom_from ?colnam ?argnam ?typnam orig_type = let get_custom typnam = match PGOCaml.find_custom_typconvs ?typnam ?lookin:load_custom_from ?colnam ?argnam () with | Ok convs -> Option.default "FIXME" typnam, convs | Error exc -> failwith exc in let rec unravel_type_aux ft = let rv = let rv = match typnam with | Some x -> Some x, None | None -> name_of_type_wrapper dbh ft, None in match PGOCaml.find_custom_typconvs ?typnam:(fst rv) ?lookin:load_custom_from ?colnam ?argnam () with | Ok (x) -> (fst rv), x | Error err -> failwith err in match rv with | None, _ -> let params = [ Some (PGOCaml.string_of_oid ft) ] in let rows = PGOCaml.execute dbh ~name:unravel_name ~params () in begin match rows with | [ typnam :: _ ] when Rresult.R.is_ok (PGOCaml.find_custom_typconvs ?typnam ?lookin:load_custom_from ?colnam ?argnam ()) -> get_custom typnam | [ [ Some _; Some typtype ; _ ] ] when typtype = "e" -> "string", None | [ [ Some _; Some typtype ; Some typbasetype ] ] when typtype = "d" -> unravel_type_aux (PGOCaml.oid_of_string typbasetype) | _ -> failwith "Impossible" end | typnam, coders -> Option.default "FIXME" typnam, coders in unravel_type_aux orig_type (* Return the list of numbers a <= i < b. *) let rec range a b = if a < b then a :: range (a+1) b else [] let rex = let open Re in [ char '$'; opt (group (char '@')); opt (group (char '?')); group ( alt [ seq [ alt [char '_'; rg 'a' 'z']; rep (alt [char '_'; char '\''; rg 'a' 'z'; rg 'A' 'Z'; rg '0' '9']) ]; seq [ char '{'; rep (diff any (char '}')); char '}' ] ] ) ] |> seq |> compile let loc_raise _loc exn = raise exn let const_string ~loc str = { pexp_desc = Pexp_constant (Pconst_string (str, loc, None)); pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = [] } let parse_flags flags loc = let f_execute = ref false in let f_nullable_results = ref false in let host = ref None in let port = ref None in let user = ref None in let password = ref None in let database = ref None in let unix_domain_socket_dir = ref None in let comment_src_loc = ref (PGOCaml.comment_src_loc ()) in let show = ref None in let load_custom_from = ref None in List.iter ( function | "execute" -> f_execute := true | "nullable-results" -> f_nullable_results := true | "show" -> show := Some "show" | str when String.starts_with str "host=" -> let host' = String.sub str 5 (String.length str - 5) in host := Some host' | str when String.starts_with str "port=" -> let port' = int_of_string (String.sub str 5 (String.length str - 5)) in port := Some port' | str when String.starts_with str "user=" -> let user' = String.sub str 5 (String.length str - 5) in user := Some user' | str when String.starts_with str "password=" -> let password' = String.sub str 9 (String.length str - 9) in password := Some password' | str when String.starts_with str "database=" -> let database' = String.sub str 9 (String.length str - 9) in database := Some database' | str when String.starts_with str "unix_domain_socket_dir=" -> let socket = String.sub str 23 (String.length str - 23) in unix_domain_socket_dir := Some socket | str when String.starts_with str "comment_src_loc=" -> let comment_src_loc' = String.sub str 19 (String.length str - 19) in begin match comment_src_loc' with | "yes" | "1" | "on" -> comment_src_loc := true | "no" | "0" | "off" -> comment_src_loc := false | _ -> loc_raise loc (Failure "Unrecognized value for option 'comment_src_loc'") end | str when String.starts_with str "show=" -> let shownam = String.sub str 5 (String.length str - 5) in show := Some shownam | str when String.starts_with str "load_custom_from=" -> let txt = String.sub str 17 (String.length str - 17) in load_custom_from := Some ((Unix.getcwd ()) ^ "/" ^ txt) | str -> loc_raise loc ( Failure ("Unknown flag: " ^ str) ) ) flags; let f_execute = !f_execute in let f_nullable_results = !f_nullable_results in let host = !host in let user = !user in let password = !password in let database = !database in let port = !port in let unix_domain_socket_dir = !unix_domain_socket_dir in let key = PGOCaml.describe_connection ?host ?user ?password ?database ?port ?unix_domain_socket_dir () in key, f_execute, f_nullable_results, !comment_src_loc, !show, !load_custom_from let mk_conversions ?load_custom_from ~loc ~dbh results = List.mapi ( fun i (result, nullable) -> let field_type = result.PGOCaml.field_type in let fn = match unravel_type dbh ?load_custom_from ~colnam:result.PGOCaml.name field_type with | nam, None -> let fn = nam ^ "_of_string" in [%expr PGOCaml.( [%e exp_of_string ~loc fn ] ) ][@metaloc loc] | _nam, Some (_, deserialize) -> exp_of_string ~loc deserialize in let col = let cname = "c" ^ string_of_int i in Exp.ident { txt = Lident cname; loc } in let sconv = [%expr match [%e col] with Some x -> x | None -> "-"][@metaloc loc] in if nullable then ([%expr PGOCaml_aux.Option.map [%e fn] [%e col] ] [@metaloc loc]) , sconv else ([%expr [%e fn] (try PGOCaml_aux.Option.get [%e col] with | _ -> failwith "ppx_pgsql's nullability heuristic has failed - use \"nullable-results\"" ) ][@metaloc loc]) , sconv ) results let coretype_of_type ~loc ~dbh oid = let typ = match unravel_type dbh oid with | "timestamp", _ -> Longident.Ldot(Ldot(Lident "CalendarLib", "Calendar"), "t") | nam, _ -> Lident nam in { ptyp_desc = Ptyp_constr({txt = typ; loc}, []); ptyp_loc = loc; ptyp_attributes = []; ptyp_loc_stack = [] } (** produce a list pattern to match the result of a query *) let mk_listpat ~loc results = List.fold_right (fun i tail -> let var = Pat.var @@ { txt = "c"^string_of_int i; loc } in ([%pat? [%p var]::[%p tail]][@metaloc loc]) ) (range 0 (List.length results)) ([%pat? []][@metaloc loc]) let pgsql_expand ~genobject ?(flags = []) loc dbh query = let open Rresult in let (key, f_execute, f_nullable_results, comment_src_loc, show, load_custom_from) = parse_flags flags loc in let query = if comment_src_loc then let start = loc.Location.loc_start in let open Lexing in (Printf.sprintf "-- '%s' L%d\n" start.pos_fname start.pos_lnum) ^ query else query in (* Connect, if necessary, to the database. *) get_connection ~loc key >>= fun my_dbh -> (* Split the query into text and variable name parts using Re.split_full. * eg. "select id from employees where name = $name and salary > $salary" * would become a structure equivalent to: * ["select id from employees where name = "; "$name"; " and salary > "; * "$salary"]. * Actually it's a wee bit more complicated than that ... *) let split = let f = function | `Text text -> `Text text | `Delim subs -> `Var Re.Group.(get subs 3, test subs 1, test subs 2) in List.map f (Re.split_full rex query) in (* Go to the database, prepare this statement, and find out exactly * what the parameter types and return values are. Exceptions can * be raised here if the statement is bad SQL. *) let (params, results), varmap = (* Rebuild the query with $n placeholders for each variable. *) let next = let i = ref 0 in fun () -> incr i; !i in let varmap = Hashtbl.create 8 in let query = String.concat "" ( List.map ( function | `Text text -> text | `Var (varname, false, option) -> let i = next () in Hashtbl.add varmap i (varname, false, option); Printf.sprintf "$%d" i | `Var (varname, true, option) -> let i = next () in Hashtbl.add varmap i (varname, true, option); Printf.sprintf "($%d)" i ) split ) in let varmap = Hashtbl.fold ( fun i var vars -> (i, var) :: vars ) varmap [] in try PGOCaml.prepare my_dbh ~query (); PGOCaml.describe_statement my_dbh (), varmap with exn -> loc_raise loc exn in (* If the PGSQL(dbh) "execute" flag was used, we will actually * execute the statement now. Normally this would never be used, but * some statements need to be executed, particularly CREATE TEMPORARY * TABLE. *) if f_execute then ignore (PGOCaml.execute my_dbh ~params:[] ()); (* Number of params should match length of map, otherwise something * has gone wrong in the substitution above. *) if List.length varmap <> List.length params then loc_raise loc ( Failure ("Mismatch in number of parameters found by database. " ^ "Most likely your statement contains bare $, $number, etc.") ); (* Generate a function for converting the parameters. * * See also: * http://archives.postgresql.org/pgsql-interfaces/2006-01/msg00043.php *) let params = List.fold_right (fun (i, { PGOCaml.param_type = param_type }) tail -> let varname, list, option = List.assoc i varmap in let argnam = if String.starts_with varname "{" then None else Some varname in let varname = if String.starts_with varname "{" then String.sub varname 1 (String.length varname - 2) else varname in let varname, typnam = match String.index_opt varname ':' with | None -> varname, None | Some _ -> let[@warning "-8"] [varname; typnam] = String.split_on_char ':' varname in varname, Some (String.trim typnam) in let varname = exp_of_string ~loc varname in let varname = {varname with pexp_loc = loc} in let fn = match unravel_type ?load_custom_from ?argnam ?typnam my_dbh param_type with | nam, None -> let fn = exp_of_string ~loc ("string_of_" ^ nam) in [%expr PGOCaml.([%e fn])][@metaloc loc] | _, Some (serialize, _) -> exp_of_string ~loc serialize in let head = match list, option with | false, false -> [%expr [Some ([%e fn] [%e varname])]][@metaloc loc] | false, true -> [%expr [PGOCaml_aux.Option.map [%e fn] [%e varname]]][@metaloc loc] | true, false -> [%expr List.map (fun x -> Some ([%e fn] x)) [%e varname]][@metaloc loc] | true, true -> [%expr List.map (fun x -> PGOCaml_aux.Option.map [%e fn]) [%e varname]][@metaloc loc] in ([%expr [%e head]::[%e tail]][@metaloc loc]) ) (List.combine (range 1 (1 + List.length varmap)) params) ([%expr []][@metaloc loc]) in (* Substitute expression. *) let expr = let split = List.fold_right ( fun s tail -> let head = match s with | `Text text -> ([%expr `Text [%e const_string ~loc text]][@metaloc loc]) | `Var (varname, list, option) -> let list = if list then ([%expr true][@metaloc loc]) else ([%expr false][@metaloc loc]) in let option = if option then ([%expr true][@metaloc loc]) else ([%expr false][@metaloc loc]) in ([%expr `Var ([%e const_string ~loc varname], [%e list], [%e option])][@metaloc loc]) in ([%expr [%e head] :: [%e tail]][@metaloc loc]) ) split ([%expr []][@metaloc loc]) in [%expr (* let original_query = $str:query$ in * original query string *) let dbh = [%e dbh] in let params : string option list list = [%e params] in let split = [%e split] in (* split up query *) (* Rebuild the query with appropriate placeholders. A single list * param can expand into several placeholders. *) let i = ref 0 in (* Counts parameters. *) let j = ref 0 in (* Counts placeholders. *) let query = String.concat "" ( List.map ( function | `Text text -> text | `Var (_varname, false, _) -> (* non-list item *) let () = incr i in (* next parameter *) let () = incr j in (* next placeholder number *) "$" ^ string_of_int j.contents | `Var (_varname, true, _) -> (* list item *) let param = List.nth params i.contents in let () = incr i in (* next parameter *) "(" ^ String.concat "," ( List.map ( fun _ -> let () = incr j in (* next placeholder number *) "$" ^ string_of_int j.contents ) param ) ^ ")" ) split) in (* Flatten the parameters to a simple list now. *) let params = List.flatten params in (* Get a unique name for this query using an MD5 digest. *) let name = "ppx_pgsql." ^ Digest.to_hex (Digest.string query) in (* Get the hash table used to keep track of prepared statements. *) let hash = try PGOCaml.private_data dbh with | Not_found -> let hash = Hashtbl.create 17 in PGOCaml.set_private_data dbh hash; hash in (* Have we prepared this statement already? If not, do so. *) let is_prepared = Hashtbl.mem hash name in PGOCaml.bind (if not is_prepared then PGOCaml.bind (PGOCaml.prepare dbh ~name ~query ()) (fun () -> Hashtbl.add hash name true; PGOCaml.return () ) else PGOCaml.return ()) (fun () -> (* Execute the statement, returning the rows. *) PGOCaml.execute_rev dbh ~name ~params ()) ][@metaloc loc] in (** decorate the results with the nullability heuristic *) let results' = match results with | Some results -> Some ( List.map (fun result -> match (result.PGOCaml.table, result.PGOCaml.column) with | Some table, Some column -> (* Find out whether the column is nullable from the * database pg_attribute table. *) let params = [ Some (PGOCaml.string_of_oid table); Some (PGOCaml.string_of_int column) ] in let _rows = PGOCaml.execute my_dbh ~name:nullable_name ~params () in let not_nullable = match _rows with | [ [ Some b ] ] -> PGOCaml.bool_of_string b | _ -> false in result, f_nullable_results || not not_nullable | _ -> result, f_nullable_results || true (* Assume it could be nullable. *)) results ) | None -> None in let mkexpr ~convert ~list = [%expr PGOCaml.bind [%e expr] (fun _rows -> PGOCaml.return (let original_query = [%e const_string ~loc query] in List.rev_map ( fun row -> match row with | [%p list] -> [%e convert] | _ -> (* This should never happen, even if the schema changes. * Well, maybe if the user does 'SELECT *'. *) let msg = "ppx_pgsql: internal error: " ^ "Incorrect number of columns returned from query: " ^ original_query ^ ". Columns are: " ^ String.concat "; " ( List.map ( function | Some str -> Printf.sprintf "%S" str | None -> "NULL" ) row ) in raise (PGOCaml.Error msg) ) _rows)) ][@metaloc loc] in (* If we're expecting any result rows, then generate a function to * convert them. Otherwise return unit. Note that we can only * determine the nullability of results if they correspond to real * columns in a table, otherwise the type will always be 'type option'. *) match (genobject, results') with | true, Some results -> let list = mk_listpat ~loc results in let fields = List.map (fun ({PGOCaml.name; field_type; _}, nullable) -> name, coretype_of_type ~loc ~dbh:my_dbh field_type, nullable) results in let convert = List.fold_left2 (fun (lsacc, showacc) (name, _, _) (conv, sconv) -> let hd = { pcf_desc = Pcf_method( {txt = name; loc} , Public , Cfk_concrete(Fresh, conv) ) ; pcf_loc = loc ; pcf_attributes = [] } in let ename = const_string ~loc name in let showacc = [%expr let fields = ([%e ename], [%e sconv]) :: fields in [%e showacc] ][@metaloc loc] in (hd :: lsacc, showacc) ) ( [] , [%expr List.fold_left (fun buffer (name, value) -> let () = Buffer.add_string buffer name in let () = Buffer.add_char buffer ':' in let () = Buffer.add_char buffer ' ' in let () = Buffer.add_string buffer value in let () = Buffer.add_char buffer '\n' in buffer ) (Buffer.create 16) fields |> Buffer.contents ][@metaloc loc] ) fields (mk_conversions ?load_custom_from ~loc ~dbh:my_dbh results) |> fun (fields, fshow) -> let fshow = [%expr let fields = [] in [%e fshow]][@metaloc loc] in let fields = match show with | Some txt -> { pcf_desc = Pcf_method( {txt; loc} , Public , Cfk_concrete(Fresh, fshow) ) ; pcf_loc = loc ; pcf_attributes = [] } :: fields | None -> fields in Exp.mk ( Pexp_object({ pcstr_self = Pat.any ~loc () ; pcstr_fields = fields }) ) in let expr = mkexpr ~convert ~list in Ok expr | true, None -> Error("It doesn't make sense to make an object to encapsulate results that aren't coming", loc) | false, Some results -> let list = mk_listpat ~loc results in let convert = let conversions = mk_conversions ?load_custom_from ~loc ~dbh:my_dbh results |> List.map fst in (* Avoid generating a single-element tuple. *) match conversions with | [] -> [%expr ()][@metaloc loc] | [a] -> a | conversions -> Exp.tuple conversions in Ok(mkexpr ~convert ~list) | false, None -> Ok ([%expr PGOCaml.bind [%e expr] (fun _rows -> PGOCaml.return ())][@metaloc loc]) let expand_sql ~genobject loc dbh extras = let query, flags = match List.rev extras with | [] -> assert false | query :: flags -> query, flags in try pgsql_expand ~genobject ~flags loc dbh query with | Failure s -> Error(s, loc) | PGOCaml.Error s -> Error(s, loc) | PGOCaml.PostgreSQL_Error (s, fields) -> let fields' = List.map (fun (c, s) -> Printf.sprintf "(%c: %s)" c s) fields in Error ("Postgres backend error: " ^ s ^ ": " ^ s ^ String.concat "," fields', loc) | exn -> Error("Unexpected PG'OCaml PPX error: " ^ Printexc.to_string exn, loc) (* Returns the empty list if one of the elements is not a string constant *) let list_of_string_args args = let maybe_strs = List.map (function | (Nolabel, {pexp_desc = Pexp_constant (Pconst_string (str, _, None)); _}) -> Some str | _ -> None) args in if List.mem None maybe_strs then [] else List.map (function Some x -> x | None -> assert false) maybe_strs let gen_expand genobject ~loc ~path:_ expr = match expr with | {pexp_desc = Pexp_apply (dbh, args); pexp_loc = qloc; _} -> begin match list_of_string_args args with | [] -> Location.raise_errorf ~loc "Something unsupported" | args -> begin match expand_sql ~genobject loc dbh args with | Ok pexp -> { pexp with pexp_loc = qloc } | Error(s, loc) -> Location.raise_errorf ~loc "PG'OCaml PPX error: %s" s end end | _ -> Location.raise_errorf ~loc "Something unsupported" let extension_pgsql = Extension.declare "pgsql" Extension.Context.expression Ast_pattern.(single_expr_payload __) (gen_expand false) let extension_pgsql_object = Extension.declare "pgsql.object" Extension.Context.expression Ast_pattern.(single_expr_payload __) (gen_expand true) let rule_pgsql = Context_free.Rule.extension extension_pgsql let rule_pgsql_object = Context_free.Rule.extension extension_pgsql_object let () = Driver.register_transformation "pgocaml" ~rules:[rule_pgsql; rule_pgsql_object] pgocaml-4.4.0/ppx/ppx_pgsql.mldylib000066400000000000000000000001241450353127600173460ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d41d8cd98f00b204e9800998ecf8427e) # OASIS_STOP pgocaml-4.4.0/ppx/ppx_pgsql.mllib000066400000000000000000000001241450353127600170110ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d41d8cd98f00b204e9800998ecf8427e) # OASIS_STOP pgocaml-4.4.0/src/000077500000000000000000000000001450353127600137365ustar00rootroot00000000000000pgocaml-4.4.0/src/PGOCaml.ml000066400000000000000000000030171450353127600155130ustar00rootroot00000000000000(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. * * PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2009 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) module Simple_thread = struct type 'a t = 'a let return x = x let (>>=) v f = f v let fail = raise let catch f fexn = try f () with e -> fexn e type in_channel = Stdlib.in_channel type out_channel = Stdlib.out_channel let open_connection = Unix.open_connection let output_char = output_char let output_binary_int = output_binary_int let output_string = output_string let flush = flush let input_char = input_char let input_binary_int = input_binary_int let really_input = really_input let close_in = close_in end module M = PGOCaml_generic.Make (Simple_thread) include M pgocaml-4.4.0/src/PGOCaml.mli000066400000000000000000000020671450353127600156700ustar00rootroot00000000000000(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. * * PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2009 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) module Simple_thread : PGOCaml_generic.THREAD with type 'a t = 'a include PGOCaml_generic.PGOCAML_GENERIC with type 'a monad = 'a pgocaml-4.4.0/src/PGOCaml_aux.ml000066400000000000000000000026321450353127600163720ustar00rootroot00000000000000module String = struct include String let starts_with str prefix = let len = length prefix in if length str < len then false else let rec aux i = if i >= len then true else if unsafe_get str i <> unsafe_get prefix i then false else aux (i + 1) in aux 0 let join = concat let implode xs = let buf = Buffer.create (List.length xs) in List.iter (Buffer.add_char buf) xs; Buffer.contents buf let fold_left f init str = let len = length str in let rec loop i accum = if i = len then accum else loop (i + 1) (f accum str.[i]) in loop 0 init (* Only available in the standard library since OCaml 4.02 *) let init n f = let s = Bytes.create n in for i = 0 to n - 1 do Bytes.unsafe_set s i (f i) done; Bytes.to_string s end module Option = struct let default v = function | Some v -> v | None -> v let get = function | Some v -> v | None -> invalid_arg "PGOCaml_aux.Option.get" let map f = function | Some v -> Some (f v) | None -> None end module List = struct include List let iteri f xs = let rec loop i = function | [] -> () | hd :: tl -> f i hd; loop (i+1) tl in loop 0 xs let mapi f xs = let rec loop i = function | [] -> [] | hd :: tl -> let hd' = f i hd in hd' :: loop (i+1) tl in loop 0 xs end pgocaml-4.4.0/src/PGOCaml_aux.mli000066400000000000000000000011561450353127600165430ustar00rootroot00000000000000module String : sig include module type of String val starts_with : string -> string -> bool val join : string -> string list -> string val implode : char list -> string val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a val init: int -> (int -> char) -> string end module Option : sig val default : 'a -> 'a option -> 'a val get : 'a option -> 'a val map : ('a -> 'b) -> 'a option -> 'b option end module List : sig include module type of List val iteri : (int -> 'a -> unit) -> 'a list -> unit val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list end pgocaml-4.4.0/src/PGOCaml_genconfig.ml000066400000000000000000000005051450353127600175310ustar00rootroot00000000000000let dir = if Sys.file_exists "/var/run/postgresql" then "/var/run/postgresql" else Filename.get_temp_dir_name () let () = Printf.printf {|let default_port = %d let default_user = %S let default_password = %S let default_unix_domain_socket_dir = %S let default_comment_src_loc = %B|} 5432 "postgres" "" dir false pgocaml-4.4.0/src/PGOCaml_generic.ml000066400000000000000000002002471450353127600172130ustar00rootroot00000000000000(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. * * PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2009 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) open PGOCaml_aux open CalendarLib open Printf module type THREAD = sig type 'a t val return : 'a -> 'a t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val fail : exn -> 'a t val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t type in_channel type out_channel val open_connection : Unix.sockaddr -> (in_channel * out_channel) t val output_char : out_channel -> char -> unit t val output_binary_int : out_channel -> int -> unit t val output_string : out_channel -> string -> unit t val flush : out_channel -> unit t val input_char : in_channel -> char t val input_binary_int : in_channel -> int t val really_input : in_channel -> Bytes.t -> int -> int -> unit t val close_in : in_channel -> unit t end module type PGOCAML_GENERIC = sig type 'a t (** Database handle. *) type 'a monad type isolation = [ `Serializable | `Repeatable_read | `Read_committed | `Read_uncommitted ] type access = [ `Read_write | `Read_only ] exception Error of string (** For library errors. *) exception PostgreSQL_Error of string * (char * string) list (** For errors generated by the PostgreSQL database back-end. The * first argument is a printable error message. The second argument * is the complete set of error fields returned from the back-end. * See [http://www.postgresql.org/docs/8.1/static/protocol-error-fields.html] *) (** {6 Connection management} *) type connection_desc = { user: string; port: int; password: string; host: [ `Hostname of string | `Unix_domain_socket_dir of string]; database: string } val describe_connection : ?host:string -> ?port:int -> ?user:string -> ?password:string -> ?database:string -> ?unix_domain_socket_dir:string -> unit -> connection_desc (** Produce the actual, concrete connection parameters based on the values and * availability of the various configuration variables. *) val connection_desc_to_string : connection_desc -> string (** Produce a human-readable textual representation of a concrete connection * descriptor (the password is NOT included in the output of this function) * for logging and error reporting purposes. *) val connect : ?host:string -> ?port:int -> ?user:string -> ?password:string -> ?database:string -> ?unix_domain_socket_dir:string -> ?desc:connection_desc -> unit -> 'a t monad (** Connect to the database. The normal [$PGDATABASE], etc. environment * variables are available. *) val close : 'a t -> unit monad (** Close the database handle. You must call this after you have * finished with the handle, or else you will get leaked file * descriptors. *) val ping : 'a t -> unit monad (** Ping the database. If the database is not available, some sort of * exception will be thrown. *) val alive : 'a t -> bool monad (** This function is a wrapper of [ping] that returns a boolean instead of * raising an exception. *) (** {6 Transactions} *) val begin_work : ?isolation:isolation -> ?access:access -> ?deferrable:bool -> 'a t -> unit monad (** Start a transaction. *) val commit : 'a t -> unit monad (** Perform a COMMIT operation on the database. *) val rollback : 'a t -> unit monad (** Perform a ROLLBACK operation on the database. *) val transact : 'a t -> ?isolation:isolation -> ?access:access -> ?deferrable:bool -> ('a t -> 'b monad) -> 'b monad (** [transact db ?isolation ?access ?deferrable f] wraps your * function [f] inside a transactional block. * First it calls [begin_work] with [isolation], [access] and [deferrable], * then calls [f] and do [rollback] if [f] raises * an exception, [commit] otherwise. *) (** {6 Serial column} *) val serial : 'a t -> string -> int64 monad (** This is a shorthand for [SELECT CURRVAL(serial)]. For a table * called [table] with serial column [id] you would typically * call this as [serial dbh "table_id_seq"] after the previous INSERT * operation to get the serial number of the inserted row. *) val serial4 : 'a t -> string -> int32 monad (** As {!serial} but assumes that the column is a SERIAL or * SERIAL4 type. *) val serial8 : 'a t -> string -> int64 monad (** Same as {!serial}. *) (** {6 Miscellaneous} *) val max_message_length : int ref (** Maximum message length accepted from the back-end. The default * is [Sys.max_string_length], which means that we will try to read as * much data from the back-end as we can, and this may cause us to * run out of memory (particularly on 64 bit machines), causing a * possible denial of service. You may want to set this to a smaller * size to avoid this happening. *) val verbose : int ref (** Verbosity. 0 means don't print anything. 1 means print short * error messages as returned from the back-end. 2 means print all * messages as returned from the back-end. Messages are printed on [stderr]. * Default verbosity level is 1. *) val set_private_data : 'a t -> 'a -> unit (** Attach some private data to the database handle. * * NB. The pa_pgsql camlp4 extension uses this for its own purposes, which * means that in most programs you will not be able to attach private data * to the database handle. *) val private_data : 'a t -> 'a (** Retrieve some private data previously attached to the database handle. * If no data has been attached, raises [Not_found]. * * NB. The pa_pgsql camlp4 extension uses this for its own purposes, which * means that in most programs you will not be able to attach private data * to the database handle. *) val uuid : 'a t -> string type pa_pg_data = (string, bool) Hashtbl.t (** When using pa_pgsql, database handles have type * [PGOCaml.pa_pg_data PGOCaml.t] *) (** {6 Low level query interface - DO NOT USE DIRECTLY} *) type oid = int32 [@@deriving show] type param = string option (* None is NULL. *) type result = string option (* None is NULL. *) type row = result list (* One row is a list of fields. *) val prepare : 'a t -> query:string -> ?name:string -> ?types:oid list -> unit -> unit monad (** [prepare conn ~query ?name ?types ()] prepares the statement [query] * and optionally names it [name] and sets the parameter types to [types]. * If no name is given, then the "unnamed" statement is overwritten. If * no types are given, then the PostgreSQL engine infers types. * Synchronously checks for errors. *) val execute_rev : 'a t -> ?name:string -> ?portal:string -> params:param list -> unit -> row list monad val execute : 'a t -> ?name:string -> ?portal:string -> params:param list -> unit -> row list monad (** [execute conn ?name ~params ()] executes the named or unnamed * statement [name], with the given parameters [params], * returning the result rows (if any). * * There are several steps involved at the protocol layer: * (1) a "portal" is created from the statement, binding the * parameters in the statement (Bind). * (2) the portal is executed (Execute). * (3) we synchronise the connection (Sync). * * The optional [?portal] parameter may be used to name the portal * created in step (1) above (otherwise the unnamed portal is used). * This is only important if you want to call {!PGOCaml.describe_portal} * to find out the result types. *) val cursor : 'a t -> ?name:string -> ?portal:string -> params:param list -> (row -> unit monad) -> unit monad val close_statement : 'a t -> ?name:string -> unit -> unit monad (** [close_statement conn ?name ()] closes a prepared statement and frees * up any resources. *) val close_portal : 'a t -> ?portal:string -> unit -> unit monad (** [close_portal conn ?portal ()] closes a portal and frees up any resources. *) val inject : 'a t -> ?name:string -> string -> row list monad (** [inject conn ?name query] executes the statement [query] * and optionally names it [name] and gives the result. *) val alter : 'a t -> ?name:string -> string -> unit monad (** [alter conn ?name query] executes the statement [query] * and optionally names it [name]. Same as inject but ignoring the result. *) type result_description = { name : string; (** Field name. *) table : oid option; (** OID of table. *) column : int option; (** Column number of field in table. *) field_type : oid; (** The type of the field. *) length : int; (** Length of the field. *) modifier : int32; (** Type modifier. *) }[@@deriving show] type row_description = result_description list [@@deriving show] type param_description = { param_type : oid; (** The type of the parameter. *) } type params_description = param_description list val describe_statement : 'a t -> ?name:string -> unit -> (params_description * row_description option) monad (** [describe_statement conn ?name ()] describes the named or unnamed * statement's parameter types and result types. *) val describe_portal : 'a t -> ?portal:string -> unit -> row_description option monad (** [describe_portal conn ?portal ()] describes the named or unnamed * portal's result types. *) (** {6 Low level type conversion functions - DO NOT USE DIRECTLY} *) val name_of_type : oid -> string (** Returns the OCaml equivalent type name to the PostgreSQL type [oid]. * For instance, [name_of_type (Int32.of_int 23)] returns ["int32"] because * the OID for PostgreSQL's internal [int4] type is [23]. As another * example, [name_of_type (Int32.of_int 25)] returns ["string"]. *) type inet = Unix.inet_addr * int type timestamptz = Calendar.t * Time_Zone.t type int16 = int type bytea = string (* XXX *) type point = float * float type hstore = (string * string option) list type numeric = string type uuid = string type jsonb = string type bool_array = bool option list type int16_array = int16 option list type int32_array = int32 option list type int64_array = int64 option list type string_array = string option list type float_array = float option list type timestamp_array = Calendar.t option list type uuid_array = string option list (** The following conversion functions are used by pa_pgsql to convert * values in and out of the database. *) val string_of_oid : oid -> string val string_of_bool : bool -> string val string_of_int : int -> string val string_of_int16 : int16 -> string val string_of_int32 : int32 -> string val string_of_int64 : int64 -> string val string_of_float : float -> string val string_of_point : point -> string val string_of_hstore : hstore -> string val string_of_numeric : numeric -> string val string_of_uuid : uuid -> string val string_of_jsonb : jsonb -> string val string_of_inet : inet -> string val string_of_timestamp : Calendar.t -> string val string_of_timestamptz : timestamptz -> string val string_of_date : Date.t -> string val string_of_time : Time.t -> string val string_of_interval : Calendar.Period.t -> string val string_of_bytea : bytea -> string val string_of_string : string -> string val string_of_unit : unit -> string val string_of_bool_array : bool_array -> string val string_of_int16_array : int16_array -> string val string_of_int32_array : int32_array -> string val string_of_int64_array : int64_array -> string val string_of_string_array : string_array -> string val string_of_bytea_array : string_array -> string val string_of_float_array : float_array -> string val string_of_timestamp_array : timestamp_array -> string val string_of_arbitrary_array : ('a -> string) -> 'a option list -> string val string_of_uuid_array : string_array -> string val comment_src_loc : unit -> bool val find_custom_typconvs : ?typnam:string -> ?lookin:string -> ?colnam:string -> ?argnam:string -> unit -> ((string * string) option, string) Rresult.result val oid_of_string : string -> oid val bool_of_string : string -> bool val int_of_string : string -> int val int16_of_string : string -> int16 val int32_of_string : string -> int32 val int64_of_string : string -> int64 val float_of_string : string -> float val point_of_string : string -> point val hstore_of_string : string -> hstore val numeric_of_string : string -> numeric val uuid_of_string : string -> uuid val jsonb_of_string : string -> jsonb val inet_of_string : string -> inet val timestamp_of_string : string -> Calendar.t val timestamptz_of_string : string -> timestamptz val date_of_string : string -> Date.t val time_of_string : string -> Time.t val interval_of_string : string -> Calendar.Period.t val bytea_of_string : string -> bytea val unit_of_string : string -> unit val bool_array_of_string : string -> bool_array val int16_array_of_string : string -> int16_array val int32_array_of_string : string -> int32_array val int64_array_of_string : string -> int64_array val string_array_of_string : string -> string_array val float_array_of_string : string -> float_array val timestamp_array_of_string : string -> timestamp_array val arbitrary_array_of_string : (string -> 'a) -> string -> 'a option list val bind : 'a monad -> ('a -> 'b monad) -> 'b monad val return : 'a -> 'a monad end module Make (Thread : THREAD) = struct open Thread type connection_desc = { user: string; port: int; password: string; host: [ `Hostname of string | `Unix_domain_socket_dir of string]; database: string } type 'a t = { ichan : in_channel; (* In_channel wrapping socket. *) chan : out_channel; (* Out_channel wrapping socket. *) mutable private_data : 'a option; uuid : string; (* UUID for this connection. *) } type 'a monad = 'a Thread.t type isolation = [ `Serializable | `Repeatable_read | `Read_committed | `Read_uncommitted ] type access = [ `Read_write | `Read_only ] exception Error of string exception PostgreSQL_Error of string * (char * string) list (* If true, emit a lot of debugging information about the protocol on stderr.*) let debug_protocol = false (*----- Code to generate messages for the back-end. -----*) let new_message typ = let buf = Buffer.create 128 in buf, Some typ (* StartUpMessage and SSLRequest are special messages which don't * have a type byte field. *) let new_start_message () = let buf = Buffer.create 128 in buf, None let add_byte (buf, _) i = (* Deliberately throw an exception if i isn't [0..255]. *) Buffer.add_char buf (Char.chr i) let add_char (buf, _) c = Buffer.add_char buf c let add_int16 (buf, _) i = if i < 0 || i > 65_535 then raise (Error "PGOCaml: int16 is outside range [0..65535]."); Buffer.add_char buf (Char.unsafe_chr ((i lsr 8) land 0xff)); Buffer.add_char buf (Char.unsafe_chr (i land 0xff)) let add_int32 (buf, _) i = let base = Int32.to_int i in let big = Int32.to_int (Int32.shift_right_logical i 24) in Buffer.add_char buf (Char.unsafe_chr (big land 0xff)); Buffer.add_char buf (Char.unsafe_chr ((base lsr 16) land 0xff)); Buffer.add_char buf (Char.unsafe_chr ((base lsr 8) land 0xff)); Buffer.add_char buf (Char.unsafe_chr (base land 0xff)) let add_string_no_trailing_nil (buf, _) str = (* Check the string doesn't contain '\0' characters. *) if String.contains str '\000' then raise (Error (sprintf "PGOCaml: string contains ASCII NIL character: %S" str)); if String.length str > 0x3fff_ffff then raise (Error "PGOCaml: string is too long."); Buffer.add_string buf str let add_string msg str = add_string_no_trailing_nil msg str; add_byte msg 0 let send_message { chan; _ } (buf, typ) = (* Get the length in bytes. *) let len = 4 + Buffer.length buf in (* If the length is longer than a 31 bit integer, then the message is * too long to send. This limits messages to 1 GB, which should be * enough for anyone :-) *) if Int64.of_int len >= 0x4000_0000L then raise (Error "PGOCaml: message is larger than 1 GB"); if debug_protocol then eprintf "> %s%d %S\n%!" (match typ with | None -> "" | Some c -> sprintf "%c " c) len (Buffer.contents buf); (* Write the type byte? *) (match typ with | None -> Thread.return () | Some c -> output_char chan c ) >>= fun () -> (* Write the length field. *) output_binary_int chan len >>= fun () -> (* Write the buffer. *) output_string chan (Buffer.contents buf) (* Max message length accepted from back-end. *) let max_message_length = ref Sys.max_string_length (* Receive a single result message. Parse out the message type, * message length, and binary message content. *) let receive_raw_message { ichan; chan; _ } = (* Flush output buffer. *) flush chan >>= fun () -> input_char ichan >>= fun typ -> input_binary_int ichan >>= fun len -> (* Discount the length word itself. *) let len = len - 4 in (* If the message is too long, give up now. *) if len > !max_message_length then ( (* Skip the message so we stay in synch with the stream. *) let bufsize = 65_536 in let buf = Bytes.create bufsize in let rec loop n = if n > 0 then begin let m = min n bufsize in really_input ichan buf 0 m >>= fun () -> loop (n - m) end else return () in loop len >>= fun () -> fail (Error "PGOCaml: back-end message is longer than max_message_length") ) else ( (* Read the binary message content. *) let msg = Bytes.create len in really_input ichan msg 0 len >>= fun () -> return (typ, Bytes.to_string msg) ) (* Parse a back-end message. *) type msg_t = | AuthenticationOk | AuthenticationKerberosV5 | AuthenticationCleartextPassword | AuthenticationCryptPassword of string | AuthenticationMD5Password of string | AuthenticationSCMCredential | BackendKeyData of int32 * int32 | BindComplete | CloseComplete | CommandComplete of string | DataRow of (int * string) list | EmptyQueryResponse | ErrorResponse of (char * string) list | NoData | NoticeResponse of (char * string) list | NotificationResponse | ParameterDescription of int32 list | ParameterStatus of string * string | ParseComplete | ReadyForQuery of char | RowDescription of (string * int32 * int * int32 * int * int32 * int) list | UnknownMessage of char * string let string_of_msg_t = function | AuthenticationOk -> "AuthenticationOk" | AuthenticationKerberosV5 -> "AuthenticationKerberosV5" | AuthenticationCleartextPassword -> "AuthenticationCleartextPassword" | AuthenticationCryptPassword str -> sprintf "AuthenticationCleartextPassword %S" str | AuthenticationMD5Password str -> sprintf "AuthenticationMD5Password %S" str | AuthenticationSCMCredential -> "AuthenticationMD5Password" | BackendKeyData (i1, i2) -> sprintf "BackendKeyData %ld, %ld" i1 i2 | BindComplete -> "BindComplete" | CloseComplete -> "CloseComplete" | CommandComplete str -> sprintf "CommandComplete %S" str | DataRow fields -> sprintf "DataRow [%s]" (String.concat "; " (List.map (fun (len, bytes) -> sprintf "%d, %S" len bytes) fields)) | EmptyQueryResponse -> "EmptyQueryResponse" | ErrorResponse strs -> sprintf "ErrorResponse [%s]" (String.concat "; " (List.map (fun (k, v) -> sprintf "%c, %S" k v) strs)) | NoData -> "NoData" | NoticeResponse strs -> sprintf "NoticeResponse [%s]" (String.concat "; " (List.map (fun (k, v) -> sprintf "%c, %S" k v) strs)) | NotificationResponse -> "NotificationResponse" | ParameterDescription fields -> sprintf "ParameterDescription [%s]" (String.concat "; " (List.map (fun oid -> sprintf "%ld" oid) fields)) | ParameterStatus (s1, s2) -> sprintf "ParameterStatus %S, %S" s1 s2 | ParseComplete -> "ParseComplete" | ReadyForQuery c -> sprintf "ReadyForQuery %s" (match c with | 'I' -> "Idle" | 'T' -> "inTransaction" | 'E' -> "Error" | c -> sprintf "unknown(%c)" c) | RowDescription fields -> sprintf "RowDescription [%s]" (String.concat "; " (List.map (fun (name, table, col, oid, len, modifier, format) -> sprintf "%s %ld %d %ld %d %ld %d" name table col oid len modifier format) fields)) | UnknownMessage (typ, msg) -> sprintf "UnknownMessage %c, %S" typ msg let parse_backend_message (typ, msg) = let pos = ref 0 in let len = String.length msg in (* Functions to grab the next object from the string 'msg'. *) let get_char where = if !pos < len then ( let r = msg.[!pos] in incr pos; r ) else raise (Error ("PGOCaml: parse_backend_message: " ^ where ^ ": short message")) in let get_byte where = Char.code (get_char where) in let get_int16 () = let r0 = get_byte "get_int16" in let r1 = get_byte "get_int16" in (r0 lsr 8) + r1 in let get_int32 () = let r0 = get_byte "get_int32" in let r1 = get_byte "get_int32" in let r2 = get_byte "get_int32" in let r3 = get_byte "get_int32" in let r = Int32.of_int r0 in let r = Int32.shift_left r 8 in let r = Int32.logor r (Int32.of_int r1) in let r = Int32.shift_left r 8 in let r = Int32.logor r (Int32.of_int r2) in let r = Int32.shift_left r 8 in let r = Int32.logor r (Int32.of_int r3) in r in (*let get_int64 () = let r0 = get_byte "get_int64" in let r1 = get_byte "get_int64" in let r2 = get_byte "get_int64" in let r3 = get_byte "get_int64" in let r4 = get_byte "get_int64" in let r5 = get_byte "get_int64" in let r6 = get_byte "get_int64" in let r7 = get_byte "get_int64" in let r = Int64.of_int r0 in let r = Int64.shift_left r 8 in let r = Int64.logor r (Int64.of_int r1) in let r = Int64.shift_left r 8 in let r = Int64.logor r (Int64.of_int r2) in let r = Int64.shift_left r 8 in let r = Int64.logor r (Int64.of_int r3) in let r = Int64.shift_left r 8 in let r = Int64.logor r (Int64.of_int r4) in let r = Int64.shift_left r 8 in let r = Int64.logor r (Int64.of_int r5) in let r = Int64.shift_left r 8 in let r = Int64.logor r (Int64.of_int r6) in let r = Int64.shift_left r 8 in let r = Int64.logor r (Int64.of_int r7) in r in*) let get_string () = let buf = Buffer.create 16 in let rec loop () = let c = get_char "get_string" in if c <> '\000' then ( Buffer.add_char buf c; loop () ) else Buffer.contents buf in loop () in let get_n_bytes n = String.init n (fun _ -> get_char "get_n_bytes") in let get_char () = get_char "get_char" in (*let get_byte () = get_byte "get_byte" in*) let msg = match typ with | 'R' -> let t = get_int32 () in (match t with | 0l -> AuthenticationOk | 2l -> AuthenticationKerberosV5 | 3l -> AuthenticationCleartextPassword | 4l -> let salt = String.init 2 (fun _ -> get_char ()) in AuthenticationCryptPassword salt | 5l -> let salt = String.init 4 (fun _ -> get_char ()) in AuthenticationMD5Password salt | 6l -> AuthenticationSCMCredential | _ -> UnknownMessage (typ, msg) ); | 'E' -> let strs = ref [] in let rec loop () = let field_type = get_char () in if field_type = '\000' then List.rev !strs (* end of list *) else ( strs := (field_type, get_string ()) :: !strs; loop () ) in ErrorResponse (loop ()) | 'N' -> let strs = ref [] in let rec loop () = let field_type = get_char () in if field_type = '\000' then List.rev !strs (* end of list *) else ( strs := (field_type, get_string ()) :: !strs; loop () ) in NoticeResponse (loop ()) | 'A' -> NotificationResponse | 'Z' -> let c = get_char () in ReadyForQuery c | 'K' -> let pid = get_int32 () in let key = get_int32 () in BackendKeyData (pid, key) | 'S' -> let param = get_string () in let value = get_string () in ParameterStatus (param, value) | '1' -> ParseComplete | '2' -> BindComplete | '3' -> CloseComplete | 'C' -> let str = get_string () in CommandComplete str | 'D' -> let nr_fields = get_int16 () in let fields = ref [] in for _ = 0 to nr_fields-1 do let len = get_int32 () in let field = if len < 0l then (-1, "") else ( if len >= 0x4000_0000l then raise (Error "PGOCaml: result field is too long"); let len = Int32.to_int len in if len > Sys.max_string_length then raise (Error "PGOCaml: result field is too wide for string"); let bytes = get_n_bytes len in len, bytes ) in fields := field :: !fields done; DataRow (List.rev !fields) | 'I' -> EmptyQueryResponse | 'n' -> NoData | 'T' -> let nr_fields = get_int16 () in let fields = ref [] in for _ = 0 to nr_fields-1 do let name = get_string () in let table = get_int32 () in let column = get_int16 () in let oid = get_int32 () in let length = get_int16 () in let modifier = get_int32 () in let format = get_int16 () in fields := (name, table, column, oid, length, modifier, format) :: !fields done; RowDescription (List.rev !fields) | 't' -> let nr_fields = get_int16 () in let fields = ref [] in for _ = 0 to nr_fields - 1 do let oid = get_int32 () in fields := oid :: !fields done; ParameterDescription (List.rev !fields) | _ -> UnknownMessage (typ, msg) in if debug_protocol then eprintf "< %s\n%!" (string_of_msg_t msg); msg let rec receive_message conn = receive_raw_message conn >>= fun msg -> match parse_backend_message msg with | ParameterStatus _ | NoticeResponse _ | NotificationResponse -> (* Skip asynchronous messages *) receive_message conn | msg -> return msg (* Send a message and expect a single result. *) let send_recv conn msg = send_message conn msg >>= fun () -> receive_message conn let verbose = ref 1 type severity = ERROR | FATAL | PANIC | WARNING | NOTICE | DEBUG | INFO | LOG let get_severity fields = let field = try List.assoc 'V' fields (* introduced with PostgreSQL 9.6 *) with Not_found -> List.assoc 'S' fields in match field with | "ERROR" -> ERROR | "FATAL" -> FATAL | "PANIC" -> PANIC | "WARNING" -> WARNING | "NOTICE" -> NOTICE | "DEBUG" -> DEBUG | "INFO" -> INFO | "LOG" -> LOG | _ -> raise Not_found let show_severity = function | ERROR -> "ERROR" | FATAL -> "FATAL" | PANIC -> "PANIC" | WARNING -> "WARNING" | NOTICE -> "NOTICE" | DEBUG -> "DEBUG" | INFO -> "INFO" | LOG -> "LOG" (* Print an ErrorResponse on stderr. *) let print_ErrorResponse fields = if !verbose >= 1 then ( try let severity = try Some (get_severity fields) with Not_found -> None in let severity_string = match severity with | Some s -> show_severity s | None -> "UNKNOWN" in let code = List.assoc 'C' fields in let message = List.assoc 'M' fields in if !verbose = 1 then match severity with | Some ERROR | Some FATAL | Some PANIC -> eprintf "%s: %s: %s\n%!" severity_string code message | _ -> () else eprintf "%s: %s: %s\n%!" severity_string code message with Not_found -> eprintf "WARNING: 'Always present' field is missing in error message\n%!" ); if !verbose >= 2 then ( List.iter ( fun (field_type, field) -> if field_type <> 'S' && field_type <> 'C' && field_type <> 'M' then eprintf "%c: %s\n%!" field_type field ) fields ) let sync_msg conn = let msg = new_message 'S' in send_message conn msg (* Handle an ErrorResponse anywhere, by printing and raising an exception. *) let pg_error ?conn fields = print_ErrorResponse fields; let str = try let severity_string = try show_severity @@ get_severity fields with Not_found -> "UNKNOWN" in let code = List.assoc 'C' fields in let message = List.assoc 'M' fields in sprintf "%s: %s: %s" severity_string code message with Not_found -> "WARNING: 'Always present' field is missing in error message" in (* If conn parameter was given, then resynch - read messages until we * see ReadyForQuery. *) (match conn with | None -> return () | Some conn -> let rec loop () = receive_message conn >>= fun msg -> match msg with ReadyForQuery _ -> return () | _ -> loop () in loop () ) >>= fun () -> fail (PostgreSQL_Error (str, fields)) (*----- Profiling. -----*) type 'a retexn = Ret of 'a | Exn of exn (* profile_op : * string -> string -> string list -> (unit -> 'a Thread.t) -> 'a Thread.t *) let profile_op uuid op detail f = let chan = try let filename = Sys.getenv "PGPROFILING" in let flags = [ Open_wronly; Open_append; Open_creat ] in let chan = open_out_gen flags 0o644 filename in Some chan with | Not_found | Sys_error _ -> None in match chan with | None -> f () (* No profiling - just run it. *) | Some chan -> (* Profiling. *) let start_time = Unix.gettimeofday () in catch (fun () -> f () >>= fun x -> return (Ret x)) (fun exn -> return (Exn exn)) >>= fun ret -> let end_time = Unix.gettimeofday () in let elapsed_time_ms = int_of_float (1000. *. (end_time -. start_time)) in let row = [ "1"; (* Version number. *) uuid; op; string_of_int elapsed_time_ms; match ret with | Ret _ -> "ok" | Exn exn -> Printexc.to_string exn ] @ detail in (* Lock the output channel while we write the row, to prevent * corruption from multiple writers. *) let fd = Unix.descr_of_out_channel chan in Unix.lockf fd Unix.F_LOCK 0; Csv.output_all (Csv.to_channel chan) [row]; close_out chan; (* Return result or re-raise the exception. *) match ret with | Ret r -> return r | Exn exn -> fail exn (*----- Connection. -----*) let pgsql_socket dir port = let sockaddr = sprintf "%s/.s.PGSQL.%d" dir port in Unix.ADDR_UNIX sockaddr let describe_connection ?host ?port ?user ?password ?database ?(unix_domain_socket_dir) () = (* Get the username. *) let user = match user with | Some user -> user | None -> try Sys.getenv "PGUSER" with Not_found -> try let pw = Unix.getpwuid (Unix.geteuid ()) in pw.Unix.pw_name with Not_found -> PGOCaml_config.default_user in (* Get the password. *) let password = match password with | Some password -> password | None -> try Sys.getenv "PGPASSWORD" with Not_found -> PGOCaml_config.default_password in (* Get the database name. *) let database = match database with | Some database -> database | None -> try Sys.getenv "PGDATABASE" with Not_found -> user in (* Get the hostname or Unix domain socket directory. *) let host = let host_or_socket s = if String.length s > 0 && s.[0] = '/' then `Unix_domain_socket_dir s else `Hostname s in match (host, unix_domain_socket_dir) with | (Some _), (Some _) -> raise (Failure "describe_connection: it's invalid to specify both a HOST and a unix domain socket directory") | (Some s), None -> host_or_socket s | None, (Some s) -> `Unix_domain_socket_dir s | None, None -> try host_or_socket (Sys.getenv "PGHOST") with Not_found -> (* fall back on Unix domain socket. *) `Unix_domain_socket_dir PGOCaml_config.default_unix_domain_socket_dir in (* Get the port number. *) let port = match port with | Some port -> port | None -> try int_of_string (Sys.getenv "PGPORT") with Not_found | Failure _ -> PGOCaml_config.default_port in { user; host; port; database; password } (** We need to convert keys to a human-readable format for error reporting. *) let connection_desc_to_string key = Printf.sprintf "host=%s, port=%s, user=%s, password=%s, database=%s" (match key.host with `Unix_domain_socket_dir _ -> "unix" | `Hostname s -> s) (string_of_int key.port) key.user "*****" (* we don't want to be dumping passwords into error logs *) key.database let connect ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?desc () = let { user; host; port; database; password } = match desc with | None -> describe_connection ?host ?port ?user ?password ?database ?unix_domain_socket_dir () | Some desc -> desc in (* Make the socket address. *) let sockaddrs = match host with | `Hostname hostname -> let addrs = Unix.getaddrinfo hostname (sprintf "%d" port) [Unix.AI_SOCKTYPE(Unix.SOCK_STREAM)] in if addrs = [] then raise (Error ("PGOCaml: unknown host: " ^ hostname)) else List.map (fun {Unix.ai_addr = sockaddr; _} -> sockaddr) addrs | `Unix_domain_socket_dir udsd -> (* Unix domain socket. *) [pgsql_socket udsd port] in (* Create a universally unique identifier for this connection. This * is mainly for debugging and profiling. *) let uuid = (* * On Windows, the result of Unix.getpid is largely meaningless (it's not unique) * and, more importantly, Unix.getppid is not implemented. *) let ppid = try Unix.getppid () with Invalid_argument _ -> 0 in sprintf "%s %d %d %g %s %g" (Unix.gethostname ()) (Unix.getpid ()) ppid (Unix.gettimeofday ()) Sys.executable_name ((Unix.times ()).Unix.tms_utime) in let uuid = Digest.to_hex (Digest.string uuid) in let sock_channels = let rec create_sock_channels sockaddrs = match sockaddrs with [] -> raise (Error ("PGOCaml: Could not connect to database")) | sockaddr :: sockaddrs -> catch (fun () -> open_connection sockaddr) (function | Unix.Unix_error _ -> create_sock_channels sockaddrs | exn -> raise exn) in create_sock_channels sockaddrs in let do_connect () = sock_channels >>= fun (ichan, chan) -> catch (fun () -> (* Create the connection structure. *) let conn = { ichan = ichan; chan = chan; private_data = None; uuid = uuid } in (* Send the StartUpMessage. NB. At present we do not support SSL. *) let msg = new_start_message () in add_int32 msg 196608l; add_string msg "user"; add_string msg user; add_string msg "database"; add_string msg database; add_byte msg 0; (* Loop around here until the database gives a ReadyForQuery message. *) let rec loop msg = (match msg with | Some msg -> send_recv conn msg | None -> receive_message conn) >>= fun msg -> match msg with | ReadyForQuery _ -> return () (* Finished connecting! *) | BackendKeyData _ -> (* XXX We should save this key. *) loop None | AuthenticationOk -> loop None | AuthenticationKerberosV5 -> fail (Error "PGOCaml: Kerberos authentication not supported") | AuthenticationCleartextPassword -> let msg = new_message 'p' in (* PasswordMessage *) add_string msg password; loop (Some msg) | AuthenticationCryptPassword _salt -> (* Crypt password not supported because there is no crypt(3) function * in OCaml. *) fail (Error "PGOCaml: crypt password authentication not supported") | AuthenticationMD5Password salt -> (* (* This is a guess at how the salt is used ... *) let password = salt ^ password in let password = Digest.string password in*) let password = "md5" ^ Digest.to_hex (Digest.string (Digest.to_hex (Digest.string (password ^ user)) ^ salt)) in let msg = new_message 'p' in (* PasswordMessage *) add_string msg password; loop (Some msg) | AuthenticationSCMCredential -> fail (Error "PGOCaml: SCM Credential authentication not supported") | ErrorResponse err -> pg_error err | _ -> (* Silently ignore unknown or unexpected message types. *) loop None in loop (Some msg) >>= fun () -> return conn) (fun e -> close_in ichan >>= fun () -> fail e) in let detail = [ "user"; user; "database"; database; "host"; begin match host with `Unix_domain_socket_dir _ -> "unix" | `Hostname s -> s end; "port"; string_of_int port; "prog"; Sys.executable_name ] in profile_op uuid "connect" detail do_connect let close conn = let do_close () = catch (fun () -> (* Be nice and send the terminate message. *) let msg = new_message 'X' in send_message conn msg >>= fun () -> flush conn.chan >>= fun () -> return None) (fun e -> return (Some e)) >>= fun e -> (* Closes the underlying socket too. *) close_in conn.ichan >>= fun () -> match e with | None -> return () | Some e -> fail e in profile_op conn.uuid "close" [] do_close let set_private_data conn data = conn.private_data <- Some data let private_data { private_data; _ } = match private_data with | None -> raise Not_found | Some private_data -> private_data let uuid conn = conn.uuid type pa_pg_data = (string, bool) Hashtbl.t let ping conn = let do_ping () = sync_msg conn >>= fun () -> (* Wait for ReadyForQuery. *) let rec loop () = receive_message conn >>= fun msg -> match msg with | ReadyForQuery _ -> return () (* Finished! *) | ErrorResponse err -> pg_error ~conn err (* Error *) | _ -> loop () in loop () in profile_op conn.uuid "ping" [] do_ping let alive conn = catch (fun () -> ping conn >>= fun () -> return true) (fun _ -> return false) type oid = int32 [@@deriving show] type param = string option type result = string option type row = result list let prepare conn ~query ?(name = "") ?(types = []) () = let do_prepare () = let msg = new_message 'P' in add_string msg name; add_string msg query; add_int16 msg (List.length types); List.iter (add_int32 msg) types; send_message conn msg >>= fun () -> sync_msg conn >>= fun () -> let rec loop () = receive_message conn >>= fun msg -> match msg with | ErrorResponse err -> pg_error ~conn err | ParseComplete -> loop () | ReadyForQuery _ -> return () (* Finished! *) | _ -> fail (Error ("PGOCaml: unknown response from parse: " ^ string_of_msg_t msg)) in loop () in let details = [ "query"; query; "name"; name ] in profile_op conn.uuid "prepare" details do_prepare let iter_execute conn name portal params proc () = (* Bind *) let msg = new_message 'B' in add_string msg portal; add_string msg name; add_int16 msg 0; (* Send all parameters as text. *) add_int16 msg (List.length params); List.iter ( fun param -> match param with | None -> add_int32 msg 0xffff_ffffl (* NULL *) | Some str -> add_int32 msg (Int32.of_int (String.length str)); add_string_no_trailing_nil msg str ) params; add_int16 msg 0; (* Send back all results as text. *) send_message conn msg >>= fun () -> (* Execute *) let msg = new_message 'E' in add_string msg portal; add_int32 msg 0l; (* no limit on rows *) send_message conn msg >>= fun () -> (* Sync *) sync_msg conn >>= fun () -> (* Process the message(s) received from the database until we read * ReadyForQuery. In the process we may get some rows back from * the database, no data, or an error. *) let rec loop () = (* NB: receive_message flushes the output connection. *) receive_message conn >>= fun msg -> match msg with | ReadyForQuery _ -> return () (* Finished! *) | ErrorResponse err -> pg_error ~conn err (* Error *) | BindComplete -> loop () | CommandComplete _ -> loop () | EmptyQueryResponse -> loop () | DataRow fields -> let fields = List.map ( function | (i, _) when i < 0 -> None (* NULL *) | (0, _) -> Some "" | (_, bytes) -> Some bytes ) fields in proc fields >>= loop | NoData -> loop () | _ -> fail (Error ("PGOCaml: unknown response message: " ^ string_of_msg_t msg)) in loop () let do_execute conn name portal params rev () = let rows = ref [] in iter_execute conn name portal params (fun fields -> return (rows := fields :: !rows)) () >>= fun () -> (* Return the result rows. *) return (if rev then List.rev !rows else !rows) let execute_rev conn ?(name = "") ?(portal = "") ~params () = let do_execute = do_execute conn name portal params false in let details = [ "name"; name; "portal"; portal ] in profile_op conn.uuid "execute" details do_execute let execute conn ?(name = "") ?(portal = "") ~params () = let do_execute = do_execute conn name portal params true in let details = [ "name"; name; "portal"; portal ] in profile_op conn.uuid "execute" details do_execute let cursor conn ?(name = "") ?(portal = "") ~params proc = let do_execute = iter_execute conn name portal params proc in let details = [ "name"; name; "portal"; portal ] in profile_op conn.uuid "cursor" details do_execute let begin_work ?isolation ?access ?deferrable conn = let isolation_str = match isolation with | None -> "" | Some x -> " isolation level " ^ (match x with | `Serializable -> "serializable" | `Repeatable_read -> "repeatable read" | `Read_committed -> "read committed" | `Read_uncommitted -> "read uncommitted") in let access_str = match access with | None -> "" | Some x -> match x with | `Read_write -> " read write" | `Read_only -> " read only" in let deferrable_str = match deferrable with | None -> "" | Some x -> (match x with true -> "" | false -> " not") ^ " deferrable" in let query = "begin work" ^ isolation_str ^ access_str ^ deferrable_str in prepare conn ~query () >>= fun () -> execute conn ~params:[] () >>= fun _ -> return () let commit conn = let query = "commit" in prepare conn ~query () >>= fun () -> execute conn ~params:[] () >>= fun _ -> return () let rollback conn = let query = "rollback" in prepare conn ~query () >>= fun () -> execute conn ~params:[] () >>= fun _ -> return () let transact conn ?isolation ?access ?deferrable f = begin_work ?isolation ?access ?deferrable conn >>= fun () -> catch (fun () -> f conn >>= fun r -> commit conn >>= fun () -> return r ) (fun e -> rollback conn >>= fun () -> fail e ) let serial conn name = let query = "select currval ($1)" in prepare conn ~query () >>= fun () -> execute conn ~params:[Some name] () >>= fun rows -> let row = List.hd rows in let result = List.hd row in (* NB. According to the manual, the return type of currval is * always a bigint, whether or not the column is serial or bigserial. *) return (Int64.of_string (Option.get result)) let serial4 conn name = serial conn name >>= fun s -> return (Int64.to_int32 s) let serial8 = serial let close_statement conn ?(name = "") () = let msg = new_message 'C' in add_char msg 'S'; add_string msg name; send_message conn msg >>= fun () -> sync_msg conn >>= fun () -> let rec loop () = receive_message conn >>= fun msg -> match msg with | ErrorResponse err -> pg_error ~conn err | CloseComplete -> loop () | ReadyForQuery _ -> return () (* Finished! *) | _ -> fail (Error ("PGOCaml: unknown response from close: " ^ string_of_msg_t msg)) in loop () let close_portal conn ?(portal = "") () = let msg = new_message 'C' in add_char msg 'P'; add_string msg portal; send_message conn msg >>= fun () -> sync_msg conn >>= fun () -> let rec loop () = receive_message conn >>= fun msg -> match msg with | ErrorResponse err -> pg_error ~conn err | CloseComplete -> loop () | ReadyForQuery _ -> return () (* Finished! *) | _ -> fail (Error ("PGOCaml: unknown response from close: " ^ string_of_msg_t msg)) in loop () let inject db ?name query = prepare db ~query ?name () >>= fun () -> execute db ?name ~params:[] () >>= fun ret -> close_statement db ?name () >>= fun () -> return ret let alter db ?name query = inject db ?name query >>= fun _ -> return () type result_description = { name : string; table : oid option; column : int option; field_type : oid; length : int; modifier : int32; }[@@deriving show] type row_description = result_description list [@@deriving show] type param_description = { param_type : oid; } type params_description = param_description list let expect_rfq conn ret = receive_message conn >>= fun msg -> match msg with | ReadyForQuery _ -> return ret | msg -> fail @@ Error ("PGOCaml: unknown response from describe: " ^ string_of_msg_t msg) let describe_statement conn ?(name = "") () = let msg = new_message 'D' in add_char msg 'S'; add_string msg name; send_message conn msg >>= fun () -> sync_msg conn >>= fun () -> receive_message conn >>= fun msg -> ( match msg with | ErrorResponse err -> pg_error ~conn err | ParameterDescription params -> let params = List.map ( fun oid -> { param_type = oid } ) params in return params | _ -> fail (Error ("PGOCaml: unknown response from describe: " ^ string_of_msg_t msg))) >>= fun params -> receive_message conn >>= fun msg -> ( match msg with | ErrorResponse err -> pg_error ~conn err | NoData -> return (params, None) | RowDescription fields -> let fields = List.map ( fun (name, table, column, oid, length, modifier, _) -> { name = name; table = if table = 0l then None else Some table; column = if column = 0 then None else Some column; field_type = oid; length = length; modifier = modifier; } ) fields in return (params, Some fields) | _ -> fail (Error ("PGOCaml: unknown response from describe: " ^ string_of_msg_t msg))) >>= expect_rfq conn let describe_portal conn ?(portal = "") () = let msg = new_message 'D' in add_char msg 'P'; add_string msg portal; send_message conn msg >>= fun () -> sync_msg conn >>= fun () -> receive_message conn >>= fun msg -> ( match msg with | ErrorResponse err -> pg_error ~conn err | NoData -> return None | RowDescription fields -> let fields = List.map ( fun (name, table, column, oid, length, modifier, _) -> { name = name; table = if table = 0l then None else Some table; column = if column = 0 then None else Some column; field_type = oid; length = length; modifier = modifier; } ) fields in return (Some fields) | _ -> fail (Error ("PGOCaml: unknown response from describe: " ^ string_of_msg_t msg))) >>= expect_rfq conn (*----- Type conversion. -----*) (* For certain types, more information is available by looking * at the modifier field as well as just the OID. For example, * for NUMERIC the modifier tells us the precision. * However we don't always have the modifier field available - * in particular for parameters. *) let name_of_type = function | 16_l -> "bool" (* BOOLEAN *) | 17_l -> "bytea" (* BYTEA *) | 20_l -> "int64" (* INT8 *) | 21_l -> "int16" (* INT2 *) | 23_l -> "int32" (* INT4 *) | 25_l -> "string" (* TEXT *) | 114_l -> "string" (* JSON *) | 119_l -> "string_array" (* JSON[] *) | 600_l -> "point" (* POINT *) | 700_l | 701_l -> "float" (* FLOAT4, FLOAT8 *) | 869_l -> "inet" (* INET *) | 1000_l -> "bool_array" (* BOOLEAN[] *) | 1005_l -> "int16_array" (* INT2[] *) | 1001_l -> "bytea_array" (* BYTEA[] *) | 1007_l -> "int32_array" (* INT4[] *) | 1009_l -> "string_array" (* TEXT[] *) | 1014_l -> "string_array" (* CHAR[] *) | 1015_l -> "string_array" (* VARCHAR[] *) | 1016_l -> "int64_array" (* INT8[] *) | 1021_l | 1022_l -> "float_array" (* FLOAT4[], FLOAT8[] *) | 1042_l -> "string" (* CHAR(n) - treat as string *) | 1043_l -> "string" (* VARCHAR(n) - treat as string *) | 1082_l -> "date" (* DATE *) | 1083_l -> "time" (* TIME *) | 1114_l -> "timestamp" (* TIMESTAMP *) | 1115_l -> "timestamp_array" (* TIMESTAMP[] *) | 1184_l -> "timestamptz" (* TIMESTAMP WITH TIME ZONE *) | 1186_l -> "interval" (* INTERVAL *) | 2278_l -> "unit" (* VOID *) | 1700_l -> "string" (* NUMERIC *) | 2950_l -> "uuid" (* UUID *) | 2951_l -> "uuid_array" (* UUID[] *) | 3802_l -> "string" (* JSONB *) | 3807_l -> "string_array" (* JSONB[] *) | i -> (* For unknown types, look at . *) raise (Error ("PGOCaml: unknown type for OID " ^ Int32.to_string i)) type inet = Unix.inet_addr * int type timestamptz = Calendar.t * Time_Zone.t type int16 = int type bytea = string type point = float * float type hstore = (string * string option) list type numeric = string type uuid = string type jsonb = string type bool_array = bool option list type int16_array = int16 option list type int32_array = int32 option list type int64_array = int64 option list type string_array = string option list type float_array = float option list type timestamp_array = Calendar.t option list type uuid_array = uuid option list let string_of_hstore hstore = let string_of_quoted str = "\"" ^ str ^ "\"" in let string_of_mapping (key, value) = let key_str = string_of_quoted key in let value_str = match value with | Some v -> string_of_quoted v | None -> "NULL" in key_str ^ "=>" ^ value_str in String.join ", " (List.map string_of_mapping hstore) let string_of_numeric (x : string) = x let string_of_uuid (x : string) = x let string_of_jsonb (x : string) = x let string_of_inet (addr, mask) = let hostmask = if Unix.domain_of_sockaddr (Unix.ADDR_INET(addr, 1)) = Unix.PF_INET6 then 128 else 32 in let addr = Unix.string_of_inet_addr addr in if mask = hostmask then addr else if mask >= 0 && mask < hostmask then addr ^ "/" ^ string_of_int mask else failwith "string_of_inet" let string_of_oid = Int32.to_string let string_of_bool = function | true -> "t" | false -> "f" let string_of_int = Stdlib.string_of_int let string_of_int16 = Stdlib.string_of_int let string_of_int32 = Int32.to_string let string_of_int64 = Int64.to_string let string_of_float = string_of_float let string_of_point (x, y) = "(" ^ (string_of_float x) ^ "," ^ (string_of_float y) ^ ")" let string_of_timestamp = Printer.Calendar.to_string let string_of_timestamptz (cal, tz) = Printer.Calendar.to_string cal ^ match tz with | Time_Zone.UTC -> "+00" | Time_Zone.Local -> let gap = Time_Zone.gap Time_Zone.UTC Time_Zone.Local in if gap >= 0 then sprintf "+%02d" gap else sprintf "-%02d" (-gap) | Time_Zone.UTC_Plus gap -> if gap >= 0 then sprintf "+%02d" gap else sprintf "-%02d" (-gap) let string_of_date = Printer.Date.to_string let string_of_time = Printer.Time.to_string let string_of_interval p = let y, m, d, s = Calendar.Period.ymds p in sprintf "%d years %d mons %d days %d seconds" y m d s let string_of_unit () = "" (* NB. It is the responsibility of the caller of this function to * properly escape array elements. *) let string_of_any_array xs = let buf = Buffer.create 128 in Buffer.add_char buf '{'; let adder i x = if i > 0 then Buffer.add_char buf ','; match x with | Some x -> Buffer.add_char buf '"'; Buffer.add_string buf x; Buffer.add_char buf '"' | None -> Buffer.add_string buf "NULL" in List.iteri adder xs; Buffer.add_char buf '}'; Buffer.contents buf let option_map f = function | Some x -> Some (f x) | None -> None let escape_string str = let buf = Buffer.create 128 in for i = 0 to String.length str - 1 do match str.[i] with | '"' | '\\' as x -> Buffer.add_char buf '\\'; Buffer.add_char buf x | x -> Buffer.add_char buf x done; Buffer.contents buf let string_of_bool_array a = string_of_any_array (List.map (option_map string_of_bool) a) let string_of_int16_array a = string_of_any_array (List.map (option_map Stdlib.string_of_int) a) let string_of_int32_array a = string_of_any_array (List.map (option_map Int32.to_string) a) let string_of_int64_array a = string_of_any_array (List.map (option_map Int64.to_string) a) let string_of_string_array a = string_of_any_array (List.map (option_map escape_string) a) let string_of_float_array a = string_of_any_array (List.map (option_map string_of_float) a) let string_of_timestamp_array a = string_of_any_array (List.map (option_map string_of_timestamp) a) let string_of_arbitrary_array f a = string_of_any_array (List.map (option_map f) a) let string_of_uuid_array a = string_of_any_array (List.map (option_map escape_string) a) let comment_src_loc () = match Sys.getenv_opt "PGCOMMENT_SRC_LOC" with | Some x -> begin match x with | "yes" | "1" | "on" -> true | "no" | "0" | "off" -> false | _ -> failwith (Printf.sprintf "Unrecognized option for 'PGCOMMENT_SRC_LOC': %s" x) end | None -> PGOCaml_config.default_comment_src_loc open Sexplib.Std type custom_rule_payload = { serialize: string ; deserialize: string } [@@deriving sexp] type custom_rule_spec = | Typnam of string | Colnam of string | Argnam of string [@@deriving sexp] type rule_logic = | And of rule_logic list | Or of rule_logic list | Rule of custom_rule_spec | True | False [@@deriving sexp] let rec eval_rule_spec ?typnam ?colnam ?argnam logic = match logic with | True -> true | False -> false | Rule (Typnam s) -> Option.(map ((=) s) typnam |> default false) | Rule (Colnam s) -> Option.(map ((=) s) colnam |> default false) | Rule (Argnam s) -> Option.(map ((=) s) argnam |> default false) | And logics -> let[@warning "-8"] (hd :: tl) = List.map (eval_rule_spec ?typnam ?colnam ?argnam) logics in List.fold_left (fun acc x -> acc && x) hd tl | Or logics -> let[@warning "-8"] (hd :: tl) = List.map (eval_rule_spec ?typnam ?colnam ?argnam) logics in List.fold_left (fun acc x -> acc || x) hd tl type custom_rule = rule_logic * custom_rule_payload [@@deriving sexp] type custom_rules_conf = custom_rule list [@@deriving sexp] let find_custom_typconvs = let open Rresult in let loadconvs fname = try Ok (Sexplib.Sexp.load_sexp_conv_exn fname custom_rules_conf_of_sexp) with | exn -> let cwd = Unix.getcwd () in Error ( Printf.sprintf "Error parsing custom typeconvs file in %s: %s" cwd (Printexc.to_string exn)) in let default_custom_converters = match Sys.getenv_opt "PGCUSTOM_CONVERTERS_CONFIG" with | None -> Ok [] | Some f -> loadconvs f in fun ?typnam ?lookin ?colnam ?argnam () -> begin match lookin with | Some x -> (*let _ = failwith ("Kill me now " ^ x) in*) let convs = loadconvs x in begin match convs with | Ok x -> Ok x | Error e -> Error e end (*>>= fun blep -> Error (Printf.sprintf "Got %d converters" (List.length @@ blep))*) | None -> default_custom_converters end >>= fun custom_converters -> begin try Ok( List.filter (fun (logic, _) -> eval_rule_spec ?typnam ?colnam ?argnam logic) custom_converters) with | Failure e -> failwith e end >>= fun res -> match res with | _ :: _ :: _ -> Error "Converter collision" | [] -> Ok None | [_rulespec, v] -> Ok (Some (v.serialize, v.deserialize)) let string_of_bytea b = let `Hex b_hex = Hex.of_string b in "\\x" ^ b_hex let string_of_bytea_array a = string_of_any_array (List.map (option_map string_of_bytea) a) let string_of_string (x : string) = x let oid_of_string = Int32.of_string let bool_of_string = function | "true" | "t" -> true | "false" | "f" -> false | str -> raise (Error ("PGOCaml: not a boolean: " ^ str)) let int_of_string = Stdlib.int_of_string let int16_of_string = Stdlib.int_of_string let int32_of_string = Int32.of_string let int64_of_string = Int64.of_string let float_of_string = float_of_string let hstore_of_string str = let expect target stream = if List.exists (fun c -> c <> Stream.next stream) target then raise (Error ("PGOCaml: unexpected input in hstore_of_string")) in let parse_quoted stream = let rec loop accum stream = match Stream.next stream with | '"' -> String.implode (List.rev accum) | '\\' -> loop (Stream.next stream :: accum) stream | x -> loop (x :: accum) stream in expect ['"'] stream; loop [] stream in let parse_value stream = match Stream.peek stream with | Some 'N' -> (expect ['N'; 'U'; 'L'; 'L'] stream; None) | _ -> Some (parse_quoted stream) in let parse_mapping stream = let key = parse_quoted stream in expect ['='; '>'] stream; let value = parse_value stream in (key, value) in let parse_main stream = let rec loop accum stream = let mapping = parse_mapping stream in match Stream.peek stream with | Some _ -> (expect [','; ' '] stream; loop (mapping :: accum) stream) | None -> mapping :: accum in match Stream.peek stream with | Some _ -> loop [] stream | None -> [] in parse_main (Stream.of_string str) let numeric_of_string (x : string) = x let uuid_of_string (x : string) = x let jsonb_of_string (x : string) = x let inet_of_string = let re = let open Re in [ group ( [ rep (compl [set ":./"]) ; group (set ":.") ; rep1 (compl [char '/']) ] |> seq ) ; opt (seq [char '/'; group (rep1 any)]) ] |> seq |> compile in fun str -> let subs = Re.exec re str in let addr = Unix.inet_addr_of_string (Re.Group.get subs 1) in let mask = try (Re.Group.get subs 3) with Not_found -> "" in (* optional match *) if mask = "" then (addr, (if (Re.Group.get subs 2) = "." then 32 else 128)) else (addr, int_of_string mask) let point_of_string = let point_re = let open Re in let space p = let space = rep (set " \t") in seq [ space ; p ; space ] in let sign = opt (set "+-") in let num = seq [ sign ; rep1 digit ; opt (char '.') ; rep digit ; opt (seq [ set "Ee"; set "+-"; rep1 digit ]) ] in let nan = seq [ set "Nn"; char 'a'; set "Nn" ] in let inf = seq [ sign ; set "Ii" ; str "nfinity" ] in let float_pat = Re.alt [num ; nan ; inf ] in [ char '(' ; space (group float_pat) ; char ',' ; space (group float_pat) ; char ')' ] |> seq |> compile in fun str -> try let subs = Re.exec point_re str in (float_of_string (Re.Group.get subs 1), float_of_string (Re.Group.get subs 2)) with | _ -> failwith "point_of_string" let date_of_string = Printer.Date.from_string let time_of_string str = (* Remove trailing ".microsecs" if present. *) let n = String.length str in let str = if n > 8 && str.[8] = '.' then String.sub str 0 8 else str in Printer.Time.from_string str let timestamp_of_string str = (* Remove trailing ".microsecs" if present. *) let n = String.length str in let str = if n > 19 && str.[19] = '.' then String.sub str 0 19 else str in Printer.Calendar.from_string str let timestamptz_of_string str = (* Split into datetime+timestamp. *) let n = String.length str in let cal, tz = if n >= 3 && (str.[n-3] = '+' || str.[n-3] = '-') then String.sub str 0 (n-3), Some (String.sub str (n-3) 3) else str, None in let cal = timestamp_of_string cal in let tz = match tz with | None -> Time_Zone.Local (* best guess? *) | Some tz -> let sgn = match tz.[0] with '+' -> 1 | '-' -> -1 | _ -> assert false in let mag = int_of_string (String.sub tz 1 2) in Time_Zone.UTC_Plus (sgn * mag) in cal, tz let re_interval = let open Re in let time_period unit_name = [ group (rep1 digit) ; space ; str unit_name ; opt (char 's') ] |> seq |> opt in let digit2 = [digit ; digit ] |> seq |> group in let time = seq [digit2 ; char ':' ; digit2 ; opt (seq [char ':' ; digit2]) ] in [ opt (time_period "year") ; rep space ; opt (time_period "mon") ; rep space ; opt (time_period "day") ; rep space ; opt time ] |> seq |> compile let interval_of_string = let int_opt subs i = try int_of_string (Re.Group.get subs i) with | Not_found -> 0 in fun str -> try let sub = Re.exec re_interval str in Calendar.Period.make (int_opt sub 1) (* year *) (int_opt sub 2) (* month *) (int_opt sub 3) (* day *) (int_opt sub 4) (* hour *) (int_opt sub 5) (* min *) (int_opt sub 6) (* sec *) with Not_found -> failwith ("interval_of_string: bad interval: " ^ str) let unit_of_string _ = () (* NB. This function also takes care of unescaping returned elements. *) let any_array_of_string str = let n = String.length str in assert (str.[0] = '{'); assert (str.[n-1] = '}'); let str = String.sub str 1 (n-2) in let buf = Buffer.create 128 in let add_field accum = let x = Buffer.contents buf in Buffer.clear buf; let field = if x = "NULL" then None else let n = String.length x in if n >= 2 && x.[0] = '"' then Some (String.sub x 1 (n-2)) else Some x in field :: accum in let loop (accum, quoted, escaped) = function | '\\' when not escaped -> (accum, quoted, true) | '"' when not escaped -> Buffer.add_char buf '"'; (accum, not quoted, false) | ',' when not escaped && not quoted -> (add_field accum, false, false) | x -> Buffer.add_char buf x; (accum, quoted, false) in let (accum, _, _) = String.fold_left loop ([], false, false) str in let accum = if Buffer.length buf = 0 then accum else add_field accum in List.rev accum let bool_array_of_string str = List.map (option_map bool_of_string) (any_array_of_string str) let int16_array_of_string str = List.map (option_map Stdlib.int_of_string) (any_array_of_string str) let int32_array_of_string str = List.map (option_map Int32.of_string) (any_array_of_string str) let int64_array_of_string str = List.map (option_map Int64.of_string) (any_array_of_string str) let string_array_of_string str = any_array_of_string str let float_array_of_string str = List.map (option_map float_of_string) (any_array_of_string str) let timestamp_array_of_string str = List.map (option_map timestamp_of_string) (any_array_of_string str) let arbitrary_array_of_string f str = List.map (option_map f) (any_array_of_string str) let is_first_oct_digit c = c >= '0' && c <= '3' let is_oct_digit c = c >= '0' && c <= '7' let oct_val c = Char.code c - 0x30 let is_hex_digit = function '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false let hex_val c = let offset = match c with | '0'..'9' -> 0x30 | 'a'..'f' -> 0x57 | 'A'..'F' -> 0x37 | _ -> failwith "hex_val" in Char.code c - offset (* Deserialiser for the new 'hex' format introduced in PostgreSQL 9.0. *) let bytea_of_string_hex str = let len = String.length str in let buf = Buffer.create ((len-2)/2) in let i = ref 3 in while !i < len do let hi_nibble = str.[!i-1] in let lo_nibble = str.[!i] in i := !i+2; if is_hex_digit hi_nibble && is_hex_digit lo_nibble then begin let byte = ((hex_val hi_nibble) lsl 4) + (hex_val lo_nibble) in Buffer.add_char buf (Char.chr byte) end done; Buffer.contents buf (* Deserialiser for the old 'escape' format used in PostgreSQL < 9.0. *) let bytea_of_string_escape str = let len = String.length str in let buf = Buffer.create len in let i = ref 0 in while !i < len do let c = str.[!i] in if c = '\\' then ( incr i; if !i < len && str.[!i] = '\\' then ( Buffer.add_char buf '\\'; incr i ) else if !i+2 < len && is_first_oct_digit str.[!i] && is_oct_digit str.[!i+1] && is_oct_digit str.[!i+2] then ( let byte = oct_val str.[!i] in incr i; let byte = (byte lsl 3) + oct_val str.[!i] in incr i; let byte = (byte lsl 3) + oct_val str.[!i] in incr i; Buffer.add_char buf (Char.chr byte) ) ) else ( incr i; Buffer.add_char buf c ) done; Buffer.contents buf (* PostgreSQL 9.0 introduced the new 'hex' format for binary data. We must therefore check whether the data begins with a magic sequence that identifies this new format and if so call the appropriate parser; if it doesn't, then we invoke the parser for the old 'escape' format. *) let bytea_of_string str = if String.starts_with str "\\x" then bytea_of_string_hex str else bytea_of_string_escape str let bind = (>>=) let return = Thread.return end pgocaml-4.4.0/src/PGOCaml_generic.mli000066400000000000000000000333071450353127600173650ustar00rootroot00000000000000(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. * * PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2009 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) (** Type-safe access to PostgreSQL databases. *) open CalendarLib module type THREAD = sig type 'a t val return : 'a -> 'a t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val fail : exn -> 'a t val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t type in_channel type out_channel val open_connection : Unix.sockaddr -> (in_channel * out_channel) t val output_char : out_channel -> char -> unit t val output_binary_int : out_channel -> int -> unit t val output_string : out_channel -> string -> unit t val flush : out_channel -> unit t val input_char : in_channel -> char t val input_binary_int : in_channel -> int t val really_input : in_channel -> Bytes.t -> int -> int -> unit t val close_in : in_channel -> unit t end module type PGOCAML_GENERIC = sig type 'a t (** Database handle. *) type 'a monad type isolation = [ `Serializable | `Repeatable_read | `Read_committed | `Read_uncommitted ] type access = [ `Read_write | `Read_only ] exception Error of string (** For library errors. *) exception PostgreSQL_Error of string * (char * string) list (** For errors generated by the PostgreSQL database back-end. The first argument is a printable error message. The second argument is the complete set of error fields returned from the back-end. See [http://www.postgresql.org/docs/8.1/static/protocol-error-fields.html] *) (** {6 Connection management} *) type connection_desc = { user: string; port: int; password: string; host: [ `Hostname of string | `Unix_domain_socket_dir of string]; database: string } val describe_connection : ?host:string -> ?port:int -> ?user:string -> ?password:string -> ?database:string -> ?unix_domain_socket_dir:string -> unit -> connection_desc (** Produce the actual, concrete connection parameters based on the values and * availability of the various configuration variables. *) val connection_desc_to_string : connection_desc -> string (** Produce a human-readable textual representation of a concrete connection * descriptor (the password is NOT included in the output of this function) * for logging and error reporting purposes. *) val connect : ?host:string -> ?port:int -> ?user:string -> ?password:string -> ?database:string -> ?unix_domain_socket_dir:string -> ?desc:connection_desc -> unit -> 'a t monad (** Connect to the database. The normal [$PGDATABASE], etc. environment variables are available. *) val close : 'a t -> unit monad (** Close the database handle. You must call this after you have finished with the handle, or else you will get leaked file descriptors. *) val ping : 'a t -> unit monad (** Ping the database. If the database is not available, some sort of exception will be thrown. *) val alive : 'a t -> bool monad (** This function is a wrapper of [ping] that returns a boolean instead of raising an exception. *) (** {6 Transactions} *) val begin_work : ?isolation:isolation -> ?access:access -> ?deferrable:bool -> 'a t -> unit monad (** Start a transaction. *) val commit : 'a t -> unit monad (** Perform a COMMIT operation on the database. *) val rollback : 'a t -> unit monad (** Perform a ROLLBACK operation on the database. *) val transact : 'a t -> ?isolation:isolation -> ?access:access -> ?deferrable:bool -> ('a t -> 'b monad) -> 'b monad (** [transact db ?isolation ?access ?deferrable f] wraps your function [f] inside a transactional block. First it calls [begin_work] with [isolation], [access] and [deferrable], then calls [f] and do [rollback] if [f] raises an exception, [commit] otherwise. *) (** {6 Serial column} *) val serial : 'a t -> string -> int64 monad (** This is a shorthand for [SELECT CURRVAL(serial)]. For a table called [table] with serial column [id] you would typically call this as [serial dbh "table_id_seq"] after the previous INSERT operation to get the serial number of the inserted row. *) val serial4 : 'a t -> string -> int32 monad (** As {!serial} but assumes that the column is a SERIAL or SERIAL4 type. *) val serial8 : 'a t -> string -> int64 monad (** Same as {!serial}. *) (** {6 Miscellaneous} *) val max_message_length : int ref (** Maximum message length accepted from the back-end. The default is [Sys.max_string_length], which means that we will try to read as much data from the back-end as we can, and this may cause us to run out of memory (particularly on 64 bit machines), causing a possible denial of service. You may want to set this to a smaller size to avoid this happening. *) val verbose : int ref (** Verbosity. 0 means don't print anything. 1 means print short error messages as returned from the back-end. 2 means print all messages as returned from the back-end. Messages are printed on [stderr]. Default verbosity level is 1. *) val set_private_data : 'a t -> 'a -> unit (** Attach some private data to the database handle. NB. The pa_pgsql camlp4 extension uses this for its own purposes, which means that in most programs you will not be able to attach private data to the database handle. *) val private_data : 'a t -> 'a (** Retrieve some private data previously attached to the database handle. If no data has been attached, raises [Not_found]. NB. The pa_pgsql camlp4 extension uses this for its own purposes, which means that in most programs you will not be able to attach private data to the database handle. *) val uuid : 'a t -> string (** Retrieve the unique identifier for this connection. *) type pa_pg_data = (string, bool) Hashtbl.t (** When using pa_pgsql, database handles have type [PGOCaml.pa_pg_data PGOCaml.t] *) (** {6 Low level query interface - DO NOT USE DIRECTLY} *) type oid = int32 [@@deriving show] type param = string option (* None is NULL. *) type result = string option (* None is NULL. *) type row = result list (* One row is a list of fields. *) val prepare : 'a t -> query:string -> ?name:string -> ?types:oid list -> unit -> unit monad (** [prepare conn ~query ?name ?types ()] prepares the statement [query] and optionally names it [name] and sets the parameter types to [types]. If no name is given, then the "unnamed" statement is overwritten. If no types are given, then the PostgreSQL engine infers types. Synchronously checks for errors. *) val execute_rev : 'a t -> ?name:string -> ?portal:string -> params:param list -> unit -> row list monad val execute : 'a t -> ?name:string -> ?portal:string -> params:param list -> unit -> row list monad (** [execute conn ?name ~params ()] executes the named or unnamed statement [name], with the given parameters [params], returning the result rows (if any). There are several steps involved at the protocol layer: (1) a "portal" is created from the statement, binding the parameters in the statement (Bind). (2) the portal is executed (Execute). (3) we synchronise the connection (Sync). The optional [?portal] parameter may be used to name the portal created in step (1) above (otherwise the unnamed portal is used). This is only important if you want to call {!describe_portal} to find out the result types. *) val cursor : 'a t -> ?name:string -> ?portal:string -> params:param list -> (row -> unit monad) -> unit monad val close_statement : 'a t -> ?name:string -> unit -> unit monad (** [close_statement conn ?name ()] closes a prepared statement and frees up any resources. *) val close_portal : 'a t -> ?portal:string -> unit -> unit monad (** [close_portal conn ?portal ()] closes a portal and frees up any resources. *) val inject : 'a t -> ?name:string -> string -> row list monad (** [inject conn ?name query] executes the statement [query] and optionally names it [name] and gives the result. *) val alter : 'a t -> ?name:string -> string -> unit monad (** [alter conn ?name query] executes the statement [query] and optionally names it [name]. Same as inject but ignoring the result. *) type result_description = { name : string; (** Field name. *) table : oid option; (** OID of table. *) column : int option; (** Column number of field in table. *) field_type : oid; (** The type of the field. *) length : int; (** Length of the field. *) modifier : int32; (** Type modifier. *) }[@@deriving show] type row_description = result_description list [@@deriving show] type params_description = param_description list and param_description = { param_type : oid; (** The type of the parameter. *) } val describe_statement : 'a t -> ?name:string -> unit -> (params_description * row_description option) monad (** [describe_statement conn ?name ()] describes the named or unnamed statement's parameter types and result types. *) val describe_portal : 'a t -> ?portal:string -> unit -> row_description option monad (** [describe_portal conn ?portal ()] describes the named or unnamed portal's result types. *) (** {6 Low level type conversion functions - DO NOT USE DIRECTLY} *) val name_of_type : oid -> string (** Returns the OCaml equivalent type name to the PostgreSQL type [oid]. For instance, [name_of_type (Int32.of_int 23)] returns ["int32"] because the OID for PostgreSQL's internal [int4] type is [23]. As another example, [name_of_type (Int32.of_int 25)] returns ["string"]. *) type inet = Unix.inet_addr * int type timestamptz = Calendar.t * Time_Zone.t type int16 = int type bytea = string (* XXX *) type point = float * float type hstore = (string * string option) list type numeric = string type uuid = string type jsonb = string type bool_array = bool option list type int16_array = int16 option list type int32_array = int32 option list type int64_array = int64 option list type string_array = string option list type float_array = float option list type timestamp_array = Calendar.t option list type uuid_array = string option list (** The following conversion functions are used by pa_pgsql to convert values in and out of the database. *) val string_of_oid : oid -> string val string_of_bool : bool -> string val string_of_int : int -> string val string_of_int16 : int16 -> string val string_of_int32 : int32 -> string val string_of_int64 : int64 -> string val string_of_float : float -> string val string_of_point : point -> string val string_of_hstore : hstore -> string val string_of_numeric : numeric -> string val string_of_uuid : uuid -> string val string_of_jsonb : jsonb -> string val string_of_inet : inet -> string val string_of_timestamp : Calendar.t -> string val string_of_timestamptz : timestamptz -> string val string_of_date : Date.t -> string val string_of_time : Time.t -> string val string_of_interval : Calendar.Period.t -> string val string_of_bytea : bytea -> string val string_of_string : string -> string val string_of_unit : unit -> string val string_of_bool_array : bool_array -> string val string_of_int16_array : int16_array -> string val string_of_int32_array : int32_array -> string val string_of_int64_array : int64_array -> string val string_of_string_array : string_array -> string val string_of_bytea_array : string_array -> string val string_of_float_array : float_array -> string val string_of_timestamp_array : timestamp_array -> string val string_of_arbitrary_array : ('a -> string) -> 'a option list -> string val string_of_uuid_array : uuid_array -> string val comment_src_loc : unit -> bool val find_custom_typconvs : ?typnam:string -> ?lookin:string -> ?colnam:string -> ?argnam:string -> unit -> ((string * string) option, string) Rresult.result val oid_of_string : string -> oid val bool_of_string : string -> bool val int_of_string : string -> int val int16_of_string : string -> int16 val int32_of_string : string -> int32 val int64_of_string : string -> int64 val float_of_string : string -> float val point_of_string : string -> point val hstore_of_string : string -> hstore val numeric_of_string : string -> numeric val uuid_of_string : string -> uuid val jsonb_of_string : string -> jsonb val inet_of_string : string -> inet val timestamp_of_string : string -> Calendar.t val timestamptz_of_string : string -> timestamptz val date_of_string : string -> Date.t val time_of_string : string -> Time.t val interval_of_string : string -> Calendar.Period.t val bytea_of_string : string -> bytea val unit_of_string : string -> unit val bool_array_of_string : string -> bool_array val int16_array_of_string : string -> int16_array val int32_array_of_string : string -> int32_array val int64_array_of_string : string -> int64_array val string_array_of_string : string -> string_array val float_array_of_string : string -> float_array val timestamp_array_of_string : string -> timestamp_array val arbitrary_array_of_string : (string -> 'a) -> string -> 'a option list val bind : 'a monad -> ('a -> 'b monad) -> 'b monad val return : 'a -> 'a monad end module Make : functor (Thread : THREAD) -> PGOCAML_GENERIC with type 'a monad = 'a Thread.t pgocaml-4.4.0/src/dune000066400000000000000000000012471450353127600146200ustar00rootroot00000000000000;(rule ; (targets PGOCaml_config.ml) ; (deps PGOCaml_config.ml.in) ; (action ; (with-stdout-to PGOCaml_config.ml (run ./genconfig.sh)))) (executable (name PGOCaml_genconfig) (preprocess (pps ppx_sexp_conv ppx_deriving.show)) (modules PGOCaml_genconfig)) (rule (targets PGOCaml_config.ml) (deps PGOCaml_genconfig.exe) (action (with-stdout-to PGOCaml_config.ml (run ./PGOCaml_genconfig.exe)))) (library (name PGOCaml) (public_name pgocaml) (libraries calendar csv hex re rresult sexplib unix camlp-streams) (preprocess (pps ppx_sexp_conv ppx_deriving.show)) (wrapped false) (modules PGOCaml_aux PGOCaml PGOCaml_generic PGOCaml_config)) pgocaml-4.4.0/src/pgocaml.mldylib000066400000000000000000000002071450353127600167350ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: da5a8c724b284262dc76d857dc1e81b6) PGOCaml_aux PGOCaml PGOCaml_generic PGOCaml_config # OASIS_STOP pgocaml-4.4.0/src/pgocaml.mllib000066400000000000000000000002071450353127600164000ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: da5a8c724b284262dc76d857dc1e81b6) PGOCaml_aux PGOCaml PGOCaml_generic PGOCaml_config # OASIS_STOP pgocaml-4.4.0/tests/000077500000000000000000000000001450353127600143115ustar00rootroot00000000000000pgocaml-4.4.0/tests/test_pgocaml_highlevel.ml000066400000000000000000000037171450353127600213630ustar00rootroot00000000000000(* Example program using typesafe calls to PostgreSQL. * * PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2009 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) open Printf let () = let dbh = PGOCaml.connect () in let () = PGSQL(dbh) "execute" "create temporary table employees ( id serial not null primary key, name text not null, salary int4 not null, email text )" in let insert name salary email = PGSQL(dbh) "insert into employees (name, salary, email) values ($name, $salary, $?email)" in insert "Ann" 10_000_l None; insert "Bob" 45_000_l None; insert "Jim" 20_000_l None; insert "Mary" 30_000_l (Some "mary@example.com"); let rows = PGSQL(dbh) "select id, name, salary, email from employees" in List.iter begin fun (id, name, salary, email) -> let email = match email with Some email -> email | None -> "-" in printf "%ld %S %ld %S\n" id name salary email end rows; let ids = [ 1_l; 3_l ] in let rows = PGSQL(dbh) "select id, name, salary, email from employees where id in $@ids" in List.iter begin fun (id, name, salary, email) -> let email = match email with Some email -> email | None -> "-" in printf "%ld %S %ld %S\n" id name salary email end rows; PGOCaml.close dbh pgocaml-4.4.0/tests/test_pgocaml_lowlevel.ml000066400000000000000000000076651450353127600212530ustar00rootroot00000000000000(* Test the lowlevel interface to the database. * Assumes that $PGHOST, etc. are set to point to a database. * * PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2009 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) open Printf let print_row i row = printf "row %d: [%s]\n" i (String.concat "; " (List.map (function | None -> "NULL" | Some str -> sprintf "%S" str) row)) let print_rows rows = List.iteri print_row rows let print_params_description params = printf "params:\n"; List.iteri ( fun i param -> printf " parameter %d:\n" i; printf " type: %ld\n" param.PGOCaml.param_type ) params let print_row_description results = match results with | None -> printf "this statement returns no data\n" | Some results -> printf "results:\n"; List.iteri ( fun i result -> printf " field %d:\n" i; printf " name: %s\n" result.PGOCaml.name; printf " type: %ld\n" result.PGOCaml.field_type ) results let () = let dbh = PGOCaml.connect () in (* Simple query with no parameters. *) let query = "select current_timestamp" in let name = "timestamp_query" in ignore (PGOCaml.prepare dbh ~query ~name ()); let i = ref 0 in PGOCaml.cursor dbh ~name ~params:[] (fun row -> incr i; print_row !i row); (* Describe the statement. *) let params, results = PGOCaml.describe_statement dbh ~name () in print_params_description params; print_row_description results; (* A query with parameters. *) let query = "select $1 + $2" in let types = [ 23l; 23l ] in (* 23 = int4 *) let name = "sum_query" in ignore (PGOCaml.prepare dbh ~query ~name ~types ()); let i = ref 0 in PGOCaml.cursor dbh ~name ~params:[Some "1"; Some "2"] (fun row -> incr i; print_row !i row); (* Describe the statement. *) let params, results = PGOCaml.describe_statement dbh ~name () in print_params_description params; print_row_description results; (* Create a temporary table and populate it. *) let query = "create temporary table employees ( id serial not null primary key, name text not null, salary numeric(8,2) not null, email text )" in ignore (PGOCaml.prepare dbh ~query ()); ignore (PGOCaml.execute dbh ~params:[] ()); let query = "insert into employees (name, salary, email) values ($1, $2, $3)" in ignore (PGOCaml.prepare dbh ~query ()); let params, results = PGOCaml.describe_statement dbh () in print_params_description params; print_row_description results; ignore (PGOCaml.execute dbh ~params:[Some "Ann"; Some "10000.00"; None] ()); ignore (PGOCaml.execute dbh ~params:[Some "Bob"; Some "45000.00"; None] ()); ignore (PGOCaml.execute dbh ~params:[Some "Jim"; Some "20000.00"; None] ()); ignore (PGOCaml.execute dbh ~params:[Some "Mary"; Some "30000.00"; None] ()); let query = "select * from employees where salary > $1 order by id" in ignore (PGOCaml.prepare dbh ~query ()); let params, results = PGOCaml.describe_statement dbh () in print_params_description params; print_row_description results; let rows = PGOCaml.execute dbh ~params:[Some "0"] () in print_rows rows; PGOCaml.close dbh pgocaml-4.4.0/tests/test_re.ml000066400000000000000000000035131450353127600163120ustar00rootroot00000000000000open OUnit let sprintf = Printf.sprintf let inet_of_string = let printer (inet, addr) = sprintf "%s/%d" (Unix.string_of_inet_addr inet) addr in [ "123.100.1.1/16", ("123.100.1.1", 16) ; "127.0.0.1", ("127.0.0.1", 32) ; "1.1.1.1/", ("1.1.1.1", 32) ; "fe80::0202:b3ff:fe1e:8329", ("fe80::0202:b3ff:fe1e:8329", 128) ] |> List.map (fun (s, (str, mask)) -> let ip = Unix.inet_addr_of_string str in s >:: fun () -> assert_equal ~printer (ip, mask) (PGOCaml.inet_of_string s) ) let point_of_string = let printer (f1, f2) = sprintf "(%f, %f)" f1 f2 in let tests = [ "(0,0)", (0.0, 0.0) ; "(+1,-2)", (1.0, -2.0) ; "(1.0, 2.0)", (1.0, 2.0) ; "( 1,1.0)", (1.0, 1.0) ; "(1.0, 1.0 )", (1.0, 1.0) ; "(+Infinity, -Infinity)", (infinity, neg_infinity) ; "(12.0, Infinity )", (12.0, infinity) ] |> List.map (fun (s, pt) -> s >:: fun () -> assert_equal ~printer pt (PGOCaml.point_of_string s) ) in ("nan" >:: fun () -> ignore (PGOCaml.point_of_string "(nan , NaN )"))::tests let interval_of_string = let printer = PGOCaml.string_of_interval in let module Period = CalendarLib.Calendar.Period in let add' = List.fold_left Period.add Period.empty in [ "5 years", Period.year 5 ; "12 day", Period.day 12 ; "06:00", Period.hour 6 ; "00:10", Period.minute 10 ; "5 years 3 mons", Period.(add (year 5) (month 3)) ; "12 year 00:12:03", Period.(add' [year 12; minute 12; second 3]) ; "77 day 12:12", Period.(add' [day 77; hour 12; minute 12]) ] |> List.map (fun (s, p) -> s >:: fun () -> assert_equal ~printer p (PGOCaml.interval_of_string s) ) let () = ("test res" >::: [ "inet_of_string" >::: inet_of_string ; "point_of_string" >::: point_of_string ; "interval_of_string" >::: interval_of_string ] ) |> run_test_tt_main |> ignore pgocaml-4.4.0/tests_ppx/000077500000000000000000000000001450353127600152005ustar00rootroot00000000000000pgocaml-4.4.0/tests_ppx/config.sexp000066400000000000000000000020101450353127600173370ustar00rootroot00000000000000( ( (And ( (Or ( (Rule (typnam userid)) (Rule (typnam int4)) (Rule (typnam int32)) ) ) (Or ( (Rule (typnam userid)) (Rule (argnam userid)) (Rule (colnam userid)) ) ) ) ) ( (serialize Userid.to_string) (deserialize Userid.from_string) ) ) ( (And ( (Or ( (Rule (typnam cash_money)) (Rule (typnam float)) ) ) (Or ( (Rule (argnam salary)) (Rule (colnam salary)) (Rule (argnam customsalary)) ) ) ) ) ( (serialize "fun x -> String.(sub x 1 (length x - 1)) |> String.trim") (deserialize "fun x -> \"$\" ^ x") ) ) ( (And ( (Rule (colnam userids)) (Rule (typnam int32_array)) ) ) ( (serialize "PGOCaml.string_of_arbitrary_array Userid.to_string") (deserialize "PGOCaml.arbitrary_array_of_string Userid.from_string") ) ) )pgocaml-4.4.0/tests_ppx/dune000066400000000000000000000003161450353127600160560ustar00rootroot00000000000000(executable (name test_ppx) (preprocessor_deps config.sexp) (libraries oUnit result pgocaml) (preprocess (pps pgocaml_ppx))) (alias (name runtest) (deps test_ppx.exe) (action (run %{deps}))) pgocaml-4.4.0/tests_ppx/test_ppx.ml000066400000000000000000000053251450353127600174050ustar00rootroot00000000000000let init_dbh dbh = let () = [%pgsql dbh "execute" "create temporary table employees ( userid serial primary key, name text not null, salary int not null, email text )"] in let () = [%pgsql dbh "execute" " DO $$ BEGIN CREATE DOMAIN cash_money AS float; EXCEPTION WHEN duplicate_object THEN null; END $$"] in [%pgsql dbh "execute" "CREATE TEMPORARY TABLE customtable ( userid int4 NOT NULL, salary cash_money NOT NULL )"] module Userid: sig type t val to_string : t -> string val from_string : string -> t val to_int : t -> int end = struct type t = int let to_string = string_of_int let from_string = int_of_string let to_int x = x end let employee_exists dbh ?email n = [%pgsql dbh "SELECT EXISTS (SELECT 1 FROM employees WHERE name = $n AND email = $?email)"] let () = let dbh = PGOCaml.connect () in init_dbh dbh; let insert name pay email = [%pgsql dbh "insert into employees (name, salary, email) values ($name, $pay, $?email)"] in insert "Ann" 10_000_l None; insert "Bob" 45_000_l None; insert "Jim" 20_000_l None; insert "Mary" 30_000_l (Some "mary@example.com"); let rows = [%pgsql dbh "load_custom_from=tests_ppx/config.sexp" "select userid, name, salary, email from employees"] in List.iter begin fun (id, name, salary, email) -> let email = match email with Some email -> email | None -> "-" in Printf.printf "%d %S %ld %S\n" (Userid.to_int id) name salary email end rows; let ids = [ 1_l; 3_l ] in let rows = [%pgsql.object dbh "show=pp" "select * from employees where userid in $@ids"] in List.iter begin fun obj -> print_endline obj#pp end rows; let uid = Userid.from_string "69" in let salary = "$420.00" in let () = [%pgsql dbh "load_custom_from=tests_ppx/config.sexp" "INSERT INTO customtable (userid, salary) VALUES (${uid:userid}, $salary)"] in let rows' = [%pgsql.object dbh "load_custom_from=tests_ppx/config.sexp" "show" "SELECT * FROM customtable WHERE salary = $salary"] in List.iter begin fun obj -> Printf.printf "%d was paid %s\n" (Userid.to_int obj#userid) obj#salary end rows'; let all_employees = [%pgsql.object dbh "load_custom_from=tests_ppx/config.sexp" "SELECT array_agg(userid) as userids FROM employees"] in let () = print_endline "All userID's:" in List.iter (fun x -> match x#userids with | None -> () | Some l -> (List.iter (function | None -> () | Some userid -> Userid.to_string userid |> Printf.printf "\t%s\n")) l ) all_employees; PGOCaml.close dbh pgocaml-4.4.0/utils/000077500000000000000000000000001450353127600143075ustar00rootroot00000000000000pgocaml-4.4.0/utils/pgocaml_prof.ml000066400000000000000000000257051450353127600173220ustar00rootroot00000000000000(* A tool to analyse profiling traces generated by $PGPROFILING=filename. * See README.profiling for more information. * * PG'OCaml - type safe interface to PostgreSQL. * Copyright (C) 2005-2009 Richard Jones and other authors. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this library; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. *) open PGOCaml_aux open Printf let (//) = Filename.concat (* Don't keep the rows in memory, instead divide them by connection * and write into a temporary directory. This allows us to handle * very large profiles. *) let tmpdir = Filename.temp_file "pgocamlprof" ".d" let nr_rows = ref 0 let () = (* Filename.temp_file actually creates the file - delete it. *) (try Unix.unlink tmpdir with _ -> ()); Unix.mkdir tmpdir 0o755; (* Little bit of caching helps in the common case where adjacent * rows belong to the same connection. *) let get_chan, close_chan = let last_conn = ref None in let last_chan = ref None in let close_chan () = match !last_chan with | None -> () | Some chan -> close_out chan; last_chan := None; last_conn := None in let get_chan conn = match !last_conn with | Some conn' when conn = conn' -> Option.get !last_chan | _ -> close_chan (); let open_flags = [ Open_wronly; Open_append; Open_creat ] in let filename = tmpdir // conn in let chan = open_out_gen open_flags 0o644 filename in last_chan := Some chan; last_conn := Some conn; chan in get_chan, close_chan in let f = function | ("1" as version) :: conn :: rest -> let chan = get_chan conn in incr nr_rows; Csv.save_out chan [version :: rest]; | _ -> () (* just ignore versions we don't understand *) in let chan = open_in Sys.argv.(1) in Csv.load_rows f chan; close_in chan; (* Close the cached out_channel. *) close_chan () (* Accumulate results by query and by connection. * (Implicitly assume that queries can be treated independently.) *) type query_data = { query : string; (* Query (prepared, w/placeholders). *) qprogs : string list; (* Programs which used this. *) nr_preps : int; (* Number of times prepared. *) prep_time : int; (* Total prep time (ms). *) nr_execs : int; (* Number of times executed. *) exec_time : int; (* Total exec time (ms). *) nr_qfailures : int; (* Number of failures (prep+exec). *) } let queries = Hashtbl.create 31 let set_query query update = let data = try Hashtbl.find queries query with Not_found -> { query = query; qprogs = []; nr_preps = 0; prep_time = 0; nr_execs = 0; exec_time = 0; nr_qfailures = 0 } in let data = update data in Hashtbl.replace queries query data type connection_data = { params : connection_params; (* Connection parameters. *) progs : string list; (* Programs which used this. *) nr_connects : int; (* Number of connects. *) connect_time : int; (* Total connect time (ms). *) nr_closes : int; (* Number of explicit closes. *) close_time : int; (* Total close time (ms). *) nr_pings : int; (* Number of pings. *) ping_time : int; (* Total ping time (ms). *) nr_failures : int; (* Number of failures. *) } and connection_params = { user : string; database : string; host : string; port : int; } let connections = Hashtbl.create 31 let set_connection params update = let data = try Hashtbl.find connections params with Not_found -> { params = params; progs = []; nr_connects = 0; connect_time = 0; nr_closes = 0; close_time = 0; nr_pings = 0; ping_time = 0; nr_failures = 0; } in let data = update data in Hashtbl.replace connections params data exception Ignore of string let files = Array.to_list (Sys.readdir tmpdir) let nr_rows' = ref 0 let () = List.iter ( fun uuid -> let rows = Csv.load (tmpdir // uuid) in nr_rows' := !nr_rows' + (List.length rows); let ignore msg = raise (Ignore msg) in try assert (rows <> []); let rec assoc i = function | x :: y :: xs when x = i -> y | _ :: _ :: xs -> assoc i xs | [] -> ignore (sprintf "key %s not found" i) | [_] -> ignore "odd number of elements in association list" in (* NB. We expect the rows to begin with a "connect" operation, * then have a series of prepare/executes, and possibly finish * with a "close". *) let params, prog = match rows with | ("1" :: "connect" :: time :: status :: details) :: _ -> { user = assoc "user" details; database = assoc "database" details; host = assoc "host" details; port = int_of_string (assoc "port" details) }, assoc "prog" details | _ -> ignore (sprintf "connection %s did not start with a 'connect' operation" uuid) in set_connection params (fun data -> { data with progs = prog :: List.filter ((<>) prog) data.progs }); (* qnames maps prepared query names to query. *) let qnames = Hashtbl.create 13 in List.iter ( function | "1" :: "connect" :: time :: status :: details -> let time = int_of_string time in let failures = if status = "ok" then 0 else 1 in set_connection params (fun data -> { data with nr_connects = data.nr_connects + 1; connect_time = data.connect_time + time; nr_failures = data.nr_failures + failures; }) | "1" :: "prepare" :: time :: status :: details -> let time = int_of_string time in let failures = if status = "ok" then 0 else 1 in let query = assoc "query" details in let name = assoc "name" details in (* Put it in qnames so we can look it up in execute below. *) Hashtbl.replace qnames name query; set_query query (fun data -> { data with qprogs = prog :: List.filter ((<>) prog) data.qprogs; nr_preps = data.nr_preps + 1; prep_time = data.prep_time + time; nr_qfailures = data.nr_qfailures + failures; }) | "1" :: "execute" :: time :: status :: details -> let time = int_of_string time in let failures = if status = "ok" then 0 else 1 in let name = assoc "name" details in let query = try Hashtbl.find qnames name with Not_found -> ignore (sprintf "execute on unprepared query name '%s'" name) in set_query query (fun data -> { data with nr_execs = data.nr_execs + 1; exec_time = data.exec_time + time; nr_qfailures = data.nr_qfailures + failures; }) | "1" :: "close" :: time :: status :: _ -> let time = int_of_string time in let failures = if status = "ok" then 0 else 1 in set_connection params (fun data -> { data with nr_closes = data.nr_closes + 1; close_time = data.close_time + time; nr_failures = data.nr_failures + failures; }) | "1" :: "ping" :: time :: status :: _ -> let time = int_of_string time in let failures = if status = "ok" then 0 else 1 in set_connection params (fun data -> { data with nr_pings = data.nr_pings + 1; ping_time = data.ping_time + time; nr_failures = data.nr_failures + failures; }) | _ -> ignore "invalid row" ) rows with Ignore msg -> eprintf "warning: %s\n" msg ) files (* Clean up temporary directory. *) let () = List.iter ( fun filename -> Unix.unlink (tmpdir // filename) ) files; Unix.rmdir tmpdir (* Sanity check - did we read back the same number of rows that * we wrote? *) let () = assert (!nr_rows = !nr_rows') (* More manageable as lists. *) let queries = Hashtbl.fold (fun query data xs -> (query, data) :: xs) queries [] let connections = Hashtbl.fold (fun params data xs -> (params, data) :: xs) connections [] (* Sort them so that the ones with the most cumulative time are first. *) let queries = let f (_, { prep_time = prep_time1; exec_time = exec_time1 }) (_, { prep_time = prep_time2; exec_time = exec_time2 }) = compare (prep_time2 + exec_time2) (prep_time1 + exec_time1) in List.sort f queries let connections = let f (_, { connect_time = connect_time1; close_time = close_time1; ping_time = ping_time1 }) (_, { connect_time = connect_time2; close_time = close_time2; ping_time = ping_time2 }) = compare (connect_time2 + close_time2 + ping_time2) (connect_time1 + close_time1 + ping_time1) in List.sort f connections (* Print out the results of the analysis. *) let () = printf "---------------------------------------- QUERIES ---------\n\n"; List.iter ( fun (query, data) -> printf "Query:\n%s\n\n" query; printf "Total time: %d ms\n" (data.prep_time + data.exec_time); printf " Prepare: %d ms\n" data.prep_time; printf " Calls: %d\n" data.nr_preps; if data.nr_preps > 0 then printf " Avg time/prep: %d ms\n" (data.prep_time / data.nr_preps); printf " Execute: %d ms\n" data.exec_time; printf " Calls: %d\n" data.nr_execs; if data.nr_execs > 0 then printf " Avg time/exec: %d ms\n" (data.exec_time / data.nr_execs); printf " Failures: %d\n" data.nr_qfailures; printf "Called from: %s\n" (String.concat ", " data.qprogs); printf "\n\n"; ) queries; printf "---------------------------------------- CONNECTIONS -----\n\n"; List.iter ( fun (params, data) -> printf "Connection:\n"; printf " user = %s\n" params.user; printf " database = %s\n" params.database; printf " host = %s\n" params.host; printf " port = %d\n" params.port; printf "\n"; printf "Total time: %d ms\n" (data.connect_time + data.close_time + data.ping_time); printf " Connect: %d ms\n" data.connect_time; printf " Calls: %d\n" data.nr_connects; if data.nr_connects > 0 then printf " Avg time/conn: %d ms\n" (data.connect_time / data.nr_connects); printf " Close: %d ms\n" data.close_time; printf " Calls: %d\n" data.nr_closes; if data.nr_closes > 0 then printf " Avg time/close: %d ms\n" (data.close_time / data.nr_closes); printf " Ping: %d ms\n" data.ping_time; printf " Calls: %d\n" data.nr_pings; if data.nr_pings > 0 then printf " Avg time/ping: %d ms\n" (data.ping_time / data.nr_pings); printf "Called from: %s\n" (String.concat ", " data.progs); printf "\n\n"; ) connections