├── .circleci └── config.yml ├── .editorconfig ├── .gitignore ├── .ocamlformat ├── .ocp-indent ├── .pre-commit-config.yaml ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── doc └── doc.odocl ├── dune-project ├── pgx.opam ├── pgx ├── src │ ├── access.ml │ ├── access.mli │ ├── dune │ ├── error_response.ml │ ├── error_response.mli │ ├── io_intf.ml │ ├── isolation.ml │ ├── isolation.mli │ ├── pgx.ml │ ├── pgx.mli │ ├── pgx_aux.ml │ ├── pgx_aux.mli │ ├── pgx_intf.ml │ ├── pgx_value.ml │ ├── pgx_value.mli │ ├── pgx_value_intf.ml │ ├── result_desc.ml │ ├── result_desc.mli │ ├── row_desc.ml │ └── types.ml └── test │ ├── dune │ ├── test_error_response.ml │ └── test_pgx_value.ml ├── pgx_async.opam ├── pgx_async ├── bin │ ├── dune │ └── pgx_async_example.ml ├── src │ ├── dune │ ├── pgx_async.ml │ ├── pgx_async.mli │ ├── pgx_async_test.ml │ └── pgx_async_test.mli └── test │ ├── dune │ └── test_pgx_async.ml ├── pgx_lwt.opam ├── pgx_lwt └── src │ ├── dune │ ├── io_intf.ml │ ├── pgx_lwt.ml │ └── pgx_lwt.mli ├── pgx_lwt_mirage.opam ├── pgx_lwt_mirage └── src │ ├── dune │ ├── pgx_lwt_mirage.ml │ └── pgx_lwt_mirage.mli ├── pgx_lwt_unix.opam ├── pgx_lwt_unix ├── src │ ├── dune │ ├── pgx_lwt_unix.ml │ └── pgx_lwt_unix.mli └── test │ ├── dune │ └── test_pgx_lwt.ml ├── pgx_test └── src │ ├── dune │ ├── pgx_test.ml │ └── pgx_test.mli ├── pgx_unix.opam ├── pgx_unix ├── src │ ├── dune │ ├── pgx_unix.ml │ └── pgx_unix.mli └── test │ ├── dune │ └── test_pgx_unix.ml ├── pgx_value_core.opam ├── pgx_value_core ├── src │ ├── dune │ ├── pgx_value_core.ml │ └── pgx_value_core.mli └── test │ ├── dune │ └── test_pgx_value_core.ml ├── pgx_value_ptime.opam ├── pgx_value_ptime ├── src │ ├── dune │ ├── pgx_value_ptime.ml │ └── pgx_value_ptime.mli └── test │ ├── dune │ └── test_pgx_value_ptime.ml ├── pin_dev.sh └── unikernel ├── .ocamlformat ├── README.md ├── config.ml └── unikernel.ml /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2.1 2 | jobs: 3 | build: 4 | docker: 5 | - image: ocaml/opam:alpine-ocaml-4.11 6 | environment: 7 | PGUSER: pgx 8 | PGDATABASE: pgx-test 9 | PGHOST: 127.0.0.1 10 | PGX_FORCE_TESTS: true 11 | TERM: xterm 12 | - image: circleci/postgres:9.6-alpine 13 | environment: 14 | POSTGRES_USER: pgx 15 | POSTGRES_DB: pgx-test 16 | POSTGRES_PASSWORD: "" 17 | steps: 18 | - checkout 19 | - run: 20 | name: Update opam 21 | command: | 22 | opam remote remove default --all 23 | opam remote add default https://opam.ocaml.org 24 | - run: 25 | name: Pin packages 26 | command: ./pin_dev.sh 27 | - run: 28 | name: Install system dependencies 29 | command: opam depext -y `basename -s .opam *.opam | tr '\n' ' '` 30 | - run: 31 | name: Install OCaml dependencies 32 | command: opam install --deps-only -y `basename -s .opam *.opam | tr '\n' ' '` 33 | - run: 34 | name: Build 35 | command: opam exec -- make 36 | - run: 37 | # This is a separate step so we don't run tests for all of these ^ 38 | name: Install OCaml test dependencies 39 | command: opam install --deps-only -t -y `basename -s .opam *.opam | tr '\n' ' '` 40 | - run: 41 | name: Test and coverage report 42 | command: | 43 | coverage_set () [[ -n $COVERALLS_REPO_TOKEN ]] 44 | opam exec -- make test-coverage 45 | (coverage_set && opam exec -- bisect-ppx-report send-to Coveralls) || true 46 | 47 | 48 | dune_lint: 49 | docker: 50 | - image: ocaml/opam2:4.09 51 | environment: 52 | TERM: xterm 53 | steps: 54 | - checkout 55 | - run: 56 | name: Pin packages 57 | command: ./pin_dev.sh 58 | - run: 59 | name: Install system dependencies 60 | command: opam depext -y dune-release 61 | - run: 62 | name: Install dependencies 63 | command: opam install -y dune-release 64 | - run: 65 | name: dune-release lint 66 | command: opam exec -- dune-release lint 67 | 68 | build_mirage: 69 | docker: 70 | - image: ocaml/opam:alpine-ocaml-4.11 71 | environment: 72 | TERM: xterm 73 | steps: 74 | - checkout 75 | - run: 76 | name: Update opam 77 | command: | 78 | opam remote remove default --all 79 | opam remote add default https://opam.ocaml.org 80 | - run: 81 | name: Pin packages 82 | command: | 83 | opam pin add -k git -y -n pgx.dev . 84 | opam pin add -k git -y -n pgx_lwt.dev . 85 | opam pin add -k git -y -n pgx_lwt_mirage.dev . 86 | - run: 87 | name: Install system dependencies 88 | command: opam depext -y pgx pgx_lwt pgx_lwt_mirage 89 | - run: 90 | name: Install OCaml dependencies 91 | command: | 92 | opam install --deps-only -y pgx pgx_lwt pgx_lwt_mirage 93 | opam install mirage 94 | - run: 95 | name: Configure mirage 96 | command: cd unikernel && opam exec -- mirage configure -t spt 97 | - run: 98 | name: Install mirage deps 99 | command: cd unikernel && opam exec -- make depend 100 | - run: 101 | name: Build mirage 102 | command: cd unikernel && opam exec -- make 103 | 104 | workflows: 105 | main: 106 | jobs: 107 | - build 108 | - build_mirage 109 | - dune_lint 110 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | 3 | root = true 4 | 5 | [*] 6 | indent_style = space 7 | indent_size = 2 8 | charset = utf-8 9 | trim_trailing_whitespace = true 10 | insert_final_newline = true 11 | max_line_length = 80 12 | 13 | # Makefiles only support tab indents 14 | [Makefile] 15 | indent_style = tab 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _coverage 3 | _esy 4 | *.install 5 | .merlin 6 | esy.lock 7 | node_modules 8 | _opam 9 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | JaneStreet 2 | -------------------------------------------------------------------------------- /.pre-commit-config.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | repos: 3 | - repo: https://github.com/arenadotio/pre-commit-ocamlformat 4 | rev: 2b9c80c268df08bbe192ae58e5e8db2ba8496767 5 | hooks: 6 | - id: ocamlformat 7 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 2.2 (unreleased) 2 | 3 | ## 2.1 (2022-05-31) 4 | ### Breaking changes 5 | 6 | * Missing SASL authentication impl provides an error instead of hanging (https://github.com/arenadotio/pgx/pull/122). 7 | * pgx_lwt_mirage now requires conduit 2.3 instead of 2.2 (https://github.com/arenadotio/pgx/pull/117). 8 | 9 | ## 2.0 (2021-05-12) 10 | 11 | ### Breaking changes 12 | 13 | * The Pgx module is now wrapped, which means `Pgx_aux`, `Types`, `Access`, etc. aren't added to the global scope. 14 | The main result of this is that `Pgx_value` now needs to be accessed as `Pgx.Value`. 15 | (https://github.com/arenadotio/pgx/pull/103) 16 | * `Pgx_async.connect` and `with_conn` now have an additional optional `?ssl` argument (see below). 17 | 18 | ### Added 19 | 20 | * Pgx_async now supports TLS connections using Conduit_async. This is enabled by default and can be controlled with the 21 | new `?ssl` argument to `connect` and `with_conn`. 22 | (https://github.com/arenadotio/pgx/pull/108) 23 | 24 | ### Fixed 25 | 26 | * Improved message for authentication errors. Previously these raised `Pgx_eof`, and now they raise 27 | `PostgreSQL_Error("Failed to authenticate with postgres server", additional details ...)`. 28 | (https://github.com/arenadotio/pgx/pull/105) 29 | 30 | ### Changed 31 | 32 | * Support new Mirage-conduit timeout argument (https://github.com/arenadotio/pgx/pull/95). 33 | 34 | ## 1.0 (2020-05-08) 35 | 36 | ### Breaking changes 37 | 38 | * Pgx_value.t is an opaque type now. Use `Pgx_value.of/to` converters. Note that these converters are _not_ equivalent 39 | to the OCaml functions like `bool_of_string` or `float_of_string`, and that for bytea data, you need to use 40 | `Pgx_value.of/to_binary`, not `Pgx_value.of/to_string`. 41 | * Pgx_lwt has been renamed Pgx_lwt_unix. 42 | * `Pgx.execute` now uses the unnamed prepare statement. In most cases this should not affect anything, but if you were 43 | relying on Pgx not internally using the unnamed prepared statement, you will need to fix your code. If you run into 44 | this, the fix is to use `Pgx.with_prepared` and name your prepared statement. 45 | * `Pgx_value.of_inet`/`to_inet` now use `Ipaddr.t` from the `ipaddr` library instead of `Unix.inet_addr`. 46 | 47 | ### Added 48 | 49 | * `Pgx_value.of_binary` and `Pgx_value.to_binary` added for bytea data. 50 | * Add `execute_map` helper to Pgx 51 | * Add `execute_pipe` helper to Pgx_async 52 | * Add `execute_unit` helper to Pgx 53 | * Break out `Pgx_value_core` library, which will allow users of Pgx_unix and Pgx_lwt to use the `Core_kernel.Tim` and 54 | `Date` types. This is still included by default in Pgx_async. 55 | * Added Pgx_lwt_mirage 56 | * Pgx_value types now all implement `compare` and `sexp_of` 57 | 58 | ### Fixed 59 | 60 | * Pgx no longer assumes all strings are binary data. Strings must be valid varchar data in the database's encoding. 61 | Use `Pgx_value.of/to_binary` with bytea columns if you want binary. 62 | * Use a tail-recursive `List.map` implementation 63 | * Use `Unix.getuid` + `Lwt_unix.getpwuid` instead of `Lwt.getlogin` for the default username, since `getlogin` fails 64 | in some cases. 65 | * Use int64 to keep track of prepared statements just in case someone prepares several million statements in one program 66 | 67 | ### Changed 68 | 69 | * Re-raise exceptions with backtraces if possible. 70 | * Pgx_async uses Async.Log for logging instead of printing directly to stderr 71 | * Use Sexplib0 instead of Sexplib 72 | * Use the Query protocol for parameterless `execute` instead of Prepare + Bind 73 | * Use the unnamed prepared statement for `execute` 74 | * Use `ipaddr` library instead of `Unix.inet_addr` 75 | * Split Pgx_lwt into Pgx_lwt_unix and Pgx_lwt_mirage 76 | 77 | ## 0.1 (2018-05-31) 78 | 79 | Initial release since fork from PG'OCaml. 80 | 81 | * More tests 82 | * More consistent use of async API's 83 | * Addition of Pgx.Value for hopefully easier conversion to and 84 | from DB types 85 | * Safe handling of concurrent queries (not any faster, but they 86 | won't crash) 87 | * Improved interface for prepared statements to make it harder 88 | to execute non-existent ones 89 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | This library is distributed under the terms of the GNU LGPL with the 2 | OCaml linking exception. 3 | 4 | ---------------------------------------------------------------------- 5 | 6 | As a special exception to the GNU Library General Public License, you 7 | may link, statically or dynamically, a "work that uses the Library" 8 | with a publicly distributed version of the Library to produce an 9 | executable file containing portions of the Library, and distribute 10 | that executable file under terms of your choice, without any of the 11 | additional requirements listed in clause 6 of the GNU Library General 12 | Public License. By "a publicly distributed version of the Library", 13 | we mean either the unmodified Library as distributed by INRIA, or a 14 | modified version of the Library that is distributed under the 15 | conditions defined in clause 3 of the GNU Library General Public 16 | License. This exception does not however invalidate any other reasons 17 | why the executable file might be covered by the GNU Library General 18 | Public License. 19 | 20 | ---------------------------------------------------------------------- 21 | 22 | GNU LIBRARY GENERAL PUBLIC LICENSE 23 | Version 2, June 1991 24 | 25 | Copyright (C) 1991 Free Software Foundation, Inc. 26 | 59 Temple Place - Suite 330 27 | Boston, MA 02111-1307, USA. 28 | Everyone is permitted to copy and distribute verbatim copies 29 | of this license document, but changing it is not allowed. 30 | 31 | [This is the first released version of the library GPL. It is 32 | numbered 2 because it goes with version 2 of the ordinary GPL.] 33 | 34 | Preamble 35 | 36 | The licenses for most software are designed to take away your 37 | freedom to share and change it. By contrast, the GNU General Public 38 | Licenses are intended to guarantee your freedom to share and change 39 | free software--to make sure the software is free for all its users. 40 | 41 | This license, the Library General Public License, applies to some 42 | specially designated Free Software Foundation software, and to any 43 | other libraries whose authors decide to use it. You can use it for 44 | your libraries, too. 45 | 46 | When we speak of free software, we are referring to freedom, not 47 | price. Our General Public Licenses are designed to make sure that you 48 | have the freedom to distribute copies of free software (and charge for 49 | this service if you wish), that you receive source code or can get it 50 | if you want it, that you can change the software or use pieces of it 51 | in new free programs; and that you know you can do these things. 52 | 53 | To protect your rights, we need to make restrictions that forbid 54 | anyone to deny you these rights or to ask you to surrender the rights. 55 | These restrictions translate to certain responsibilities for you if 56 | you distribute copies of the library, or if you modify it. 57 | 58 | For example, if you distribute copies of the library, whether gratis 59 | or for a fee, you must give the recipients all the rights that we gave 60 | you. You must make sure that they, too, receive or can get the source 61 | code. If you link a program with the library, you must provide 62 | complete object files to the recipients so that they can relink them 63 | with the library, after making changes to the library and recompiling 64 | it. And you must show them these terms so they know their rights. 65 | 66 | Our method of protecting your rights has two steps: (1) copyright 67 | the library, and (2) offer you this license which gives you legal 68 | permission to copy, distribute and/or modify the library. 69 | 70 | Also, for each distributor's protection, we want to make certain 71 | that everyone understands that there is no warranty for this free 72 | library. If the library is modified by someone else and passed on, we 73 | want its recipients to know that what they have is not the original 74 | version, so that any problems introduced by others will not reflect on 75 | the original authors' reputations. 76 | 77 | Finally, any free program is threatened constantly by software 78 | patents. We wish to avoid the danger that companies distributing free 79 | software will individually obtain patent licenses, thus in effect 80 | transforming the program into proprietary software. To prevent this, 81 | we have made it clear that any patent must be licensed for everyone's 82 | free use or not licensed at all. 83 | 84 | Most GNU software, including some libraries, is covered by the ordinary 85 | GNU General Public License, which was designed for utility programs. This 86 | license, the GNU Library General Public License, applies to certain 87 | designated libraries. This license is quite different from the ordinary 88 | one; be sure to read it in full, and don't assume that anything in it is 89 | the same as in the ordinary license. 90 | 91 | The reason we have a separate public license for some libraries is that 92 | they blur the distinction we usually make between modifying or adding to a 93 | program and simply using it. Linking a program with a library, without 94 | changing the library, is in some sense simply using the library, and is 95 | analogous to running a utility program or application program. However, in 96 | a textual and legal sense, the linked executable is a combined work, a 97 | derivative of the original library, and the ordinary General Public License 98 | treats it as such. 99 | 100 | Because of this blurred distinction, using the ordinary General 101 | Public License for libraries did not effectively promote software 102 | sharing, because most developers did not use the libraries. We 103 | concluded that weaker conditions might promote sharing better. 104 | 105 | However, unrestricted linking of non-free programs would deprive the 106 | users of those programs of all benefit from the free status of the 107 | libraries themselves. This Library General Public License is intended to 108 | permit developers of non-free programs to use free libraries, while 109 | preserving your freedom as a user of such programs to change the free 110 | libraries that are incorporated in them. (We have not seen how to achieve 111 | this as regards changes in header files, but we have achieved it as regards 112 | changes in the actual functions of the Library.) The hope is that this 113 | will lead to faster development of free libraries. 114 | 115 | The precise terms and conditions for copying, distribution and 116 | modification follow. Pay close attention to the difference between a 117 | "work based on the library" and a "work that uses the library". The 118 | former contains code derived from the library, while the latter only 119 | works together with the library. 120 | 121 | Note that it is possible for a library to be covered by the ordinary 122 | General Public License rather than by this special one. 123 | 124 | GNU LIBRARY GENERAL PUBLIC LICENSE 125 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 126 | 127 | 0. This License Agreement applies to any software library which 128 | contains a notice placed by the copyright holder or other authorized 129 | party saying it may be distributed under the terms of this Library 130 | General Public License (also called "this License"). Each licensee is 131 | addressed as "you". 132 | 133 | A "library" means a collection of software functions and/or data 134 | prepared so as to be conveniently linked with application programs 135 | (which use some of those functions and data) to form executables. 136 | 137 | The "Library", below, refers to any such software library or work 138 | which has been distributed under these terms. A "work based on the 139 | Library" means either the Library or any derivative work under 140 | copyright law: that is to say, a work containing the Library or a 141 | portion of it, either verbatim or with modifications and/or translated 142 | straightforwardly into another language. (Hereinafter, translation is 143 | included without limitation in the term "modification".) 144 | 145 | "Source code" for a work means the preferred form of the work for 146 | making modifications to it. For a library, complete source code means 147 | all the source code for all modules it contains, plus any associated 148 | interface definition files, plus the scripts used to control compilation 149 | and installation of the library. 150 | 151 | Activities other than copying, distribution and modification are not 152 | covered by this License; they are outside its scope. The act of 153 | running a program using the Library is not restricted, and output from 154 | such a program is covered only if its contents constitute a work based 155 | on the Library (independent of the use of the Library in a tool for 156 | writing it). Whether that is true depends on what the Library does 157 | and what the program that uses the Library does. 158 | 159 | 1. You may copy and distribute verbatim copies of the Library's 160 | complete source code as you receive it, in any medium, provided that 161 | you conspicuously and appropriately publish on each copy an 162 | appropriate copyright notice and disclaimer of warranty; keep intact 163 | all the notices that refer to this License and to the absence of any 164 | warranty; and distribute a copy of this License along with the 165 | Library. 166 | 167 | You may charge a fee for the physical act of transferring a copy, 168 | and you may at your option offer warranty protection in exchange for a 169 | fee. 170 | 171 | 2. You may modify your copy or copies of the Library or any portion 172 | of it, thus forming a work based on the Library, and copy and 173 | distribute such modifications or work under the terms of Section 1 174 | above, provided that you also meet all of these conditions: 175 | 176 | a) The modified work must itself be a software library. 177 | 178 | b) You must cause the files modified to carry prominent notices 179 | stating that you changed the files and the date of any change. 180 | 181 | c) You must cause the whole of the work to be licensed at no 182 | charge to all third parties under the terms of this License. 183 | 184 | d) If a facility in the modified Library refers to a function or a 185 | table of data to be supplied by an application program that uses 186 | the facility, other than as an argument passed when the facility 187 | is invoked, then you must make a good faith effort to ensure that, 188 | in the event an application does not supply such function or 189 | table, the facility still operates, and performs whatever part of 190 | its purpose remains meaningful. 191 | 192 | (For example, a function in a library to compute square roots has 193 | a purpose that is entirely well-defined independent of the 194 | application. Therefore, Subsection 2d requires that any 195 | application-supplied function or table used by this function must 196 | be optional: if the application does not supply it, the square 197 | root function must still compute square roots.) 198 | 199 | These requirements apply to the modified work as a whole. If 200 | identifiable sections of that work are not derived from the Library, 201 | and can be reasonably considered independent and separate works in 202 | themselves, then this License, and its terms, do not apply to those 203 | sections when you distribute them as separate works. But when you 204 | distribute the same sections as part of a whole which is a work based 205 | on the Library, the distribution of the whole must be on the terms of 206 | this License, whose permissions for other licensees extend to the 207 | entire whole, and thus to each and every part regardless of who wrote 208 | it. 209 | 210 | Thus, it is not the intent of this section to claim rights or contest 211 | your rights to work written entirely by you; rather, the intent is to 212 | exercise the right to control the distribution of derivative or 213 | collective works based on the Library. 214 | 215 | In addition, mere aggregation of another work not based on the Library 216 | with the Library (or with a work based on the Library) on a volume of 217 | a storage or distribution medium does not bring the other work under 218 | the scope of this License. 219 | 220 | 3. You may opt to apply the terms of the ordinary GNU General Public 221 | License instead of this License to a given copy of the Library. To do 222 | this, you must alter all the notices that refer to this License, so 223 | that they refer to the ordinary GNU General Public License, version 2, 224 | instead of to this License. (If a newer version than version 2 of the 225 | ordinary GNU General Public License has appeared, then you can specify 226 | that version instead if you wish.) Do not make any other change in 227 | these notices. 228 | 229 | Once this change is made in a given copy, it is irreversible for 230 | that copy, so the ordinary GNU General Public License applies to all 231 | subsequent copies and derivative works made from that copy. 232 | 233 | This option is useful when you wish to copy part of the code of 234 | the Library into a program that is not a library. 235 | 236 | 4. You may copy and distribute the Library (or a portion or 237 | derivative of it, under Section 2) in object code or executable form 238 | under the terms of Sections 1 and 2 above provided that you accompany 239 | it with the complete corresponding machine-readable source code, which 240 | must be distributed under the terms of Sections 1 and 2 above on a 241 | medium customarily used for software interchange. 242 | 243 | If distribution of object code is made by offering access to copy 244 | from a designated place, then offering equivalent access to copy the 245 | source code from the same place satisfies the requirement to 246 | distribute the source code, even though third parties are not 247 | compelled to copy the source along with the object code. 248 | 249 | 5. A program that contains no derivative of any portion of the 250 | Library, but is designed to work with the Library by being compiled or 251 | linked with it, is called a "work that uses the Library". Such a 252 | work, in isolation, is not a derivative work of the Library, and 253 | therefore falls outside the scope of this License. 254 | 255 | However, linking a "work that uses the Library" with the Library 256 | creates an executable that is a derivative of the Library (because it 257 | contains portions of the Library), rather than a "work that uses the 258 | library". The executable is therefore covered by this License. 259 | Section 6 states terms for distribution of such executables. 260 | 261 | When a "work that uses the Library" uses material from a header file 262 | that is part of the Library, the object code for the work may be a 263 | derivative work of the Library even though the source code is not. 264 | Whether this is true is especially significant if the work can be 265 | linked without the Library, or if the work is itself a library. The 266 | threshold for this to be true is not precisely defined by law. 267 | 268 | If such an object file uses only numerical parameters, data 269 | structure layouts and accessors, and small macros and small inline 270 | functions (ten lines or less in length), then the use of the object 271 | file is unrestricted, regardless of whether it is legally a derivative 272 | work. (Executables containing this object code plus portions of the 273 | Library will still fall under Section 6.) 274 | 275 | Otherwise, if the work is a derivative of the Library, you may 276 | distribute the object code for the work under the terms of Section 6. 277 | Any executables containing that work also fall under Section 6, 278 | whether or not they are linked directly with the Library itself. 279 | 280 | 6. As an exception to the Sections above, you may also compile or 281 | link a "work that uses the Library" with the Library to produce a 282 | work containing portions of the Library, and distribute that work 283 | under terms of your choice, provided that the terms permit 284 | modification of the work for the customer's own use and reverse 285 | engineering for debugging such modifications. 286 | 287 | You must give prominent notice with each copy of the work that the 288 | Library is used in it and that the Library and its use are covered by 289 | this License. You must supply a copy of this License. If the work 290 | during execution displays copyright notices, you must include the 291 | copyright notice for the Library among them, as well as a reference 292 | directing the user to the copy of this License. Also, you must do one 293 | of these things: 294 | 295 | a) Accompany the work with the complete corresponding 296 | machine-readable source code for the Library including whatever 297 | changes were used in the work (which must be distributed under 298 | Sections 1 and 2 above); and, if the work is an executable linked 299 | with the Library, with the complete machine-readable "work that 300 | uses the Library", as object code and/or source code, so that the 301 | user can modify the Library and then relink to produce a modified 302 | executable containing the modified Library. (It is understood 303 | that the user who changes the contents of definitions files in the 304 | Library will not necessarily be able to recompile the application 305 | to use the modified definitions.) 306 | 307 | b) Accompany the work with a written offer, valid for at 308 | least three years, to give the same user the materials 309 | specified in Subsection 6a, above, for a charge no more 310 | than the cost of performing this distribution. 311 | 312 | c) If distribution of the work is made by offering access to copy 313 | from a designated place, offer equivalent access to copy the above 314 | specified materials from the same place. 315 | 316 | d) Verify that the user has already received a copy of these 317 | materials or that you have already sent this user a copy. 318 | 319 | For an executable, the required form of the "work that uses the 320 | Library" must include any data and utility programs needed for 321 | reproducing the executable from it. However, as a special exception, 322 | the source code distributed need not include anything that is normally 323 | distributed (in either source or binary form) with the major 324 | components (compiler, kernel, and so on) of the operating system on 325 | which the executable runs, unless that component itself accompanies 326 | the executable. 327 | 328 | It may happen that this requirement contradicts the license 329 | restrictions of other proprietary libraries that do not normally 330 | accompany the operating system. Such a contradiction means you cannot 331 | use both them and the Library together in an executable that you 332 | distribute. 333 | 334 | 7. You may place library facilities that are a work based on the 335 | Library side-by-side in a single library together with other library 336 | facilities not covered by this License, and distribute such a combined 337 | library, provided that the separate distribution of the work based on 338 | the Library and of the other library facilities is otherwise 339 | permitted, and provided that you do these two things: 340 | 341 | a) Accompany the combined library with a copy of the same work 342 | based on the Library, uncombined with any other library 343 | facilities. This must be distributed under the terms of the 344 | Sections above. 345 | 346 | b) Give prominent notice with the combined library of the fact 347 | that part of it is a work based on the Library, and explaining 348 | where to find the accompanying uncombined form of the same work. 349 | 350 | 8. You may not copy, modify, sublicense, link with, or distribute 351 | the Library except as expressly provided under this License. Any 352 | attempt otherwise to copy, modify, sublicense, link with, or 353 | distribute the Library is void, and will automatically terminate your 354 | rights under this License. However, parties who have received copies, 355 | or rights, from you under this License will not have their licenses 356 | terminated so long as such parties remain in full compliance. 357 | 358 | 9. You are not required to accept this License, since you have not 359 | signed it. However, nothing else grants you permission to modify or 360 | distribute the Library or its derivative works. These actions are 361 | prohibited by law if you do not accept this License. Therefore, by 362 | modifying or distributing the Library (or any work based on the 363 | Library), you indicate your acceptance of this License to do so, and 364 | all its terms and conditions for copying, distributing or modifying 365 | the Library or works based on it. 366 | 367 | 10. Each time you redistribute the Library (or any work based on the 368 | Library), the recipient automatically receives a license from the 369 | original licensor to copy, distribute, link with or modify the Library 370 | subject to these terms and conditions. You may not impose any further 371 | restrictions on the recipients' exercise of the rights granted herein. 372 | You are not responsible for enforcing compliance by third parties to 373 | this License. 374 | 375 | 11. If, as a consequence of a court judgment or allegation of patent 376 | infringement or for any other reason (not limited to patent issues), 377 | conditions are imposed on you (whether by court order, agreement or 378 | otherwise) that contradict the conditions of this License, they do not 379 | excuse you from the conditions of this License. If you cannot 380 | distribute so as to satisfy simultaneously your obligations under this 381 | License and any other pertinent obligations, then as a consequence you 382 | may not distribute the Library at all. For example, if a patent 383 | license would not permit royalty-free redistribution of the Library by 384 | all those who receive copies directly or indirectly through you, then 385 | the only way you could satisfy both it and this License would be to 386 | refrain entirely from distribution of the Library. 387 | 388 | If any portion of this section is held invalid or unenforceable under any 389 | particular circumstance, the balance of the section is intended to apply, 390 | and the section as a whole is intended to apply in other circumstances. 391 | 392 | It is not the purpose of this section to induce you to infringe any 393 | patents or other property right claims or to contest validity of any 394 | such claims; this section has the sole purpose of protecting the 395 | integrity of the free software distribution system which is 396 | implemented by public license practices. Many people have made 397 | generous contributions to the wide range of software distributed 398 | through that system in reliance on consistent application of that 399 | system; it is up to the author/donor to decide if he or she is willing 400 | to distribute software through any other system and a licensee cannot 401 | impose that choice. 402 | 403 | This section is intended to make thoroughly clear what is believed to 404 | be a consequence of the rest of this License. 405 | 406 | 12. If the distribution and/or use of the Library is restricted in 407 | certain countries either by patents or by copyrighted interfaces, the 408 | original copyright holder who places the Library under this License may add 409 | an explicit geographical distribution limitation excluding those countries, 410 | so that distribution is permitted only in or among countries not thus 411 | excluded. In such case, this License incorporates the limitation as if 412 | written in the body of this License. 413 | 414 | 13. The Free Software Foundation may publish revised and/or new 415 | versions of the Library General Public License from time to time. 416 | Such new versions will be similar in spirit to the present version, 417 | but may differ in detail to address new problems or concerns. 418 | 419 | Each version is given a distinguishing version number. If the Library 420 | specifies a version number of this License which applies to it and 421 | "any later version", you have the option of following the terms and 422 | conditions either of that version or of any later version published by 423 | the Free Software Foundation. If the Library does not specify a 424 | license version number, you may choose any version ever published by 425 | the Free Software Foundation. 426 | 427 | 14. If you wish to incorporate parts of the Library into other free 428 | programs whose distribution conditions are incompatible with these, 429 | write to the author to ask for permission. For software which is 430 | copyrighted by the Free Software Foundation, write to the Free 431 | Software Foundation; we sometimes make exceptions for this. Our 432 | decision will be guided by the two goals of preserving the free status 433 | of all derivatives of our free software and of promoting the sharing 434 | and reuse of software generally. 435 | 436 | NO WARRANTY 437 | 438 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 439 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 440 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 441 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 442 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 443 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 444 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 445 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 446 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 447 | 448 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 449 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 450 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 451 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 452 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 453 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 454 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 455 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 456 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 457 | DAMAGES. 458 | 459 | END OF TERMS AND CONDITIONS 460 | 461 | Appendix: How to Apply These Terms to Your New Libraries 462 | 463 | If you develop a new library, and you want it to be of the greatest 464 | possible use to the public, we recommend making it free software that 465 | everyone can redistribute and change. You can do so by permitting 466 | redistribution under these terms (or, alternatively, under the terms of the 467 | ordinary General Public License). 468 | 469 | To apply these terms, attach the following notices to the library. It is 470 | safest to attach them to the start of each source file to most effectively 471 | convey the exclusion of warranty; and each file should have at least the 472 | "copyright" line and a pointer to where the full notice is found. 473 | 474 | 475 | Copyright (C) 476 | 477 | This library is free software; you can redistribute it and/or 478 | modify it under the terms of the GNU Library General Public 479 | License as published by the Free Software Foundation; either 480 | version 2 of the License, or (at your option) any later version. 481 | 482 | This library is distributed in the hope that it will be useful, 483 | but WITHOUT ANY WARRANTY; without even the implied warranty of 484 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 485 | Library General Public License for more details. 486 | 487 | You should have received a copy of the GNU General Public License 488 | along with this library; see the file COPYING. If not, write to 489 | the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 490 | Boston, MA 02111-1307, USA. 491 | 492 | Also add information on how to contact you by electronic and paper mail. 493 | 494 | You should also get your employer (if you work as a programmer) or your 495 | school, if any, to sign a "copyright disclaimer" for the library, if 496 | necessary. Here is a sample; alter the names: 497 | 498 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 499 | library `Frob' (a library for tweaking knobs) written by James Random Hacker. 500 | 501 | , 1 April 1990 502 | Ty Coon, President of Vice 503 | 504 | That's all there is to it! -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGES := $(shell ls -1 *.opam | xargs echo | sed 's/.opam//g' | sed 's/ /,/g') 2 | 3 | all: build 4 | 5 | build: 6 | @dune build @install @examples -p $(PACKAGES) 7 | 8 | clean: 9 | @dune clean 10 | 11 | coverage: clean 12 | @BISECT_ENABLE=yes dune runtest -p $(PACKAGES) 13 | @bisect-ppx-report send-to Coveralls 14 | 15 | test: 16 | @dune runtest --force -p $(PACKAGES) 17 | 18 | test-coverage: 19 | @BISECT_ENABLE=yes dune runtest -p $(PACKAGES) 20 | 21 | .PHONY: all build clean coverage test 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![CircleCI](https://circleci.com/gh/arenadotio/pgx.svg?style=shield)](https://circleci.com/gh/arenadotio/pgx) 2 | [![Coverage Status](https://coveralls.io/repos/github/arenadotio/pgx/badge.svg?branch=master)](https://coveralls.io/github/arenadotio/pgx?branch=master) 3 | [![Documentation](https://img.shields.io/badge/documentation-odoc-blue)](https://arenadotio.github.io/pgx/index.html) 4 | 5 | PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or 6 | synchronous operations. 7 | 8 | This library focuses on correctness and safety, with features like: 9 | 10 | - It is nearly impossible to try to execute a prepared statement that hasn't 11 | been prepared. 12 | - Trying to run multiple queries at the same time will work properly (although 13 | there's no performance benefit, since we currently don't send queries in 14 | parallel). 15 | - Lots of automated tests. 16 | - `Pgx.Value` for parameters and returned data, encouraging people to use 17 | the built-in converters instead of trying to handle everything as a string. 18 | - Async and LWT support are built in, no need to write your own IO module. 19 | - Mirage OS is supported via Pgx_lwt_mirage 20 | 21 | We also provide a relatively high-level interface, like `Pgx_async.execute_pipe`, 22 | which prepares a statement, executes it with the given parameters, returns an 23 | `Async.Pipe.Reader.t` (so you can stream results), and unprepares the statement 24 | when the query is finished. 25 | 26 | Significant portions of the code come from [PG'Ocaml](http://pgocaml.forge.ocamlcore.org/). 27 | 28 | ## Setup 29 | 30 | ``` 31 | opam install pgx_async # or pgx_lwt_unix or pgx_unix or pgx_lwt_mirage 32 | ``` 33 | 34 | ## Examples 35 | 36 | See [pgx_async/bin/pgx_async_example.ml](pgx_async/bin/pgx_async_example.ml) for 37 | a complete example of the high-level functional interface. To translate the 38 | example to Lwt, replace `Pgx_async` with `Pgx_lwt` and `>>|` with `>|=`. To 39 | translate it to synchronous IO / standard-library-only, use `Pgx_unix` and 40 | replace both `>>|` and `>>=` with `|>`, or just replace `>>| fun () ->` with `;`. 41 | 42 | I.e. in `Pgx_unix`, you can replace: 43 | 44 | ```ocaml 45 | Pgx_async.execute ~params "INSERT INTO ..." 46 | >>| fun () -> 47 | ``` 48 | 49 | ... with: 50 | 51 | ```ocaml 52 | Pgx_unix.execute ~params "INSERT INTO ..."; 53 | ``` 54 | -------------------------------------------------------------------------------- /doc/doc.odocl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/arenadotio/pgx/2bdd5182142d79710d53bf7c4da2a1f066f71590/doc/doc.odocl -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.2) 2 | 3 | (name pgx) 4 | 5 | (generate_opam_files true) 6 | 7 | (license "LGPL-2.0-only with OCaml-LGPL-linking-exception") 8 | 9 | (maintainers "Arena Developers ") 10 | 11 | (authors "Arena Developers ") 12 | 13 | (source 14 | (github arenadotio/pgx)) 15 | 16 | (documentation "https://arenadotio.github.io/pgx") 17 | 18 | (package 19 | (name pgx) 20 | (synopsis "Pure-OCaml PostgreSQL client library") 21 | (description 22 | "PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or synchronous operations.") 23 | (depends 24 | (alcotest 25 | (and 26 | :with-test 27 | (>= 1.0.0))) 28 | (bisect_ppx 29 | (and 30 | :dev 31 | (>= 2.0.0))) 32 | (dune 33 | (>= 3.2)) 34 | hex 35 | ipaddr 36 | camlp-streams 37 | (ocaml 38 | (>= 4.08)) 39 | (odoc :with-doc) 40 | (ppx_compare 41 | (>= v0.13.0)) 42 | (ppx_custom_printf 43 | (>= v0.13.0)) 44 | (ppx_sexp_conv 45 | (>= v0.13.0)) 46 | (re 47 | (>= 1.5.0)) 48 | (sexplib0 49 | (>= v0.13.0)) 50 | uuidm)) 51 | 52 | (package 53 | (name pgx_unix) 54 | (synopsis 55 | "PGX using the standard library's Unix module for IO (synchronous)") 56 | (description 57 | "PGX using the standard library's Unix module for IO (synchronous)") 58 | (depends 59 | (alcotest 60 | (and 61 | :with-test 62 | (>= 1.0.0))) 63 | (base64 64 | (and 65 | :with-test 66 | (>= 3.0.0))) 67 | (ocaml 68 | (>= 4.08)) 69 | (pgx 70 | (= :version)))) 71 | 72 | (package 73 | (name pgx_async) 74 | (synopsis "Pgx using Async for IO") 75 | (description "Pgx using Async for IO") 76 | (depends 77 | (alcotest-async 78 | (and 79 | :with-test 80 | (>= "1.0.0"))) 81 | (async_kernel 82 | (>= "v0.13.0")) 83 | (async_unix 84 | (>= "v0.13.0")) 85 | async_ssl 86 | (base64 87 | (and 88 | :with-test 89 | (>= 3.0.0))) 90 | (conduit-async 91 | (>= 1.5.0)) 92 | (ocaml 93 | (>= 4.08)) 94 | (pgx 95 | (= :version)) 96 | (pgx_value_core 97 | (= :version)))) 98 | 99 | (package 100 | (name pgx_lwt) 101 | (synopsis "Pgx using Lwt for IO") 102 | (description "Pgx using Lwt for IO") 103 | (depends 104 | lwt 105 | logs 106 | (ocaml 107 | (>= 4.08)) 108 | (pgx 109 | (= :version)))) 110 | 111 | (package 112 | (name pgx_lwt_unix) 113 | (synopsis "Pgx using Lwt and Unix libraries for IO") 114 | (description "Pgx using Lwt and Unix libraries for IO") 115 | (depends 116 | (alcotest-lwt 117 | (and 118 | :with-test 119 | (>= "1.0.0"))) 120 | (base64 121 | (and 122 | :with-test 123 | (>= 3.0.0))) 124 | (ocaml 125 | (>= 4.08)) 126 | (pgx 127 | (= :version)) 128 | (pgx_lwt 129 | (= :version)))) 130 | 131 | (package 132 | (name pgx_value_core) 133 | (synopsis "Pgx_value converters for Core types like Date and Time") 134 | (description "Pgx_value converters for Core types like Date and Time") 135 | (depends 136 | (alcotest 137 | (and 138 | :with-test 139 | (>= 1.0.0))) 140 | (core_kernel 141 | (>= "v0.13.0")) 142 | (ocaml 143 | (>= 4.08)) 144 | (pgx 145 | (= :version)))) 146 | 147 | (package 148 | (name pgx_value_ptime) 149 | (synopsis "Pgx_value converters for Ptime types") 150 | (description "Pgx_value converters for Ptime types") 151 | (depends 152 | (alcotest 153 | (and 154 | :with-test 155 | (>= 1.0.0))) 156 | (ptime 157 | (>= 0.8.3)) 158 | (ocaml 159 | (>= 4.08)) 160 | (pgx 161 | (= :version)))) 162 | 163 | (package 164 | (name pgx_lwt_mirage) 165 | (synopsis "Pgx using Lwt on Mirage for IO") 166 | (description "Pgx using Lwt on Mirage for IO") 167 | (depends 168 | lwt 169 | (ocaml 170 | (>= 4.08)) 171 | logs 172 | mirage-channel 173 | (conduit-mirage 174 | (>= 2.3.0)) 175 | (dns-client 176 | (>= 6.0.0)) 177 | mirage-random 178 | mirage-time 179 | mirage-clock 180 | (tcpip 181 | (>= 7.0.0)) 182 | (pgx 183 | (= :version)) 184 | (pgx_lwt 185 | (= :version)))) 186 | -------------------------------------------------------------------------------- /pgx.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Pure-OCaml PostgreSQL client library" 4 | description: 5 | "PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or synchronous operations." 6 | maintainer: ["Arena Developers "] 7 | authors: ["Arena Developers "] 8 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 9 | homepage: "https://github.com/arenadotio/pgx" 10 | doc: "https://arenadotio.github.io/pgx" 11 | bug-reports: "https://github.com/arenadotio/pgx/issues" 12 | depends: [ 13 | "alcotest" {with-test & >= "1.0.0"} 14 | "bisect_ppx" {dev & >= "2.0.0"} 15 | "dune" {>= "3.2" & >= "3.2"} 16 | "hex" 17 | "ipaddr" 18 | "camlp-streams" 19 | "ocaml" {>= "4.08"} 20 | "odoc" {with-doc} 21 | "ppx_compare" {>= "v0.13.0"} 22 | "ppx_custom_printf" {>= "v0.13.0"} 23 | "ppx_sexp_conv" {>= "v0.13.0"} 24 | "re" {>= "1.5.0"} 25 | "sexplib0" {>= "v0.13.0"} 26 | "uuidm" 27 | ] 28 | build: [ 29 | ["dune" "subst"] {dev} 30 | [ 31 | "dune" 32 | "build" 33 | "-p" 34 | name 35 | "-j" 36 | jobs 37 | "@install" 38 | "@runtest" {with-test} 39 | "@doc" {with-doc} 40 | ] 41 | ] 42 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 43 | -------------------------------------------------------------------------------- /pgx/src/access.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Read_write 3 | | Read_only 4 | [@@deriving sexp] 5 | 6 | let to_string = function 7 | | Read_write -> "read write" 8 | | Read_only -> "read only" 9 | ;; 10 | -------------------------------------------------------------------------------- /pgx/src/access.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Read_write 3 | | Read_only 4 | [@@deriving sexp] 5 | 6 | val to_string : t -> string 7 | -------------------------------------------------------------------------------- /pgx/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "bisect_ppx" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx) 13 | (libraries hex ipaddr uuidm re sexplib0 camlp-streams) 14 | (preprocess (pps ppx_compare ppx_custom_printf ppx_sexp_conv |} ^ preprocess ^ {|))) 15 | |} 16 | -------------------------------------------------------------------------------- /pgx/src/error_response.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Sexplib0.Sexp_conv 3 | open Pgx_aux 4 | 5 | type t = 6 | { code : string 7 | ; severity : string 8 | ; message : string 9 | ; custom : (char * string) list 10 | } 11 | [@@deriving sexp] 12 | 13 | let should_print t ~verbose = 14 | if verbose < 1 15 | then false 16 | else if verbose = 1 17 | then ( 18 | match t.severity with 19 | | "ERROR" | "FATAL" | "PANIC" -> true 20 | | _ -> false) 21 | else true 22 | ;; 23 | 24 | let to_string ?(verbose = false) t = 25 | let msg = sprintf "%s: %s: %s" t.severity t.code t.message in 26 | let field_info = 27 | if verbose 28 | then List.map (fun (field_type, field) -> sprintf "%c: %s" field_type field) t.custom 29 | else [] 30 | in 31 | String.concat "\n" (msg :: field_info) 32 | ;; 33 | -------------------------------------------------------------------------------- /pgx/src/error_response.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | { code : string 3 | ; severity : string 4 | ; message : string 5 | ; custom : (char * string) list 6 | } 7 | [@@deriving sexp] 8 | 9 | val should_print : t -> verbose:int -> bool 10 | val to_string : ?verbose:bool -> t -> string 11 | -------------------------------------------------------------------------------- /pgx/src/io_intf.ml: -------------------------------------------------------------------------------- 1 | (** The interface implemented by IO backends (Async, Lwt, Unix, etc.) *) 2 | module type S = sig 3 | type 'a t 4 | 5 | val return : 'a -> 'a t 6 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 7 | val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t 8 | 9 | type in_channel 10 | type out_channel 11 | 12 | type sockaddr = 13 | | Unix of string 14 | | Inet of string * int 15 | 16 | val open_connection : sockaddr -> (in_channel * out_channel) t 17 | 18 | type ssl_config 19 | 20 | val upgrade_ssl 21 | : [ `Not_supported 22 | | `Supported of 23 | ?ssl_config:ssl_config 24 | -> in_channel 25 | -> out_channel 26 | -> (in_channel * out_channel) t 27 | ] 28 | 29 | val output_char : out_channel -> char -> unit t 30 | val output_binary_int : out_channel -> int -> unit t 31 | val output_string : out_channel -> string -> unit t 32 | val flush : out_channel -> unit t 33 | val input_char : in_channel -> char t 34 | val input_binary_int : in_channel -> int t 35 | val really_input : in_channel -> Bytes.t -> int -> int -> unit t 36 | val close_in : in_channel -> unit t 37 | val getlogin : unit -> string t 38 | val debug : string -> unit t 39 | val protect : (unit -> 'a t) -> finally:(unit -> unit t) -> 'a t 40 | 41 | module Sequencer : sig 42 | type 'a monad = 'a t 43 | type 'a t 44 | 45 | val create : 'a -> 'a t 46 | val enqueue : 'a t -> ('a -> 'b monad) -> 'b monad 47 | end 48 | end 49 | -------------------------------------------------------------------------------- /pgx/src/isolation.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Serializable 3 | | Repeatable_read 4 | | Read_committed 5 | | Read_uncommitted 6 | [@@deriving sexp] 7 | 8 | let to_string = function 9 | | Serializable -> "serializable" 10 | | Repeatable_read -> "repeatable read" 11 | | Read_committed -> "read committed" 12 | | Read_uncommitted -> "read uncommitted" 13 | ;; 14 | -------------------------------------------------------------------------------- /pgx/src/isolation.mli: -------------------------------------------------------------------------------- 1 | (** Database transaction isolation levels *) 2 | type t = 3 | | Serializable 4 | | Repeatable_read 5 | | Read_committed 6 | | Read_uncommitted 7 | [@@deriving sexp] 8 | 9 | val to_string : t -> string 10 | -------------------------------------------------------------------------------- /pgx/src/pgx.ml: -------------------------------------------------------------------------------- 1 | (* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. 2 | * 3 | * PG'OCaml - type safe interface to PostgreSQL. 4 | * Copyright (C) 2005-2009 Richard Jones and other authors. 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Library General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Library General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this library; see the file COPYING. If not, write to 18 | * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 | * Boston, MA 02111-1307, USA. 20 | *) 21 | 22 | open Pgx_aux 23 | open Printf 24 | open Sexplib0.Sexp_conv 25 | include Types 26 | module Isolation = Isolation 27 | module Access = Access 28 | 29 | module Ready = struct 30 | type t = 31 | | Idle 32 | | In_transaction 33 | | Error 34 | | Other of char 35 | [@@deriving sexp] 36 | 37 | let of_char = function 38 | | 'I' -> Idle 39 | | 'T' -> In_transaction 40 | | 'E' -> Error 41 | | c -> Other c 42 | ;; 43 | end 44 | 45 | module Result_desc = Result_desc 46 | 47 | (* We get a message from postgres that we didn't expect. Almost always a bug 48 | in our bindings *) 49 | exception Unexpected_message of string [@@deriving sexp] 50 | 51 | let fail_msg fmt = ksprintf (fun m -> raise (Unexpected_message m)) fmt 52 | 53 | exception Parsing_failure of string [@@deriving sexp] 54 | 55 | let fail_parse str = raise (Parsing_failure str) 56 | 57 | module Error_response = Error_response 58 | 59 | module Message_in = struct 60 | type copy_format = 61 | | Text 62 | | Binary 63 | [@@deriving sexp] 64 | 65 | type t = 66 | | AuthenticationOk 67 | | AuthenticationKerberosV5 68 | | AuthenticationCleartextPassword 69 | | AuthenticationCryptPassword of string 70 | | AuthenticationMD5Password of string 71 | | AuthenticationSCMCredential 72 | | AuthenticationSASLCredential 73 | | BackendKeyData of int32 * int32 74 | | BindComplete 75 | | CloseComplete 76 | | CommandComplete of string 77 | | CopyOutResponse of (copy_format * copy_format list) 78 | | CopyData of string 79 | | CopyDone 80 | | DataRow of string option list 81 | | EmptyQueryResponse 82 | | ErrorResponse of Error_response.t 83 | | NoData 84 | | NoticeResponse of (char * string) list 85 | | ParameterDescription of int32 list 86 | | ParameterStatus of string * string 87 | | ParseComplete 88 | | ReadyForQuery of Ready.t 89 | | RowDescription of Row_desc.t list 90 | | UnknownMessage of char * string 91 | [@@deriving sexp] 92 | 93 | let to_string t = Sexplib0.Sexp.to_string_hum (sexp_of_t t) 94 | 95 | let read (typ, msg) = 96 | let pos = ref 0 in 97 | let len = String.length msg in 98 | let get_char where = 99 | if !pos < len 100 | then ( 101 | let r = msg.[!pos] in 102 | incr pos; 103 | r) 104 | else fail_parse ("Pgx: parse_backend_message: " ^ where ^ ": short message") 105 | in 106 | let get_byte where = Char.code (get_char where) in 107 | let get_int8 () = get_byte "get_int8" in 108 | let get_int16 () = 109 | let r0 = get_byte "get_int16" in 110 | let r1 = get_byte "get_int16" in 111 | (r0 lsr 8) + r1 112 | in 113 | let get_int32 () = 114 | let r0 = get_byte "get_int32" in 115 | let r1 = get_byte "get_int32" in 116 | let r2 = get_byte "get_int32" in 117 | let r3 = get_byte "get_int32" in 118 | let r = Int32.of_int r0 in 119 | let r = Int32.shift_left r 8 in 120 | let r = Int32.logor r (Int32.of_int r1) in 121 | let r = Int32.shift_left r 8 in 122 | let r = Int32.logor r (Int32.of_int r2) in 123 | let r = Int32.shift_left r 8 in 124 | let r = Int32.logor r (Int32.of_int r3) in 125 | r 126 | in 127 | let get_string () = 128 | let buf = Buffer.create 16 in 129 | let rec loop () = 130 | let c = get_char "get_string" in 131 | if c <> '\000' 132 | then ( 133 | Buffer.add_char buf c; 134 | loop ()) 135 | else Buffer.contents buf 136 | in 137 | loop () 138 | in 139 | let get_n_bytes n = String.init n (fun _ -> get_char "get_n_bytes") in 140 | let get_char () = get_char "get_char" in 141 | let get_many f = 142 | let num = get_int16 () in 143 | let fields = ref [] in 144 | for _ = 0 to num - 1 do 145 | fields := f () :: !fields 146 | done; 147 | List.rev !fields 148 | in 149 | let msg = 150 | match typ with 151 | | 'R' -> 152 | (match get_int32 () with 153 | | 0l -> AuthenticationOk 154 | | 2l -> AuthenticationKerberosV5 155 | | 3l -> AuthenticationCleartextPassword 156 | | 4l -> AuthenticationCryptPassword (get_n_bytes 2) 157 | | 5l -> AuthenticationMD5Password (get_n_bytes 4) 158 | | 6l -> AuthenticationSCMCredential 159 | | 10l -> AuthenticationSASLCredential 160 | | _ -> UnknownMessage (typ, msg)) 161 | | 'H' -> 162 | let format_code_to_format = function 163 | | 0 -> Text 164 | | 1 -> Binary 165 | | format_code -> fail_msg "Unused CopyOutResponse format: %d" format_code 166 | in 167 | let format_ = format_code_to_format (get_int8 ()) in 168 | let formats = get_many (fun () -> format_code_to_format (get_int16 ())) in 169 | CopyOutResponse (format_, formats) 170 | | 'd' -> CopyData (get_n_bytes len) 171 | | 'c' -> CopyDone 172 | | 'E' -> 173 | let acc = [| ""; ""; "" |] in 174 | let others = ref [] in 175 | let rec loop () = 176 | match get_char () with 177 | | '\000' -> 178 | { Error_response.code = acc.(0) 179 | ; severity = acc.(1) 180 | ; message = acc.(2) 181 | ; custom = !others 182 | } 183 | | 'C' -> 184 | acc.(0) <- get_string (); 185 | loop () 186 | | 'S' -> 187 | acc.(1) <- get_string (); 188 | loop () 189 | | 'M' -> 190 | acc.(2) <- get_string (); 191 | loop () 192 | | c -> 193 | others := (c, get_string ()) :: !others; 194 | loop () 195 | in 196 | ErrorResponse (loop ()) 197 | | 'N' -> 198 | let strs = ref [] in 199 | let rec loop () = 200 | let field_type = get_char () in 201 | if field_type = '\000' 202 | then List.rev !strs (* end of list *) 203 | else ( 204 | strs := (field_type, get_string ()) :: !strs; 205 | loop ()) 206 | in 207 | NoticeResponse (loop ()) 208 | | 'Z' -> ReadyForQuery (Ready.of_char (get_char ())) 209 | | 'K' -> 210 | let pid = get_int32 () in 211 | let key = get_int32 () in 212 | BackendKeyData (pid, key) 213 | | 'S' -> 214 | let param = get_string () in 215 | let value = get_string () in 216 | ParameterStatus (param, value) 217 | | '1' -> ParseComplete 218 | | '2' -> BindComplete 219 | | '3' -> CloseComplete 220 | | 'C' -> CommandComplete (get_string ()) 221 | | 'D' -> 222 | DataRow 223 | (get_many (fun () -> 224 | let len = get_int32 () in 225 | if len < 0l 226 | then None 227 | else ( 228 | if len >= 0x4000_0000l then fail_parse "Pgx: result field is too long"; 229 | let len = Int32.to_int len in 230 | if len > Sys.max_string_length 231 | then fail_parse "Pgx: result field is too wide for string"; 232 | let bytes = get_n_bytes len in 233 | Some bytes))) 234 | | 'I' -> EmptyQueryResponse 235 | | 'n' -> NoData 236 | | 'T' -> 237 | RowDescription 238 | (get_many (fun () -> 239 | let name = get_string () in 240 | let table = get_int32 () in 241 | let col = get_int16 () in 242 | let oid = get_int32 () in 243 | let len = get_int16 () in 244 | let modifier = get_int32 () in 245 | let format = get_int16 () in 246 | { Row_desc.name; table; col; oid; len; modifier; format })) 247 | | 't' -> ParameterDescription (get_many get_int32) 248 | | _ -> UnknownMessage (typ, msg) 249 | in 250 | msg 251 | ;; 252 | end 253 | 254 | module Message_out = struct 255 | type prepare = 256 | { name : string 257 | ; query : string 258 | ; types : oid list 259 | } 260 | [@@deriving sexp] 261 | 262 | type portal = string [@@deriving sexp] 263 | type statement = string [@@deriving sexp] 264 | type query = string [@@deriving sexp] 265 | 266 | type bind = 267 | { portal : string 268 | ; name : string 269 | ; params : string option list 270 | } 271 | [@@deriving sexp] 272 | 273 | type startup = 274 | { user : string 275 | ; database : string 276 | } 277 | [@@deriving sexp] 278 | 279 | type t = 280 | | Password of string (* p *) 281 | | Close (* X *) 282 | | Sync (* S *) 283 | | Flush (* H *) 284 | | Prepare of prepare (* P *) 285 | | Execute of portal (* E *) 286 | | Bind of bind (* B *) 287 | | Close_statement of statement (* CP *) 288 | | Close_portal of portal (* CS *) 289 | | Describe_statement of statement (* DS *) 290 | | Describe_portal of portal (* DP *) 291 | | Startup_message of startup 292 | | Simple_query of query 293 | | SSLRequest 294 | [@@deriving sexp] 295 | 296 | let add_byte buf i = 297 | (* Deliberately throw an exception if i isn't [0..255]. *) 298 | Buffer.add_char buf (Char.chr i) 299 | ;; 300 | 301 | let add_int16 buf i = 302 | if i < 0 || i > 65_535 then fail_msg "Pgx: int16 %d is outside range [0..65535]." i; 303 | Buffer.add_char buf (Char.unsafe_chr ((i lsr 8) land 0xff)); 304 | Buffer.add_char buf (Char.unsafe_chr (i land 0xff)) 305 | ;; 306 | 307 | let add_int32 buf i = 308 | let base = Int32.to_int i in 309 | let big = Int32.to_int (Int32.shift_right_logical i 24) in 310 | Buffer.add_char buf (Char.unsafe_chr (big land 0xff)); 311 | Buffer.add_char buf (Char.unsafe_chr ((base lsr 16) land 0xff)); 312 | Buffer.add_char buf (Char.unsafe_chr ((base lsr 8) land 0xff)); 313 | Buffer.add_char buf (Char.unsafe_chr (base land 0xff)) 314 | ;; 315 | 316 | let check_str str = 317 | (* Check the string doesn't contain '\0' characters. *) 318 | if String.contains str '\000' 319 | then fail_msg "Pgx: string contains ASCII NIL character: %S" str; 320 | if String.length str > 0x3fff_ffff then fail_msg "Pgx: string is too long." 321 | ;; 322 | 323 | let add_string_no_trailing_nil buf str = 324 | check_str str; 325 | Buffer.add_string buf str 326 | ;; 327 | 328 | let add_string msg str = 329 | add_string_no_trailing_nil msg str; 330 | add_byte msg 0 331 | ;; 332 | 333 | let str s = 334 | check_str s; 335 | s ^ "\000" 336 | ;; 337 | 338 | let to_packet = function 339 | | Password p -> Some 'p', str p 340 | | Close -> Some 'X', "" 341 | | Sync -> Some 'S', "" 342 | | Flush -> Some 'H', "" 343 | | Prepare { name; query; types } -> 344 | let msg = Buffer.create 128 in 345 | add_string msg name; 346 | add_string msg query; 347 | add_int16 msg (List.length types); 348 | List.iter (add_int32 msg) types; 349 | Some 'P', Buffer.contents msg 350 | | Execute portal -> 351 | let msg = Buffer.create 128 in 352 | add_string msg portal; 353 | add_int32 msg 0l; 354 | (* no limit on rows *) 355 | Some 'E', Buffer.contents msg 356 | | Bind { portal; name; params } -> 357 | let msg = Buffer.create 128 in 358 | add_string msg portal; 359 | add_string msg name; 360 | add_int16 msg 0; 361 | (* Send all parameters as text. *) 362 | add_int16 msg (List.length params); 363 | List.iter 364 | (function 365 | | None -> add_int32 msg 0xffff_ffffl (* NULL *) 366 | | Some str -> 367 | add_int32 msg (Int32.of_int (String.length str)); 368 | add_string_no_trailing_nil msg str) 369 | params; 370 | add_int16 msg 0; 371 | (* Send back all results as text. *) 372 | Some 'B', Buffer.contents msg 373 | | Close_statement statement -> Some 'C', "S" ^ str statement 374 | | Close_portal portal -> Some 'C', "P" ^ str portal 375 | | Describe_statement statement -> Some 'D', "S" ^ str statement 376 | | Describe_portal portal -> Some 'D', "S" ^ str portal 377 | | Startup_message { user; database } -> 378 | let msg = Buffer.create 64 in 379 | add_int32 msg 196608l; 380 | add_string msg "user"; 381 | add_string msg user; 382 | add_string msg "database"; 383 | add_string msg database; 384 | add_byte msg 0; 385 | None, Buffer.contents msg 386 | | Simple_query q -> Some 'Q', str q 387 | | SSLRequest -> 388 | let msg = Buffer.create 8 in 389 | add_int32 msg 80877103l; 390 | None, Buffer.contents msg 391 | ;; 392 | end 393 | 394 | module Value = Pgx_value 395 | 396 | module type Io = Io_intf.S 397 | module type S = Pgx_intf.S 398 | 399 | module Make (Thread : Io) = struct 400 | module Io = Thread 401 | open Io 402 | 403 | type conn = 404 | { ichan : (in_channel[@sexp.opaque] (* In_channel wrapping socket. *)) 405 | ; chan : (out_channel[@sexp.opaque] (* Out_channel wrapping socket. *)) 406 | ; id : int (* unique id for this connection. *) 407 | ; mutable in_transaction : bool 408 | ; verbose : int 409 | ; max_message_length : int 410 | ; mutable prepared_num : int64 (* Used to generate statement names *) 411 | } 412 | [@@deriving sexp_of] 413 | 414 | type t = conn Sequencer.t 415 | 416 | let ( >>| ) x f = x >>= fun x -> return (f x) 417 | 418 | (* If true, emit a lot of debugging information about the protocol on 419 | stderr.*) 420 | let debug_protocol = 421 | try 422 | ignore (Sys.getenv "PGX_DEBUG" : string); 423 | true 424 | with 425 | | Not_found -> false 426 | ;; 427 | 428 | let send_message { chan; _ } msg = 429 | let typ, msg = Message_out.to_packet msg in 430 | (* Get the length in bytes. *) 431 | let len = 4 + String.length msg in 432 | (* If the length is longer than a 31 bit integer, then the message is 433 | * too long to send. This limits messages to 1 GB, which should be 434 | * enough for anyone :-) 435 | *) 436 | if Int64.of_int len >= 0x4000_0000L then fail_msg "Pgx: message is larger than 1 GB"; 437 | (if debug_protocol 438 | then 439 | Thread.debug 440 | (sprintf 441 | "> %s%d %S" 442 | (match typ with 443 | | None -> "" 444 | | Some c -> sprintf "%c " c) 445 | len 446 | msg) 447 | else return ()) 448 | >>= fun () -> 449 | (* Write the type byte? *) 450 | (match typ with 451 | | None -> Thread.return () 452 | | Some c -> output_char chan c) 453 | >>= fun () -> 454 | (* Write the length field. *) 455 | output_binary_int chan len 456 | >>= fun () -> 457 | (* Write the buffer. *) 458 | output_string chan msg 459 | ;; 460 | 461 | (* TODO possibly not write if empty *) 462 | 463 | (* Receive a single result message. Parse out the message type, 464 | * message length, and binary message content. 465 | *) 466 | let receive_message { ichan; chan; max_message_length; _ } = 467 | (* Flush output buffer. *) 468 | flush chan 469 | >>= fun () -> 470 | input_char ichan 471 | >>= fun typ -> 472 | input_binary_int ichan 473 | >>= fun len -> 474 | (* Discount the length word itself. *) 475 | let len = len - 4 in 476 | (* If the message is too long, give up now. *) 477 | if len > max_message_length 478 | then ( 479 | (* Skip the message so we stay in synch with the stream. *) 480 | let bufsize = 65_536 in 481 | let buf = Bytes.create bufsize in 482 | let rec loop n = 483 | if n > 0 484 | then ( 485 | let m = min n bufsize in 486 | really_input ichan buf 0 m >>= fun () -> loop (n - m)) 487 | else return () 488 | in 489 | loop len 490 | >>= fun () -> fail_parse "Pgx: back-end message is longer than max_message_length") 491 | else ( 492 | (* Read the binary message content. *) 493 | let msg = Bytes.create len in 494 | really_input ichan msg 0 len 495 | >>= fun () -> 496 | let msg = Message_in.read (typ, Bytes.to_string msg) in 497 | (if debug_protocol 498 | then Thread.debug (sprintf "< %s" (Message_in.to_string msg)) 499 | else return ()) 500 | >>| fun () -> msg) 501 | ;; 502 | 503 | (* Send a message and expect a single result. *) 504 | let send_recv conn msg = send_message conn msg >>= fun () -> receive_message conn 505 | 506 | (* Handle an ErrorResponse anywhere, by printing and raising an exception. *) 507 | let pg_error ?(sync = false) ~conn fields = 508 | (if Error_response.should_print fields ~verbose:conn.verbose 509 | then Thread.debug (Error_response.to_string ~verbose:(conn.verbose > 1) fields) 510 | else return ()) 511 | >>= fun () -> 512 | (* If conn parameter was given, then resynch - read messages until we 513 | * see ReadyForQuery. *) 514 | let rec loop () = 515 | receive_message conn 516 | >>= function 517 | | Message_in.ReadyForQuery _ -> return () 518 | | _ -> loop () 519 | in 520 | (if sync then send_message conn Message_out.Sync else return ()) 521 | >>= loop 522 | >>= fun () -> raise (PostgreSQL_Error (Error_response.to_string fields, fields)) 523 | ;; 524 | 525 | let next_id = 526 | let id = ref 0 in 527 | fun () -> 528 | (* In OCaml this doesn't allocate, and threads can't context switch except on 529 | allocation *) 530 | incr id; 531 | !id 532 | ;; 533 | 534 | (*----- Connection. -----*) 535 | 536 | let attempt_tls_upgrade ?(ssl = `Auto) ({ ichan; chan; _ } as conn) = 537 | (* To initiate an SSL-encrypted connection, the frontend initially sends an SSLRequest message rather than a 538 | StartupMessage. The server then responds with a single byte containing S or N, indicating that it is willing 539 | or unwilling to perform SSL, respectively. The frontend might close the connection at this point if it is 540 | dissatisfied with the response. To continue after S, perform an SSL startup handshake (not described here, 541 | part of the SSL specification) with the server. If this is successful, continue with sending the usual 542 | StartupMessage. In this case the StartupMessage and all subsequent data will be SSL-encrypted. To continue 543 | after N, send the usual StartupMessage and proceed without encryption. 544 | See https://www.postgresql.org/docs/9.3/protocol-flow.html#AEN100021 *) 545 | match ssl with 546 | | `No -> return conn 547 | | (`Auto | `Always _) as ssl -> 548 | (match Io.upgrade_ssl with 549 | | `Not_supported -> 550 | (match ssl with 551 | | `Always _ -> 552 | failwith 553 | "TLS support is not compiled into this Pgx library but ~ssl was set to \ 554 | `Always" 555 | | _ -> ()); 556 | debug 557 | "TLS-support is not compiled into this Pgx library, not attempting to upgrade" 558 | >>| fun () -> conn 559 | | `Supported upgrade_ssl -> 560 | debug "Request SSL upgrade from server" 561 | >>= fun () -> 562 | let msg = Message_out.SSLRequest in 563 | send_message conn msg 564 | >>= fun () -> 565 | flush chan 566 | >>= fun () -> 567 | input_char ichan 568 | >>= (function 569 | | 'S' -> 570 | debug "Server supports TLS, attempting to upgrade" 571 | >>= fun () -> 572 | let ssl_config = 573 | match ssl with 574 | | `Auto -> None 575 | | `Always ssl_config -> Some ssl_config 576 | in 577 | upgrade_ssl ?ssl_config ichan chan 578 | >>= fun (ichan, chan) -> return { conn with ichan; chan } 579 | | 'N' -> debug "Server does not support TLS, not upgrading" >>| fun () -> conn 580 | | c -> 581 | fail_msg 582 | "Got unexpected response '%c' from server after SSLRequest message. Response \ 583 | should always be 'S' or 'N'." 584 | c)) 585 | ;; 586 | 587 | let connect 588 | ?ssl 589 | ?host 590 | ?port 591 | ?user 592 | ?password 593 | ?database 594 | ?(unix_domain_socket_dir = "/tmp") 595 | ?verbose 596 | ?(max_message_length = Sys.max_string_length) 597 | () 598 | = 599 | (* Get the username. *) 600 | (match user with 601 | | Some user -> return user 602 | | None -> 603 | (try return (Sys.getenv "PGUSER") with 604 | | Not_found -> Thread.getlogin ())) 605 | >>= fun user -> 606 | (* Get the password. *) 607 | let password = 608 | match password with 609 | | Some password -> password 610 | | None -> 611 | (try Sys.getenv "PGPASSWORD" with 612 | | Not_found -> "") 613 | in 614 | (* Get the database name. *) 615 | let database = 616 | match database with 617 | | Some database -> database 618 | | None -> 619 | (try Sys.getenv "PGDATABASE" with 620 | | Not_found -> user) 621 | in 622 | (* Get socket address using hostname and port number. *) 623 | let sockaddr = 624 | let port = 625 | match port with 626 | | Some port -> port 627 | | None -> 628 | (try int_of_string (Sys.getenv "PGPORT") with 629 | | Not_found | Failure _ -> 5432) 630 | in 631 | match host with 632 | | Some name -> Inet (name, port) 633 | | None -> 634 | (try Inet (Sys.getenv "PGHOST", port) with 635 | | Not_found -> 636 | (* use Unix domain socket. *) 637 | let path = sprintf "%s/.s.PGSQL.%d" unix_domain_socket_dir port in 638 | Unix path) 639 | in 640 | (* Get the verbosity level *) 641 | let verbose = 642 | match verbose with 643 | | Some verbose -> verbose 644 | | None -> 645 | (try Sys.getenv "PGD_PGX_VERBOSE" |> int_of_string with 646 | | Not_found -> 0) 647 | in 648 | let id = next_id () in 649 | open_connection sockaddr 650 | >>= fun (ichan, chan) -> 651 | (* Create the connection structure. *) 652 | let conn = 653 | { ichan 654 | ; chan 655 | ; id 656 | ; in_transaction = false 657 | ; verbose 658 | ; max_message_length 659 | ; prepared_num = Int64.of_int 0 660 | } 661 | in 662 | attempt_tls_upgrade ?ssl conn 663 | >>= fun conn -> 664 | (* Send the StartUpMessage. NB. At present we do not support SSL. *) 665 | let msg = Message_out.Startup_message { Message_out.user; database } in 666 | (* Loop around here until the database gives a ReadyForQuery message. *) 667 | let rec loop msg = 668 | (match msg with 669 | | Some msg -> send_recv conn msg 670 | | None -> receive_message conn) 671 | >>= function 672 | | Message_in.ReadyForQuery _ -> return () (* Finished connecting! *) 673 | | Message_in.BackendKeyData _ -> 674 | (* XXX We should save this key. *) 675 | loop None 676 | | Message_in.ParameterStatus _ -> 677 | (* Should we do something with this? *) 678 | loop None 679 | | Message_in.AuthenticationOk -> loop None 680 | | Message_in.AuthenticationKerberosV5 -> 681 | fail_msg "Pgx: Kerberos authentication not supported" 682 | | Message_in.AuthenticationCleartextPassword -> 683 | loop (Some (Message_out.Password password)) 684 | | Message_in.AuthenticationCryptPassword _ -> 685 | (* Crypt password not supported because there is no crypt(3) function 686 | * in OCaml. 687 | *) 688 | fail_msg "Pgx: crypt password authentication not supported" 689 | | Message_in.AuthenticationMD5Password salt -> 690 | (* (* This is a guess at how the salt is used ... *) 691 | let password = salt ^ password in 692 | let password = Digest.string password in*) 693 | let digest = 694 | password ^ user 695 | |> Digest.string 696 | |> Digest.to_hex 697 | |> (fun x -> x ^ salt) 698 | |> Digest.string 699 | |> Digest.to_hex 700 | in 701 | let password = "md5" ^ digest in 702 | loop (Some (Message_out.Password password)) 703 | | Message_in.AuthenticationSCMCredential -> 704 | fail_msg "Pgx: SCM Credential authentication not supported" 705 | | Message_in.AuthenticationSASLCredential -> 706 | fail_msg "Pgx: SASL Credential authentication not supported" 707 | | Message_in.ErrorResponse err -> 708 | raise (PostgreSQL_Error ("Failed to authenticate with postgres server", err)) 709 | | Message_in.NoticeResponse _ -> 710 | (* XXX Do or print something here? *) 711 | loop None 712 | | _ -> 713 | (* Silently ignore unknown or unexpected message types. *) 714 | loop None 715 | in 716 | loop (Some msg) >>| fun () -> Sequencer.create conn 717 | ;; 718 | 719 | let close seq = 720 | Sequencer.enqueue seq (fun conn -> 721 | (* Be nice and send the terminate message. *) 722 | send_message conn Message_out.Close 723 | >>= fun () -> 724 | flush conn.chan 725 | >>= fun () -> 726 | (* Closes the underlying socket too. *) 727 | close_in conn.ichan) 728 | ;; 729 | 730 | let with_conn 731 | ?ssl 732 | ?host 733 | ?port 734 | ?user 735 | ?password 736 | ?database 737 | ?unix_domain_socket_dir 738 | ?verbose 739 | ?max_message_length 740 | f 741 | = 742 | connect 743 | ?ssl 744 | ?host 745 | ?port 746 | ?user 747 | ?password 748 | ?database 749 | ?unix_domain_socket_dir 750 | ?verbose 751 | ?max_message_length 752 | () 753 | >>= fun dbh -> protect (fun () -> f dbh) ~finally:(fun () -> close dbh) 754 | ;; 755 | 756 | let sync conn = 757 | send_message conn Message_out.Sync 758 | >>= fun () -> 759 | let rec loop () = 760 | receive_message conn 761 | >>= function 762 | | Message_in.ReadyForQuery _ -> return () (* Finished! *) 763 | | Message_in.ErrorResponse err -> pg_error ~conn err (* Error *) 764 | | _ -> loop () 765 | in 766 | loop () 767 | ;; 768 | 769 | let ping seq = Sequencer.enqueue seq (fun conn -> sync conn) 770 | 771 | let alive conn = 772 | catch (fun () -> ping conn >>= fun () -> return true) (fun _ -> return false) 773 | ;; 774 | 775 | type param = Pgx_value.t [@@deriving compare, sexp_of] 776 | type result = Pgx_value.t [@@deriving compare, sexp_of] 777 | type row = result list [@@deriving compare, sexp_of] 778 | 779 | let flush_msg conn = 780 | send_message conn Message_out.Flush 781 | >>= fun () -> 782 | (* Might as well actually flush the channel too, otherwise what is the 783 | * point of executing this command? 784 | *) 785 | flush conn.chan 786 | ;; 787 | 788 | module Prepared = struct 789 | type s = 790 | { conn : (conn Sequencer.t[@sexp.opaque]) 791 | ; name : string 792 | } 793 | 794 | let sexp_of_s { name; _ } = 795 | Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom ""; sexp_of_string name ] 796 | ;; 797 | 798 | let prepare ?name ?(types = []) seq ~query = 799 | Sequencer.enqueue seq (fun conn -> 800 | let name = 801 | match name with 802 | | Some name -> name 803 | | None -> 804 | let n = conn.prepared_num in 805 | conn.prepared_num <- Int64.succ n; 806 | sprintf "pgx_prepared_%Ld" n 807 | in 808 | send_message conn (Message_out.Prepare { Message_out.name; query; types }) 809 | >>= fun () -> 810 | flush_msg conn 811 | >>= fun () -> 812 | let rec loop () = 813 | receive_message conn 814 | >>= function 815 | | Message_in.ErrorResponse err -> pg_error ~sync:true ~conn err 816 | | Message_in.ParseComplete -> 817 | (* Finished! *) 818 | return { conn = seq; name } 819 | | Message_in.NoticeResponse _ -> 820 | (* XXX Do or print something here? *) 821 | loop () 822 | | msg -> 823 | fail_msg "Pgx: unknown response from parse: %s" (Message_in.to_string msg) 824 | in 825 | loop ()) 826 | ;; 827 | 828 | let close { conn; name } = 829 | Sequencer.enqueue conn (fun conn -> 830 | send_message conn (Message_out.Close_statement name) 831 | >>= fun () -> 832 | flush_msg conn 833 | >>= fun () -> 834 | let rec loop () = 835 | receive_message conn 836 | >>= function 837 | | Message_in.ErrorResponse err -> pg_error ~conn err 838 | | Message_in.CloseComplete -> return () (* Finished! *) 839 | | Message_in.NoticeResponse _ -> 840 | (* XXX Do or print something here? *) 841 | loop () 842 | | m -> 843 | fail_msg "Pgx: unknown response from close: %s" (Message_in.to_string m) 844 | in 845 | loop ()) 846 | ;; 847 | 848 | let with_prepare ?name ?types t ~query ~f = 849 | prepare ?name ?types t ~query 850 | >>= fun s -> protect (fun () -> f s) ~finally:(fun () -> close s) 851 | ;; 852 | 853 | let execute_iter ?(portal = "") { name; conn } ~params ~f = 854 | let params = List.map Value.to_string params in 855 | Sequencer.enqueue conn (fun conn -> 856 | send_message conn (Message_out.Bind { Message_out.portal; name; params }) 857 | >>= fun () -> 858 | send_message conn (Message_out.Execute portal) 859 | >>= fun () -> 860 | send_message conn Message_out.Sync 861 | >>= fun () -> 862 | (* Process the message(s) received from the database until we read 863 | * ReadyForQuery. In the process we may get some rows back from 864 | * the database, no data, or an error. 865 | *) 866 | let rec loop () = 867 | (* NB: receive_message flushes the output connection. *) 868 | receive_message conn 869 | >>= function 870 | | Message_in.ReadyForQuery _ -> return () (* Finished! *) 871 | | Message_in.ErrorResponse err -> pg_error ~conn err (* Error *) 872 | | Message_in.NoticeResponse _ -> 873 | (* XXX Do or print something here? *) 874 | loop () 875 | | Message_in.BindComplete -> loop () 876 | | Message_in.CommandComplete _ -> loop () 877 | | Message_in.EmptyQueryResponse -> loop () 878 | | Message_in.DataRow fields -> 879 | List.map (fun v -> Option.bind v Value.of_string) fields |> f >>= loop 880 | | Message_in.NoData -> loop () 881 | | Message_in.ParameterStatus _ -> 882 | (* 43.2.6: ParameterStatus messages will be generated whenever 883 | * the active value changes for any of the parameters the backend 884 | * believes the frontend should know about. Most commonly this 885 | * occurs in response to a SET SQL command executed by the 886 | * frontend, and this case is effectively synchronous -- but it 887 | * is also possible for parameter status changes to occur because 888 | * the administrator changed a configuration file and then sent 889 | * the SIGHUP signal to the postmaster. 890 | *) 891 | loop () 892 | | Message_in.CopyOutResponse (format_, format_list) -> 893 | (match format_ with 894 | | Message_in.Text -> 895 | List.iter 896 | (function 897 | | Message_in.Binary -> 898 | fail_msg "Pgx.query: Binary column found in text CopyOutResponse" 899 | | _ -> ()) 900 | format_list; 901 | loop () 902 | | Message_in.Binary -> 903 | fail_msg 904 | "Pgx.iter_execute: CopyOutResponse for binary is not implemented yet") 905 | | Message_in.CopyData row -> 906 | f [ row |> Value.of_string ] >>= fun () -> loop () 907 | | Message_in.CopyDone -> loop () 908 | | m -> fail_msg "Pgx: unknown response message: %s" (Message_in.to_string m) 909 | in 910 | loop ()) 911 | ;; 912 | 913 | let execute_fold ?portal s ~params ~init ~f = 914 | let acc = ref init in 915 | execute_iter ?portal s ~params ~f:(fun fields -> 916 | f !acc fields >>| fun res -> acc := res) 917 | >>| fun () -> !acc 918 | ;; 919 | 920 | let execute_map ?portal s ~params ~f = 921 | execute_fold ?portal s ~params ~init:[] ~f:(fun acc row -> 922 | f row >>| fun res -> res :: acc) 923 | >>| List.rev 924 | ;; 925 | 926 | let execute ?portal s ~params = execute_map s ?portal ~params ~f:return 927 | 928 | let execute_unit ?portal s ~params = 929 | execute ?portal s ~params 930 | >>| function 931 | | [] | [ [] ] -> () 932 | | results -> 933 | fail_msg 934 | !"Pgx.execute_unit: Query returned a non-empty result but execute_unit was \ 935 | expecting no result and found '%{sexp:row list}'" 936 | results 937 | ;; 938 | 939 | let execute_many s ~params = 940 | List.fold_left 941 | (fun acc params -> 942 | acc >>= fun acc -> execute s ~params >>| fun results -> results :: acc) 943 | (return []) 944 | params 945 | >>| List.rev 946 | ;; 947 | 948 | let describe { conn; name } = 949 | Sequencer.enqueue conn (fun conn -> 950 | send_message conn (Message_out.Describe_statement name) 951 | >>= fun () -> 952 | flush_msg conn 953 | >>= fun () -> 954 | receive_message conn 955 | >>= (function 956 | | Message_in.ErrorResponse err -> pg_error ~sync:true ~conn err 957 | | Message_in.ParameterDescription params -> return params 958 | | msg -> 959 | fail_msg 960 | "Pgx: unknown response from describe: %s" 961 | (Message_in.to_string msg)) 962 | >>= fun params -> 963 | receive_message conn 964 | >>= function 965 | | Message_in.ErrorResponse err -> pg_error ~sync:true ~conn err 966 | | Message_in.NoData -> return (params, None) 967 | | Message_in.RowDescription fields -> 968 | let fields = List.map Result_desc.of_row_desc fields in 969 | return (params, Some fields) 970 | | msg -> 971 | fail_msg "Pgx: unknown response from describe: %s" (Message_in.to_string msg)) 972 | ;; 973 | 974 | let close_portal ?(portal = "") { conn; _ } = 975 | Sequencer.enqueue conn (fun conn -> 976 | send_message conn (Message_out.Close_portal portal) 977 | >>= fun () -> 978 | flush_msg conn 979 | >>= fun () -> 980 | let rec loop () = 981 | receive_message conn 982 | >>= function 983 | | Message_in.ErrorResponse err -> pg_error ~conn err 984 | | Message_in.CloseComplete -> return () 985 | | Message_in.NoticeResponse _ -> 986 | (* XXX Do or print something here? *) 987 | loop () 988 | | msg -> 989 | fail_msg "Pgx: unknown response from close: %s" (Message_in.to_string msg) 990 | in 991 | loop ()) 992 | ;; 993 | 994 | let describe_portal ?(portal = "") { conn; _ } = 995 | Sequencer.enqueue conn (fun conn -> 996 | send_message conn (Message_out.Describe_portal portal) 997 | >>= fun () -> 998 | flush_msg conn 999 | >>= fun () -> 1000 | receive_message conn 1001 | >>= function 1002 | | Message_in.ErrorResponse err -> pg_error ~sync:true ~conn err 1003 | | Message_in.NoData -> return None 1004 | | Message_in.RowDescription fields -> 1005 | let fields = List.map Result_desc.of_row_desc fields in 1006 | return (Some fields) 1007 | | msg -> 1008 | fail_msg "Pgx: unknown response from describe: %s" (Message_in.to_string msg)) 1009 | ;; 1010 | end 1011 | 1012 | let simple_query' dbh query = 1013 | send_message dbh (Message_out.Simple_query query) 1014 | >>= fun () -> 1015 | let rec loop acc rows state = 1016 | receive_message dbh 1017 | >>= fun msg -> 1018 | match state, msg with 1019 | | _, Message_in.EmptyQueryResponse -> 1020 | (match acc, rows with 1021 | | [], [] -> return [] 1022 | | _ -> fail_msg "Pgx.query: EmptyQueryResponse with rows") 1023 | | _, Message_in.CopyOutResponse (format_, format_list) -> 1024 | (match format_ with 1025 | | Message_in.Text -> 1026 | List.iter 1027 | (function 1028 | | Message_in.Binary -> 1029 | fail_msg "Pgx.query: Binary column found in text CopyOutResponse" 1030 | | _ -> ()) 1031 | format_list; 1032 | loop acc rows state 1033 | | Message_in.Binary -> 1034 | fail_msg "Pgx.query: CopyOutResponse for binary is not implemented yet") 1035 | | _, Message_in.CopyData row -> loop acc ([ row |> Value.of_string ] :: rows) state 1036 | | _, Message_in.CopyDone -> loop acc rows state 1037 | | `Rows, Message_in.DataRow row -> 1038 | let row = List.map (fun v -> Option.bind v Value.of_string) row in 1039 | loop acc (row :: rows) `Rows 1040 | | (`Row_desc | `Rows), Message_in.CommandComplete _ -> 1041 | let rows = List.rev rows in 1042 | loop (rows :: acc) [] `Row_desc 1043 | | `Row_desc, Message_in.RowDescription _ -> loop acc rows `Rows 1044 | | _, Message_in.ReadyForQuery _ -> 1045 | (match rows with 1046 | | [] -> return (List.rev acc) 1047 | | _ -> fail_msg "Pgx.query: unused rows for acc") 1048 | | _, Message_in.ErrorResponse err -> pg_error ~conn:dbh err 1049 | (* XXX log this notice properly *) 1050 | | _, Message_in.NoticeResponse _ -> loop acc rows state 1051 | (* The query changed a setting *) 1052 | | _, Message_in.ParameterStatus _ -> loop acc rows state 1053 | | _, msg -> 1054 | fail_msg "Pgx.query: unknown response message: %s" (Message_in.to_string msg) 1055 | in 1056 | loop [] [] `Row_desc 1057 | ;; 1058 | 1059 | let simple_query seq query = Sequencer.enqueue seq (fun dbh -> simple_query' dbh query) 1060 | 1061 | let execute ?(params = []) db query = 1062 | match params with 1063 | | [] -> 1064 | simple_query db query 1065 | >>| (function 1066 | | [ rows ] -> rows 1067 | | results -> 1068 | fail_msg 1069 | "Pgx.execute: Query returned %d result sets but execute should only ever \ 1070 | return one. Query was: %s" 1071 | (List.length results) 1072 | query) 1073 | | _ -> Prepared.(with_prepare db ~query ~f:(fun s -> execute s ~params)) 1074 | ;; 1075 | 1076 | let execute_unit ?params db query = 1077 | execute ?params db query 1078 | >>| function 1079 | | [] | [ [] ] -> () 1080 | | results -> 1081 | fail_msg 1082 | !"Pgx.execute_unit: Query returned a non-empty result but execute_unit was \ 1083 | expecting no result. Query was: %s, with results '%{sexp:row list}'" 1084 | query 1085 | results 1086 | ;; 1087 | 1088 | let execute_iter ?(params = []) db query ~f = 1089 | Prepared.(with_prepare db ~query ~f:(fun s -> execute_iter s ~params ~f)) 1090 | ;; 1091 | 1092 | let execute_fold ?(params = []) db query ~init ~f = 1093 | Prepared.(with_prepare db ~query ~f:(fun s -> execute_fold s ~params ~init ~f)) 1094 | ;; 1095 | 1096 | let execute_map ?(params = []) db query ~f = 1097 | Prepared.(with_prepare db ~query ~f:(fun s -> execute_map s ~params ~f)) 1098 | ;; 1099 | 1100 | let begin_work ?isolation ?access ?deferrable seq = 1101 | Sequencer.enqueue seq (fun conn -> 1102 | if conn.in_transaction 1103 | then invalid_arg "begin_work: cannot transact while in another transaction" 1104 | else conn.in_transaction <- true; 1105 | let isolation_str = 1106 | match isolation with 1107 | | None -> "" 1108 | | Some x -> " isolation level " ^ Isolation.to_string x 1109 | in 1110 | let access_str = 1111 | match access with 1112 | | None -> "" 1113 | | Some x -> " " ^ Access.to_string x 1114 | in 1115 | let deferrable_str = 1116 | match deferrable with 1117 | | None -> "" 1118 | | Some true -> " deferrable" 1119 | | Some false -> " not deferrable" 1120 | in 1121 | let query = "begin work" ^ isolation_str ^ access_str ^ deferrable_str in 1122 | simple_query' conn query) 1123 | >>| fun _ -> seq 1124 | ;; 1125 | 1126 | let commit seq = 1127 | Sequencer.enqueue seq (fun conn -> 1128 | if not conn.in_transaction 1129 | then invalid_arg "commit: cannot run outside of transaction"; 1130 | simple_query' conn "commit" >>| fun _ -> conn.in_transaction <- false) 1131 | ;; 1132 | 1133 | let rollback seq = 1134 | Sequencer.enqueue seq (fun conn -> 1135 | if not conn.in_transaction 1136 | then invalid_arg "rollback: cannot run outside of transaction"; 1137 | simple_query' conn "rollback" >>| fun _ -> conn.in_transaction <- false) 1138 | ;; 1139 | 1140 | let with_transaction ?isolation ?access ?deferrable conn f = 1141 | begin_work ?isolation ?access ?deferrable conn 1142 | >>= fun conn -> 1143 | catch 1144 | (fun () -> f conn >>= fun r -> commit conn >>= fun () -> return r) 1145 | (fun e -> 1146 | let backtrace = Printexc.get_raw_backtrace () in 1147 | rollback conn >>= fun () -> Printexc.raise_with_backtrace e backtrace) 1148 | ;; 1149 | 1150 | let execute_many conn ~query ~params = 1151 | Prepared.(with_prepare conn ~query ~f:(fun s -> execute_many s ~params)) 1152 | ;; 1153 | end 1154 | -------------------------------------------------------------------------------- /pgx/src/pgx.mli: -------------------------------------------------------------------------------- 1 | (* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. 2 | * 3 | * PG'OCaml - type safe interface to PostgreSQL. 4 | * Copyright (C) 2005-2009 Richard Jones and other authors. 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Library General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Library General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this library; see the file COPYING. If not, write to 18 | * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 | * Boston, MA 02111-1307, USA. 20 | *) 21 | module type Io = Io_intf.S 22 | 23 | (* FIXME: I can't figure out how to not duplicate these types from types.ml *) 24 | type oid = int32 [@@deriving compare, sexp] 25 | 26 | (** None is NULL. *) 27 | type param = Pgx_value.t [@@deriving compare, sexp_of] 28 | 29 | (** None is NULL. *) 30 | type result = Pgx_value.t [@@deriving compare, sexp_of] 31 | 32 | (** One row is a list of fields. *) 33 | type row = Pgx_value.t list [@@deriving compare, sexp_of] 34 | 35 | type params_description = oid list [@@deriving compare, sexp] 36 | 37 | (** For errors generated by the PostgreSQL database back-end. The 38 | * first argument is a printable error message. The second argument 39 | * is the complete set of error fields returned from the back-end. 40 | * See [http://www.postgresql.org/docs/8.1/static/protocol-error-fields.html] *) 41 | exception PostgreSQL_Error of string * Error_response.t 42 | [@@deriving sexp] 43 | 44 | module Access = Access 45 | module Isolation = Isolation 46 | module Error_response = Error_response 47 | module Result_desc = Result_desc 48 | module Value = Pgx_value 49 | 50 | module type S = Pgx_intf.S 51 | 52 | module Make (Thread : Io) : 53 | S with type 'a Io.t = 'a Thread.t and type Io.ssl_config = Thread.ssl_config 54 | -------------------------------------------------------------------------------- /pgx/src/pgx_aux.ml: -------------------------------------------------------------------------------- 1 | module String = struct 2 | include String 3 | 4 | let implode xs = 5 | let buf = Buffer.create (List.length xs) in 6 | List.iter (Buffer.add_char buf) xs; 7 | Buffer.contents buf 8 | ;; 9 | 10 | let fold_left f init str = 11 | let len = length str in 12 | let rec loop i accum = if i = len then accum else loop (i + 1) (f accum str.[i]) in 13 | loop 0 init 14 | ;; 15 | end 16 | 17 | module List = struct 18 | include List 19 | 20 | (* From Base 21 | https://github.com/janestreet/base/blob/f86e72ee3b59ff5315e20a8392b81fb2f5237a25/src/ppx_compare_lib.ml 22 | 23 | The MIT License 24 | 25 | Copyright (c) 2016--2020 Jane Street Group, LLC 26 | 27 | Permission is hereby granted, free of charge, to any person obtaining a copy 28 | of this software and associated documentation files (the "Software"), to deal 29 | in the Software without restriction, including without limitation the rights 30 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 31 | copies of the Software, and to permit persons to whom the Software is 32 | furnished to do so, subject to the following conditions: 33 | 34 | The above copyright notice and this permission notice shall be included in all 35 | copies or substantial portions of the Software. 36 | 37 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 38 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 39 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 40 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 41 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 42 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 43 | SOFTWARE. 44 | *) 45 | let rec compare compare_elt a b = 46 | match a, b with 47 | | [], [] -> 0 48 | | [], _ -> -1 49 | | _, [] -> 1 50 | | x :: xs, y :: ys -> 51 | let res = compare_elt x y in 52 | if res <> 0 then res else compare compare_elt xs ys 53 | ;; 54 | 55 | (* The default List.map isn't tail recursive so we replace it with one that is *) 56 | let map f xs = List.rev_map f xs |> List.rev 57 | end 58 | 59 | let compare_bool = Bool.compare 60 | let compare_float = Float.compare 61 | let compare_int = Int.compare 62 | let compare_int32 = Int32.compare 63 | let compare_list = List.compare 64 | let compare_option = Option.compare 65 | let compare_string = String.compare 66 | -------------------------------------------------------------------------------- /pgx/src/pgx_aux.mli: -------------------------------------------------------------------------------- 1 | (** Helper functions since we don't want a dependency on Core or Batteries. *) 2 | 3 | module String : sig 4 | include module type of String 5 | 6 | val implode : char list -> string 7 | val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a 8 | end 9 | 10 | module List : sig 11 | include module type of List 12 | 13 | (** Like the built-in [List.map], but tail-recursive *) 14 | val map : ('a -> 'b) -> 'a list -> 'b list 15 | end 16 | 17 | (** Necessary for ppx_compare *) 18 | val compare_bool : bool -> bool -> int 19 | 20 | val compare_float : float -> float -> int 21 | val compare_int : int -> int -> int 22 | val compare_int32 : int32 -> int32 -> int 23 | val compare_list : ('a -> 'a -> int) -> 'a list -> 'a list -> int 24 | val compare_option : ('a -> 'a -> int) -> 'a option -> 'a option -> int 25 | val compare_string : string -> string -> int 26 | -------------------------------------------------------------------------------- /pgx/src/pgx_intf.ml: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | module type S = sig 4 | type t 5 | 6 | module Io : sig 7 | type 'a t 8 | type ssl_config 9 | 10 | val return : 'a -> 'a t 11 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 12 | val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t 13 | val protect : (unit -> 'a t) -> finally:(unit -> unit t) -> 'a t 14 | end 15 | 16 | (** Connect to the database. The normal [$PGDATABASE], etc. environment 17 | variables are available. 18 | 19 | [max_message_length] is the maximum message length accepted from the back-end. 20 | The default is [Sys.max_string_length], which means that we will try to 21 | read as much data from the back-end as we can, and this may cause us to 22 | run out of memory (particularly on 64 bit machines), causing a 23 | possible denial of service. You may want to set this to a smaller 24 | size to avoid this happening. *) 25 | val connect 26 | : ?ssl:[ `Auto | `No | `Always of Io.ssl_config ] 27 | -> ?host:string 28 | -> ?port:int 29 | -> ?user:string 30 | -> ?password:string 31 | -> ?database:string 32 | -> ?unix_domain_socket_dir:string 33 | -> ?verbose:int 34 | -> ?max_message_length:int 35 | -> unit 36 | -> t Io.t 37 | 38 | (** Close the database handle. You must call this after you have 39 | finished with the handle, or else you will get leaked file 40 | descriptors. *) 41 | val close : t -> unit Io.t 42 | 43 | (** Calls [connect], passes the DB handle to the callback, then calls 44 | [close]. This is the preferred way to use this library since it cleans up 45 | after itself. *) 46 | val with_conn 47 | : ?ssl:[ `Auto | `No | `Always of Io.ssl_config ] 48 | -> ?host:string 49 | -> ?port:int 50 | -> ?user:string 51 | -> ?password:string 52 | -> ?database:string 53 | -> ?unix_domain_socket_dir:string 54 | -> ?verbose:int 55 | -> ?max_message_length:int 56 | -> (t -> 'a Io.t) 57 | -> 'a Io.t 58 | 59 | (** Ping the database. If the database is not available, some sort of 60 | exception will be thrown. *) 61 | val ping : t -> unit Io.t 62 | 63 | (** This function is a wrapper of [ping] that returns a boolean instead of 64 | raising an exception. *) 65 | val alive : t -> bool Io.t 66 | 67 | (** Start a transaction. *) 68 | val begin_work 69 | : ?isolation:Isolation.t 70 | -> ?access:Access.t 71 | -> ?deferrable:bool 72 | -> t 73 | -> t Io.t 74 | 75 | (** Commit a transaction. Throws an exception if no transaction is open. 76 | Use [with_transaction] when possible. *) 77 | val commit : t -> unit Io.t 78 | 79 | (** Rollback a transaction. Throws an exception if no transaction is open. 80 | Use [with_transaction] when possible. *) 81 | val rollback : t -> unit Io.t 82 | 83 | (** [with_transaction db ?isolation ?access ?deferrable f] wraps your 84 | function [f] inside a transactional block. 85 | See [begin_work] for a description of [isolation], [access], and 86 | [deferrable]. 87 | If [f] throws an exception, the transaction will be rolled back. Otherwise 88 | the transaction will be commited. It is an error to call [commit] or 89 | [rollback] manually inside of this function. *) 90 | val with_transaction 91 | : ?isolation:Isolation.t 92 | -> ?access:Access.t 93 | -> ?deferrable:bool 94 | -> t 95 | -> (t -> 'b Io.t) 96 | -> 'b Io.t 97 | 98 | module Prepared : sig 99 | type s [@@deriving sexp_of] 100 | 101 | (** [prepare ?name ?types conn ~query] prepares the statement [query] and 102 | sets the parameter types to [types]. 103 | If no [name] is given, a random name will be generated. 104 | If no types are given, then the PostgreSQL engine infers types. *) 105 | val prepare : ?name:string -> ?types:oid list -> t -> query:string -> s Io.t 106 | 107 | (** [close_statement t] closes a prepared statement and frees 108 | up any resources. *) 109 | val close : s -> unit Io.t 110 | 111 | (** [prepare] a query, execute [f], and then [close_statement] *) 112 | val with_prepare 113 | : ?name:string 114 | -> ?types:oid list 115 | -> t 116 | -> query:string 117 | -> f:(s -> 'a Io.t) 118 | -> 'a Io.t 119 | 120 | (** [execute conn ~params t] executes the given prepared statement, with 121 | the given parameters [params], returning the result rows (if any). 122 | 123 | There are several steps involved at the protocol layer: 124 | (1) a "portal" is created from the statement, binding the 125 | parameters in the statement (Bind). 126 | (2) the portal is executed (Execute). 127 | (3) we synchronise the connection (Sync). 128 | 129 | The optional [?portal] parameter may be used to name the portal 130 | created in step (1) above (otherwise the unnamed portal is used). 131 | This is only important if you want to call {!describe_portal} 132 | to find out the result types. *) 133 | val execute : ?portal:string -> s -> params:param list -> row list Io.t 134 | 135 | (** [execute_unit ?portal s ?params] same as execute, but intended 136 | for database calls that have side-affects rather than returning results *) 137 | val execute_unit : ?portal:string -> s -> params:param list -> unit Io.t 138 | 139 | val execute_fold 140 | : ?portal:string 141 | -> s 142 | -> params:param list 143 | -> init:'accum 144 | -> f:('accum -> row -> 'accum Io.t) 145 | -> 'accum Io.t 146 | 147 | val execute_iter 148 | : ?portal:string 149 | -> s 150 | -> params:param list 151 | -> f:(row -> unit Io.t) 152 | -> unit Io.t 153 | 154 | val execute_map 155 | : ?portal:string 156 | -> s 157 | -> params:param list 158 | -> f:(row -> 'a Io.t) 159 | -> 'a list Io.t 160 | 161 | val execute_many : s -> params:param list list -> row list list Io.t 162 | 163 | (** [describe_statement t] describes the statement's parameter types and 164 | result types. *) 165 | val describe : s -> (params_description * Result_desc.t list option) Io.t 166 | 167 | (** [close_portal conn ?portal ()] closes a portal and frees up any 168 | resources. *) 169 | val close_portal : ?portal:string -> s -> unit Io.t 170 | 171 | (** [describe_portal conn ?portal ()] describes the named or unnamed 172 | portal's result types. *) 173 | val describe_portal : ?portal:string -> s -> Result_desc.t list option Io.t 174 | end 175 | 176 | (** [execute conn ?params query] prepares and executes the statement 177 | [query] and returns the result. *) 178 | val execute : ?params:row -> t -> string -> row list Io.t 179 | 180 | (** [execute_unit conn ?params query ] same as execute, but intended 181 | for database calls that have side-affects rather than returning results *) 182 | val execute_unit : ?params:row -> t -> string -> unit Io.t 183 | 184 | val execute_fold 185 | : ?params:param list 186 | -> t 187 | -> string 188 | -> init:'accum 189 | -> f:('accum -> row -> 'accum Io.t) 190 | -> 'accum Io.t 191 | 192 | val execute_map 193 | : ?params:param list 194 | -> t 195 | -> string 196 | -> f:(row -> 'a Io.t) 197 | -> 'a list Io.t 198 | 199 | val execute_iter 200 | : ?params:param list 201 | -> t 202 | -> string 203 | -> f:(row -> unit Io.t) 204 | -> unit Io.t 205 | 206 | (** Prepares a query as in [execute] and then executes it once per set of 207 | parameters in [params]. This is more efficient than calling [execute] 208 | in a loop because the query is only prepared once. *) 209 | val execute_many : t -> query:string -> params:param list list -> row list list Io.t 210 | 211 | (** [simple_query conn query] executes the command(s) in the given [query] 212 | and returns a list of query results (i.e. if you run two queries, you 213 | will get a list with two elements: the results of the first query 214 | followed by the results of the second query. *) 215 | val simple_query : t -> string -> row list list Io.t 216 | end 217 | -------------------------------------------------------------------------------- /pgx/src/pgx_value.ml: -------------------------------------------------------------------------------- 1 | open Sexplib0.Sexp_conv 2 | open Pgx_aux 3 | 4 | type v = string [@@deriving compare, sexp_of] 5 | type t = v option [@@deriving compare, sexp_of] 6 | 7 | exception Conversion_failure of string [@@deriving sexp_of] 8 | 9 | let convert_failure ?hint type_ s = 10 | let hint = 11 | match hint with 12 | | None -> "" 13 | | Some hint -> Printf.sprintf " (%s)" hint 14 | in 15 | Conversion_failure (Printf.sprintf "Unable to convert to %s%s: %s" type_ hint s) 16 | |> raise 17 | ;; 18 | 19 | let required f = function 20 | | Some x -> f x 21 | | None -> raise (Conversion_failure "Expected not-null but got null") 22 | ;; 23 | 24 | let opt f v = Option.bind v f 25 | let null = None 26 | 27 | let of_binary b = 28 | match b with 29 | | "" -> Some "" 30 | | _ -> 31 | (try 32 | let (`Hex hex) = Hex.of_string b in 33 | Some ("\\x" ^ hex) 34 | with 35 | | exn -> convert_failure ~hint:(Printexc.to_string exn) "binary" b) 36 | ;; 37 | 38 | let to_binary' = function 39 | | "" -> "" 40 | | t -> 41 | (* Skip if not encoded as hex *) 42 | (try 43 | if String.sub t 0 2 <> "\\x" 44 | then t (* Decode if encoded as hex *) 45 | else `Hex (String.sub t 2 (String.length t - 2)) |> Hex.to_string 46 | with 47 | | exn -> convert_failure ~hint:(Printexc.to_string exn) "binary" t) 48 | ;; 49 | 50 | let to_binary_exn = required to_binary' 51 | let to_binary = Option.map to_binary' 52 | 53 | let of_bool = function 54 | | true -> Some "t" 55 | | false -> Some "f" 56 | ;; 57 | 58 | let to_bool' = function 59 | | "t" -> true 60 | | "f" -> false 61 | | s -> convert_failure "bool" s 62 | ;; 63 | 64 | let to_bool_exn = required to_bool' 65 | let to_bool = Option.map to_bool' 66 | 67 | let of_float' f = 68 | match classify_float f with 69 | | FP_infinite when f > 0. -> "Infinity" 70 | | FP_infinite when f < 0. -> "-Infinity" 71 | | FP_nan -> "NaN" 72 | | _ -> string_of_float f 73 | ;; 74 | 75 | let of_float f = Some (of_float' f) 76 | 77 | let to_float' t = 78 | match String.lowercase_ascii t with 79 | | "infinity" -> infinity 80 | | "-infinity" -> neg_infinity 81 | | "nan" -> nan 82 | | _ -> 83 | (try float_of_string t with 84 | | Failure hint -> convert_failure ~hint "float" t) 85 | ;; 86 | 87 | let to_float_exn = required to_float' 88 | let to_float = Option.map to_float' 89 | 90 | type hstore = (string * string option) list [@@deriving compare, sexp_of] 91 | 92 | let of_hstore hstore = 93 | let string_of_quoted str = "\"" ^ str ^ "\"" in 94 | let string_of_mapping (key, value) = 95 | let key_str = string_of_quoted key 96 | and value_str = 97 | match value with 98 | | Some v -> string_of_quoted v 99 | | None -> "NULL" 100 | in 101 | key_str ^ "=>" ^ value_str 102 | in 103 | Some (String.concat ", " (List.map string_of_mapping hstore)) 104 | ;; 105 | 106 | let to_hstore' str = 107 | let expect target stream = 108 | if List.exists (fun c -> c <> Stream.next stream) target 109 | then convert_failure "hstore" str 110 | in 111 | let parse_quoted stream = 112 | let rec loop accum stream = 113 | match Stream.next stream with 114 | | '"' -> String.implode (List.rev accum) 115 | (* FIXME: Slashes don't seem to round-trip properly *) 116 | | '\\' -> loop (Stream.next stream :: accum) stream 117 | | x -> loop (x :: accum) stream 118 | in 119 | expect [ '"' ] stream; 120 | loop [] stream 121 | in 122 | let parse_value stream = 123 | match Stream.peek stream with 124 | | Some 'N' -> 125 | expect [ 'N'; 'U'; 'L'; 'L' ] stream; 126 | None 127 | | _ -> Some (parse_quoted stream) 128 | in 129 | let parse_mapping stream = 130 | let key = parse_quoted stream in 131 | expect [ '='; '>' ] stream; 132 | let value = parse_value stream in 133 | key, value 134 | in 135 | let parse_main stream = 136 | let rec loop accum stream = 137 | let mapping = parse_mapping stream in 138 | match Stream.peek stream with 139 | | Some _ -> 140 | expect [ ','; ' ' ] stream; 141 | loop (mapping :: accum) stream 142 | | None -> mapping :: accum 143 | in 144 | match Stream.peek stream with 145 | | Some _ -> loop [] stream 146 | | None -> [] 147 | in 148 | parse_main (Stream.of_string str) 149 | ;; 150 | 151 | let to_hstore_exn = required to_hstore' 152 | let to_hstore = Option.map to_hstore' 153 | 154 | type inet = Ipaddr.t * int [@@deriving compare] 155 | 156 | let sexp_of_inet (addr, mask) = [%sexp_of: string * int] (Ipaddr.to_string addr, mask) 157 | 158 | let of_inet (addr, mask) = 159 | let hostmask = 160 | match addr with 161 | | Ipaddr.V4 _ -> 32 162 | | Ipaddr.V6 _ -> 128 163 | in 164 | let addr = Ipaddr.to_string addr in 165 | if mask = hostmask 166 | then Some addr 167 | else if mask >= 0 && mask < hostmask 168 | then Some (addr ^ "/" ^ string_of_int mask) 169 | else invalid_arg "mask" 170 | ;; 171 | 172 | let to_inet' = 173 | let re = 174 | let open Re in 175 | [ group 176 | ([ rep (compl [ set ":./" ]); group (set ":."); rep1 (compl [ char '/' ]) ] |> seq) 177 | ; opt (seq [ char '/'; group (rep1 any) ]) 178 | ] 179 | |> seq 180 | |> compile 181 | in 182 | fun str -> 183 | try 184 | let subs = Re.exec re str in 185 | let addr = Ipaddr.of_string_exn (Re.Group.get subs 1) in 186 | (* optional match *) 187 | let mask = 188 | try Re.Group.get subs 3 with 189 | | Not_found -> "" 190 | in 191 | if mask = "" 192 | then addr, if Re.Group.get subs 2 = "." then 32 else 128 193 | else addr, int_of_string mask 194 | with 195 | | exn -> convert_failure ~hint:(Printexc.to_string exn) "inet" str 196 | ;; 197 | 198 | let to_inet_exn = required to_inet' 199 | let to_inet = Option.map to_inet' 200 | let of_int i = Some (string_of_int i) 201 | 202 | let to_int' t = 203 | try int_of_string t with 204 | | Failure hint -> convert_failure ~hint "int" t 205 | ;; 206 | 207 | let to_int_exn = required to_int' 208 | let to_int = Option.map to_int' 209 | let of_int32 i = Some (Int32.to_string i) 210 | 211 | let to_int32' t = 212 | try Int32.of_string t with 213 | | Failure hint -> convert_failure ~hint "int32" t 214 | ;; 215 | 216 | let to_int32_exn = required to_int32' 217 | let to_int32 = Option.map to_int32' 218 | let of_int64 i = Some (Int64.to_string i) 219 | 220 | let to_int64' t = 221 | try Int64.of_string t with 222 | | Failure hint -> convert_failure ~hint "int64" t 223 | ;; 224 | 225 | let to_int64_exn = required to_int64' 226 | let to_int64 = Option.map to_int64' 227 | 228 | let escape_string str = 229 | let buf = Buffer.create 128 in 230 | for i = 0 to String.length str - 1 do 231 | match str.[i] with 232 | | ('"' | '\\') as x -> 233 | Buffer.add_char buf '\\'; 234 | Buffer.add_char buf x 235 | | x -> Buffer.add_char buf x 236 | done; 237 | Buffer.contents buf 238 | ;; 239 | 240 | let of_list (xs : t list) = 241 | let buf = Buffer.create 128 in 242 | Buffer.add_char buf '{'; 243 | let adder i x = 244 | if i > 0 then Buffer.add_char buf ','; 245 | match x with 246 | | Some x -> 247 | let x = escape_string x in 248 | Buffer.add_char buf '"'; 249 | Buffer.add_string buf x; 250 | Buffer.add_char buf '"' 251 | | None -> Buffer.add_string buf "NULL" 252 | in 253 | List.iteri adder xs; 254 | Buffer.add_char buf '}'; 255 | Some (Buffer.contents buf) 256 | ;; 257 | 258 | let to_list' str = 259 | let n = String.length str in 260 | if n = 0 || str.[0] <> '{' || str.[n - 1] <> '}' then convert_failure "list" str; 261 | let str = String.sub str 1 (n - 2) in 262 | let buf = Buffer.create 128 in 263 | let add_field accum = 264 | let x = Buffer.contents buf in 265 | Buffer.clear buf; 266 | let field = 267 | if x = "NULL" 268 | then None 269 | else ( 270 | let n = String.length x in 271 | if n >= 2 && x.[0] = '"' then Some (String.sub x 1 (n - 2)) else Some x) 272 | in 273 | field :: accum 274 | in 275 | let loop (accum, quoted, escaped) = function 276 | | '\\' when not escaped -> accum, quoted, true 277 | | '"' when not escaped -> 278 | Buffer.add_char buf '"'; 279 | accum, not quoted, false 280 | | ',' when (not escaped) && not quoted -> add_field accum, false, false 281 | | x -> 282 | Buffer.add_char buf x; 283 | accum, quoted, false 284 | in 285 | let accum, _, _ = String.fold_left loop ([], false, false) str in 286 | let accum = if Buffer.length buf = 0 then accum else add_field accum in 287 | List.rev accum 288 | ;; 289 | 290 | let to_list_exn = required to_list' 291 | let to_list = Option.map to_list' 292 | 293 | type point = float * float [@@deriving compare, sexp_of] 294 | 295 | let of_point (x, y) = 296 | let x = of_float' x in 297 | let y = of_float' y in 298 | Some (Printf.sprintf "(%s,%s)" x y) 299 | ;; 300 | 301 | let to_point' = 302 | let point_re = 303 | let open Re in 304 | let part = seq [ rep space; group (rep any); rep space ] in 305 | [ rep space; char '('; part; char ','; part; char ')'; rep space ] 306 | |> seq 307 | |> whole_string 308 | |> compile 309 | in 310 | fun str -> 311 | try 312 | let subs = Re.exec point_re str in 313 | float_of_string (Re.Group.get subs 1), float_of_string (Re.Group.get subs 2) 314 | with 315 | | exn -> convert_failure ~hint:(Printexc.to_string exn) "point" str 316 | ;; 317 | 318 | let to_point_exn = required to_point' 319 | let to_point = Option.map to_point' 320 | let of_string t = Some t 321 | let to_string_exn = required (fun t -> t) 322 | let to_string t = t 323 | let unit = Some "" 324 | 325 | let to_unit' = function 326 | | "" -> () 327 | | t -> convert_failure "unit" t 328 | ;; 329 | 330 | let to_unit_exn = required to_unit' 331 | let to_unit = Option.map to_unit' 332 | 333 | type uuid = Uuidm.t [@@deriving compare] 334 | 335 | let sexp_of_uuid u = Uuidm.to_string u |> sexp_of_string 336 | let of_uuid s = Some (Uuidm.to_string s) 337 | 338 | let to_uuid' t = 339 | match Uuidm.of_string t with 340 | | Some u -> u 341 | | None -> convert_failure "uuid" t 342 | ;; 343 | 344 | let to_uuid_exn = required to_uuid' 345 | let to_uuid = Option.map to_uuid' 346 | -------------------------------------------------------------------------------- /pgx/src/pgx_value.mli: -------------------------------------------------------------------------------- 1 | include Pgx_value_intf.S 2 | 3 | (* Exposed for extending this module *) 4 | 5 | (** [convert_failure type_ str] raises [Convert_failure] with a useful 6 | error message. Add [~hint] if there's additional info you can give the 7 | user about the error. *) 8 | val convert_failure : ?hint:string -> string -> string -> _ 9 | -------------------------------------------------------------------------------- /pgx/src/pgx_value_intf.ml: -------------------------------------------------------------------------------- 1 | (** A wrapper for holding Postgres types *) 2 | module type S = sig 3 | (** [v] is opaque because the exact contents depend on Postgres types, so you could have two [v]'s with the 4 | same value but different internal data representation, for example if you did a [SELECT 'a'::bytea] vs 5 | [SELECT 'a'::varchar], the internal representation will be different, but the actual data if you use 6 | [to_binary] or [to_string] will be the same. *) 7 | type v [@@deriving compare, sexp_of] 8 | 9 | type t = v option [@@deriving compare, sexp_of] 10 | 11 | exception Conversion_failure of string [@@deriving sexp_of] 12 | 13 | val required : ('a -> 'b) -> 'a option -> 'b 14 | val opt : ('a -> t) -> 'a option -> t 15 | val null : t 16 | val of_binary : string -> t 17 | val to_binary_exn : t -> string 18 | val to_binary : t -> string option 19 | val of_bool : bool -> t 20 | val to_bool_exn : t -> bool 21 | val to_bool : t -> bool option 22 | val of_float : float -> t 23 | val to_float_exn : t -> float 24 | val to_float : t -> float option 25 | 26 | type hstore = (string * string option) list [@@deriving compare, sexp_of] 27 | 28 | val of_hstore : hstore -> t 29 | val to_hstore_exn : t -> hstore 30 | val to_hstore : t -> hstore option 31 | 32 | type inet = Ipaddr.t * int [@@deriving compare, sexp_of] 33 | 34 | val of_inet : inet -> t 35 | val to_inet_exn : t -> inet 36 | val to_inet : t -> inet option 37 | val of_int : int -> t 38 | val to_int_exn : t -> int 39 | val to_int : t -> int option 40 | val of_int32 : int32 -> t 41 | val to_int32_exn : t -> int32 42 | val to_int32 : t -> int32 option 43 | val of_int64 : int64 -> t 44 | val to_int64_exn : t -> int64 45 | val to_int64 : t -> int64 option 46 | val of_list : t list -> t 47 | val to_list_exn : t -> t list 48 | val to_list : t -> t list option 49 | 50 | type point = float * float [@@deriving compare, sexp_of] 51 | 52 | val of_point : point -> t 53 | val to_point_exn : t -> point 54 | val to_point : t -> point option 55 | val of_string : string -> t 56 | val to_string_exn : t -> string 57 | val to_string : t -> string option 58 | val unit : t 59 | val to_unit_exn : t -> unit 60 | val to_unit : t -> unit option 61 | 62 | type uuid = Uuidm.t [@@deriving compare, sexp_of] 63 | 64 | val of_uuid : uuid -> t 65 | val to_uuid_exn : t -> uuid 66 | val to_uuid : t -> uuid option 67 | end 68 | -------------------------------------------------------------------------------- /pgx/src/result_desc.ml: -------------------------------------------------------------------------------- 1 | open Sexplib0.Sexp_conv 2 | include Types 3 | 4 | type t = 5 | { name : string 6 | ; table : oid option 7 | ; column : int option 8 | ; field_type : oid 9 | ; length : int 10 | ; modifier : int32 11 | } 12 | [@@deriving sexp] 13 | 14 | let of_row_desc r = 15 | let open Row_desc in 16 | { name = r.name 17 | ; table = (if r.table = 0l then None else Some r.table) 18 | ; column = (if r.col = 0 then None else Some r.col) 19 | ; field_type = r.oid 20 | ; length = r.len 21 | ; modifier = r.modifier 22 | } 23 | ;; 24 | -------------------------------------------------------------------------------- /pgx/src/result_desc.mli: -------------------------------------------------------------------------------- 1 | open Types 2 | 3 | type t = 4 | { name : string (** Field name. *) 5 | ; table : oid option (** OID of table. *) 6 | ; column : int option (** Column number of field in table. *) 7 | ; field_type : oid (** The type of the field. *) 8 | ; length : int (** Length of the field. *) 9 | ; modifier : int32 (** Type modifier. *) 10 | } 11 | [@@deriving sexp] 12 | 13 | val of_row_desc : Row_desc.t -> t 14 | -------------------------------------------------------------------------------- /pgx/src/row_desc.ml: -------------------------------------------------------------------------------- 1 | open Sexplib0.Sexp_conv 2 | 3 | type t = 4 | { name : string 5 | ; table : int32 6 | ; col : int 7 | ; oid : int32 8 | ; len : int 9 | ; modifier : int32 10 | ; format : int 11 | } 12 | [@@deriving sexp] 13 | -------------------------------------------------------------------------------- /pgx/src/types.ml: -------------------------------------------------------------------------------- 1 | open Sexplib0.Sexp_conv 2 | open Pgx_aux 3 | 4 | type oid = int32 [@@deriving compare, sexp] 5 | 6 | (** None is NULL. *) 7 | type param = Pgx_value.t [@@deriving compare, sexp_of] 8 | 9 | (** None is NULL. *) 10 | type result = Pgx_value.t [@@deriving compare, sexp_of] 11 | 12 | (** One row is a list of fields. *) 13 | type row = Pgx_value.t list [@@deriving compare, sexp_of] 14 | 15 | type params_description = oid list [@@deriving compare, sexp] 16 | 17 | exception PostgreSQL_Error of string * Error_response.t [@@deriving sexp] 18 | -------------------------------------------------------------------------------- /pgx/test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test_error_response test_pgx_value) 3 | (libraries alcotest ipaddr pgx) 4 | (package pgx)) 5 | -------------------------------------------------------------------------------- /pgx/test/test_error_response.ml: -------------------------------------------------------------------------------- 1 | open Pgx.Error_response 2 | 3 | let tests = 4 | let info_msg = 5 | { code = "5" 6 | ; severity = "INFO" 7 | ; message = "test" 8 | ; custom = [ 'a', "string"; 'c', "field" ] 9 | } 10 | in 11 | let error_msg = { info_msg with severity = "ERROR" } in 12 | [ Alcotest.test_case "to_string tests: print msg when verbose = false" `Quick (fun () -> 13 | let verbose = false in 14 | Alcotest.(check string) 15 | "info to string" 16 | "INFO: 5: test" 17 | (to_string ~verbose info_msg); 18 | Alcotest.(check string) 19 | "error to string" 20 | "ERROR: 5: test" 21 | (to_string ~verbose error_msg)) 22 | ; Alcotest.test_case 23 | "to_string tests: print msg and fields when verbose = true" 24 | `Quick 25 | (fun () -> 26 | let verbose = true in 27 | Alcotest.(check string) 28 | "vebose error to string" 29 | "ERROR: 5: test\na: string\nc: field" 30 | (to_string ~verbose error_msg)) 31 | ; Alcotest.test_case 32 | "should_print tests: should not print when verbose = 0" 33 | `Quick 34 | (fun () -> 35 | let verbose = 0 in 36 | Alcotest.(check bool) 37 | "should not print info" 38 | false 39 | (should_print ~verbose info_msg); 40 | Alcotest.(check bool) 41 | "should not print error" 42 | false 43 | (should_print ~verbose error_msg)) 44 | ; Alcotest.test_case 45 | "should_print tests: print if verbose = 1 and t.severity is one of three: INFO, \ 46 | ERROR, PANIC" 47 | `Quick 48 | (fun () -> 49 | let verbose = 1 in 50 | [ "FATAL"; "ERROR"; "PANIC" ] 51 | |> List.iter (fun severity -> 52 | let msg = { info_msg with severity } in 53 | Alcotest.(check bool) "should print" true (should_print msg ~verbose)); 54 | Alcotest.(check bool) "should not print" false (should_print info_msg ~verbose)) 55 | ; Alcotest.test_case 56 | "should_print tests: print if verbose > 1 no matter t.severity" 57 | `Quick 58 | (fun () -> 59 | let verbose = 2 in 60 | [ "INFO"; "FATAL"; "ERROR"; "PANIC" ] 61 | |> List.iter (fun severity -> 62 | let msg = { info_msg with severity } in 63 | Alcotest.(check bool) 64 | "should always print" 65 | true 66 | (should_print msg ~verbose))) 67 | ] 68 | ;; 69 | 70 | let () = 71 | Alcotest.run "test_error_response" [ "to_string and should_print inline tests", tests ] 72 | ;; 73 | -------------------------------------------------------------------------------- /pgx/test/test_pgx_value.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Sexplib0 3 | open Sexplib0.Sexp_conv 4 | open Pgx.Value 5 | 6 | let pp_value ppf x = Sexp.pp_hum ppf (sexp_of_t x) 7 | let equal_value (x : t) (y : t) = x = y 8 | let pp_hstore ppf x = Sexp.pp_hum ppf (sexp_of_hstore x) 9 | let equal_hstore x y = Sexp.equal (sexp_of_hstore x) (sexp_of_hstore y) 10 | let printer sexp value = sexp value |> Sexp.to_string_hum 11 | let sort_hstore = List.sort (fun (k, _) (k', _) -> String.compare k k') 12 | let to_hstore_sorted v = to_hstore v |> Option.map sort_hstore 13 | let to_hstore_sorted_exn v = to_hstore_exn v |> sort_hstore 14 | let pp_inet ppf (addr, port) = Format.fprintf ppf "%a:%d" Ipaddr.pp addr port 15 | let equal_inet (a1, p1) (a2, p2) = Ipaddr.compare a1 a2 = 0 && p1 = p2 16 | let epsilon = 0.00001 17 | 18 | let equal_float x y = 19 | match classify_float x, classify_float y with 20 | | FP_infinite, FP_infinite -> x = y 21 | | FP_nan, FP_nan -> true 22 | | _, _ -> abs_float (x -. y) <= epsilon *. (abs_float x +. abs_float y) 23 | ;; 24 | 25 | module Alcotest_ext = struct 26 | let hstore = Alcotest.testable pp_hstore equal_hstore 27 | let inet = Alcotest.testable pp_inet equal_inet 28 | let value = Alcotest.testable pp_value equal_value 29 | let uuid = Alcotest.testable Uuidm.pp Uuidm.equal 30 | let our_float = Alcotest.testable Format.pp_print_float equal_float 31 | end 32 | 33 | let make_test name typ to_value of_value of_value_exn values fail_values = 34 | let fail_tests = 35 | Alcotest.test_case "null required input" `Quick (fun () -> 36 | Alcotest.check_raises 37 | "non-null conversion" 38 | (Conversion_failure "Expected not-null but got null") 39 | (fun () -> ignore (of_value_exn None))) 40 | :: 41 | List.map 42 | (fun str -> 43 | let test_name = sprintf "bad conversion - %s" str in 44 | let value = of_string str in 45 | Alcotest.test_case test_name `Quick 46 | @@ fun () -> 47 | try 48 | of_value value |> ignore; 49 | Alcotest.fail "Expected Conversion_failure" 50 | with 51 | | Conversion_failure _ -> ()) 52 | fail_values 53 | in 54 | let success_opt_tests = 55 | None :: List.map (fun v -> Some v) values 56 | |> List.map (fun expect -> 57 | let test_name = 58 | Format.asprintf "good conversion - %a" Alcotest.(pp (option typ)) expect 59 | in 60 | Alcotest.test_case test_name `Quick 61 | @@ fun () -> 62 | let value = expect |> opt to_value |> of_value in 63 | Alcotest.(check (option typ)) test_name expect value) 64 | in 65 | let success_tests = 66 | List.map 67 | (fun expect -> 68 | let test_name = Format.asprintf "good conversion - %a" (Alcotest.pp typ) expect in 69 | Alcotest.test_case test_name `Quick 70 | @@ fun () -> 71 | let value = expect |> to_value |> of_value_exn in 72 | Alcotest.(check typ) test_name expect value) 73 | values 74 | in 75 | name, success_tests @ success_opt_tests @ fail_tests 76 | ;; 77 | 78 | let () = 79 | let all_chars = String.init 255 char_of_int in 80 | Alcotest.run 81 | "Pgx.Value" 82 | [ make_test 83 | "binary" 84 | Alcotest.string 85 | of_binary 86 | to_binary 87 | to_binary_exn 88 | [ ""; "normal string"; "string with null\x00 in the midddle"; all_chars ] 89 | [] 90 | ; make_test 91 | "bool" 92 | Alcotest.bool 93 | of_bool 94 | to_bool 95 | to_bool_exn 96 | [ true; false ] 97 | [ ""; "asd" ] 98 | ; make_test 99 | "float" 100 | Alcotest_ext.our_float 101 | of_float 102 | to_float 103 | to_float_exn 104 | [ 0.; 3.14; -5.; neg_infinity; infinity; nan; max_float; min_float ] 105 | [ ""; "asd" ] 106 | ; make_test 107 | "hstore" 108 | Alcotest_ext.hstore 109 | of_hstore 110 | to_hstore_sorted 111 | to_hstore_sorted_exn 112 | [ [] 113 | ; [ "a", Some "b" ] 114 | ; [ "key", None ] 115 | ; [ "1", Some "2"; "3;'", Some "'!"; "asdf=>", None ] 116 | ] 117 | [ "asd"; "=>"; "a=>"; "=>v" ] 118 | ; make_test 119 | "inet" 120 | Alcotest_ext.inet 121 | of_inet 122 | to_inet 123 | to_inet_exn 124 | ([ "127.0.0.1", 32; "192.168.5.9", 0; "fe80::0202:b3ff:fe1e:8329", 128 ] 125 | |> List.map (fun (addr, mask) -> Ipaddr.of_string_exn addr, mask)) 126 | [ ""; "asd"; "192.168.1.a/32" ] 127 | ; make_test 128 | "int" 129 | Alcotest.int 130 | of_int 131 | to_int 132 | to_int_exn 133 | [ 0; 1; -1; max_int; min_int ] 134 | [ ""; "asd"; "t"; "f" ] 135 | ; make_test 136 | "int32" 137 | Alcotest.int32 138 | of_int32 139 | to_int32 140 | to_int32_exn 141 | Int32.[ zero; of_int 1; of_int (-1); max_int; min_int ] 142 | [ ""; "asd"; "t"; "f" ] 143 | ; make_test 144 | "int64" 145 | Alcotest.int64 146 | of_int64 147 | to_int64 148 | to_int64_exn 149 | Int64.[ zero; of_int 1; of_int (-1); max_int; min_int ] 150 | [ ""; "asd"; "t"; "f" ] 151 | ; make_test 152 | "list" 153 | Alcotest.(list Alcotest_ext.value) 154 | of_list 155 | to_list 156 | to_list_exn 157 | [ [] 158 | ; [ of_bool true 159 | ; of_bool false 160 | ; of_float 10.5 161 | ; of_hstore [] 162 | ; of_hstore [ "key", Some "value" ] 163 | ; of_hstore [ "key2", None ] 164 | ; of_inet (Ipaddr.of_string_exn "8.8.8.8", 4) 165 | ; of_int 99 166 | ; of_int32 (Int32.of_int 101) 167 | ; of_int64 (Int64.of_int 1102931) 168 | ; of_list [] 169 | ; null 170 | ; of_point (-5., 100.) 171 | ; unit 172 | ; of_uuid (Uuidm.create `V4) 173 | ; of_string all_chars 174 | ] 175 | ] 176 | [ ""; "asd" ] 177 | ; make_test 178 | "point" 179 | Alcotest.(Alcotest_ext.(pair our_float our_float)) 180 | of_point 181 | to_point 182 | to_point_exn 183 | [ 0., 0.; infinity, neg_infinity; nan, nan; max_float, 5.; -5., max_float ] 184 | [ ""; "asd"; "5." ] 185 | ; make_test 186 | "string" 187 | Alcotest.string 188 | of_string 189 | to_string 190 | to_string_exn 191 | [ ""; "this is a test string"; all_chars ] 192 | [] 193 | ; make_test "unit" Alcotest.unit (fun () -> unit) to_unit to_unit_exn [ () ] [ "asd" ] 194 | ; make_test 195 | "uuid" 196 | Alcotest_ext.uuid 197 | of_uuid 198 | to_uuid 199 | to_uuid_exn 200 | [ Uuidm.create `V4 ] 201 | [ ""; "asd" ] 202 | ] 203 | ;; 204 | -------------------------------------------------------------------------------- /pgx_async.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Pgx using Async for IO" 4 | description: "Pgx using Async for IO" 5 | maintainer: ["Arena Developers "] 6 | authors: ["Arena Developers "] 7 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 8 | homepage: "https://github.com/arenadotio/pgx" 9 | doc: "https://arenadotio.github.io/pgx" 10 | bug-reports: "https://github.com/arenadotio/pgx/issues" 11 | depends: [ 12 | "dune" {>= "3.2"} 13 | "alcotest-async" {with-test & >= "1.0.0"} 14 | "async_kernel" {>= "v0.13.0"} 15 | "async_unix" {>= "v0.13.0"} 16 | "async_ssl" 17 | "base64" {with-test & >= "3.0.0"} 18 | "conduit-async" {>= "1.5.0"} 19 | "ocaml" {>= "4.08"} 20 | "pgx" {= version} 21 | "pgx_value_core" {= version} 22 | "odoc" {with-doc} 23 | ] 24 | build: [ 25 | ["dune" "subst"] {dev} 26 | [ 27 | "dune" 28 | "build" 29 | "-p" 30 | name 31 | "-j" 32 | jobs 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ] 38 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 39 | -------------------------------------------------------------------------------- /pgx_async/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names pgx_async_example) 3 | (libraries pgx_async)) 4 | 5 | (alias 6 | (name examples) 7 | (deps pgx_async_example.exe)) 8 | -------------------------------------------------------------------------------- /pgx_async/bin/pgx_async_example.ml: -------------------------------------------------------------------------------- 1 | (* A basic example of Pgx_async usage *) 2 | open Core_kernel 3 | open Async_kernel 4 | open Async_unix 5 | 6 | module Employee = struct 7 | let create db = 8 | Pgx_async.simple_query 9 | db 10 | {| 11 | CREATE TEMPORARY TABLE Employee ( 12 | id SERIAL PRIMARY KEY, 13 | name VARCHAR(100) NOT NULL UNIQUE); 14 | |} 15 | |> Deferred.ignore_m 16 | ;; 17 | 18 | (* This function lets us insert multiple users relatively efficiently *) 19 | let insert_many db names = 20 | let params = List.map names ~f:(fun name -> Pgx_async.Value.[ of_string name ]) in 21 | Pgx_async.execute_many 22 | db 23 | ~params 24 | ~query: 25 | {| 26 | INSERT INTO Employee (name) 27 | VALUES ($1) 28 | RETURNING id 29 | |} 30 | >>| List.map ~f:(function 31 | | [ [ id ] ] -> Pgx.Value.to_int_exn id 32 | | _ -> assert false) 33 | ;; 34 | 35 | let insert ~name db = insert_many db [ name ] >>| List.hd_exn 36 | end 37 | 38 | module Facility = struct 39 | let create db = 40 | Pgx_async.simple_query 41 | db 42 | {| 43 | CREATE TEMPORARY TABLE Facility ( 44 | id SERIAL PRIMARY KEY, 45 | name VARCHAR(100) NOT NULL UNIQUE, 46 | director_id INT REFERENCES Employee(id) ON DELETE SET NULL); 47 | 48 | CREATE INDEX facility_director_id ON Facility (director_id); 49 | |} 50 | |> Deferred.ignore_m 51 | ;; 52 | 53 | let insert ~name ?director_id db = 54 | let params = Pgx_async.Value.[ of_string name; opt of_int director_id ] in 55 | Pgx_async.execute 56 | db 57 | ~params 58 | {| 59 | INSERT INTO Facility (name, director_id) 60 | VALUES ($1, $2) 61 | RETURNING id 62 | |} 63 | >>| function 64 | | [ [ id ] ] -> Pgx.Value.to_int_exn id 65 | | _ -> assert false 66 | ;; 67 | 68 | let all_name_and_director_name db = 69 | Pgx_async.execute 70 | db 71 | {| 72 | SELECT f.name, e.name 73 | FROM Facility f 74 | LEFT JOIN Employee e ON e.id = f.director_id 75 | |} 76 | >>| List.map ~f:(function 77 | | [ name; director_name ] -> 78 | Pgx.Value.(to_string_exn name, to_string director_name) 79 | | _ -> assert false) 80 | ;; 81 | 82 | let reassign_director db ~director_id ~from_facility_id ~to_facility_id = 83 | (* Note: with_transaction doesn't currently have any special handling 84 | for concurrent queries *) 85 | Pgx_async.with_transaction db 86 | @@ fun db -> 87 | let params = Pgx.Value.[ of_int director_id; of_int from_facility_id ] in 88 | Pgx_async.execute 89 | db 90 | ~params 91 | {| 92 | UPDATE Facility SET director_id = NULL WHERE id = $2 AND director_id = $1 93 | |} 94 | >>= fun _ -> 95 | let params = Pgx.Value.[ of_int director_id; of_int to_facility_id ] in 96 | Pgx_async.execute 97 | db 98 | ~params 99 | {| 100 | UPDATE Facility SET director_id = $1 WHERE id = $2 101 | |} 102 | |> Deferred.ignore_m 103 | ;; 104 | end 105 | 106 | let setup db = Employee.create db >>= fun () -> Facility.create db 107 | 108 | let main () = 109 | Pgx_async.with_conn 110 | @@ fun db -> 111 | setup db 112 | >>= fun () -> 113 | Employee.insert ~name:"Steve" db 114 | >>= fun steve_id -> 115 | (* Parallel queries are not an error, but will execute in serial *) 116 | [ Facility.insert ~name:"Headquarters" ~director_id:steve_id db 117 | ; Facility.insert ~name:"New Office" db 118 | ] 119 | |> Deferred.all 120 | >>= function 121 | | [ headquarters_id; new_office_id ] -> 122 | Facility.all_name_and_director_name db 123 | >>| List.iter ~f:(fun (name, director_name) -> 124 | let director_name = Option.value director_name ~default:"(none)" in 125 | printf "The director of %s is %s\n" name director_name) 126 | >>= fun () -> 127 | print_endline "Re-assigning Steve to the New Office"; 128 | Facility.reassign_director 129 | db 130 | ~director_id:steve_id 131 | ~from_facility_id:headquarters_id 132 | ~to_facility_id:new_office_id 133 | >>= fun () -> 134 | Facility.all_name_and_director_name db 135 | >>| List.iter ~f:(fun (name, director_name) -> 136 | let director_name = Option.value director_name ~default:"(none)" in 137 | printf "The director of %s is %s\n" name director_name) 138 | | _ -> assert false 139 | ;; 140 | 141 | let () = Thread_safe.block_on_async_exn main 142 | -------------------------------------------------------------------------------- /pgx_async/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "(preprocess (pps bisect_ppx))" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx_async) 13 | (wrapped false) 14 | (libraries async_kernel async_unix conduit-async pgx_value_core) 15 | |} ^ preprocess ^ {|) 16 | |} 17 | -------------------------------------------------------------------------------- /pgx_async/src/pgx_async.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async_kernel 3 | open Async_unix 4 | 5 | (* Pgx allows to generate bindings from any module implementing their 6 | THREAD signature which encompasses monadic concurrency + IO. The 7 | implementation that we've chosen here is a deferred represents an 8 | asynchronous value returned by pgx and Writer.t/Reader.t are the 9 | channels it uses for communication *) 10 | 11 | exception Pgx_eof [@@deriving sexp] 12 | 13 | module Thread = struct 14 | type 'a t = 'a Deferred.t 15 | 16 | let return = return 17 | let ( >>= ) = ( >>= ) 18 | 19 | let catch f on_exn = 20 | try_with ~extract_exn:true f 21 | >>= function 22 | | Ok x -> return x 23 | | Error exn -> on_exn exn 24 | ;; 25 | 26 | type sockaddr = 27 | | Unix of string 28 | | Inet of string * int 29 | 30 | type in_channel = Reader.t 31 | type out_channel = Writer.t 32 | 33 | let output_char w char = return (Writer.write_char w char) 34 | let output_string w s = return (Writer.write w s) 35 | 36 | let output_binary_int w n = 37 | let chr = Caml.Char.chr in 38 | Writer.write_char w (chr (n lsr 24)); 39 | Writer.write_char w (chr ((n lsr 16) land 255)); 40 | Writer.write_char w (chr ((n lsr 8) land 255)); 41 | return @@ Writer.write_char w (chr (n land 255)) 42 | ;; 43 | 44 | let flush = Writer.flushed 45 | 46 | let input_char r = 47 | Reader.read_char r 48 | >>| function 49 | | `Ok c -> c 50 | | `Eof -> raise Pgx_eof 51 | ;; 52 | 53 | let input_binary_int r = 54 | let b = Bytes.create 4 in 55 | Reader.really_read r b 56 | >>| function 57 | | `Eof _ -> raise Pgx_eof 58 | | `Ok -> 59 | let code = Caml.Char.code in 60 | (code (Bytes.get b 0) lsl 24) 61 | lor (code (Bytes.get b 1) lsl 16) 62 | lor (code (Bytes.get b 2) lsl 8) 63 | lor code (Bytes.get b 3) 64 | ;; 65 | 66 | let really_input r s pos len = 67 | Reader.really_read r ~pos ~len s 68 | >>| function 69 | | `Ok -> () 70 | | `Eof _ -> raise Pgx_eof 71 | ;; 72 | 73 | let close_in = Reader.close 74 | 75 | let open_connection sockaddr = 76 | match sockaddr with 77 | | Unix path -> Conduit_async.connect (`Unix_domain_socket path) 78 | | Inet (host, port) -> 79 | Uri.make ~host ~port () 80 | |> Conduit_async.V3.resolve_uri 81 | >>= Conduit_async.V3.connect 82 | >>| fun (_socket, in_channel, out_channel) -> in_channel, out_channel 83 | ;; 84 | 85 | type ssl_config = Conduit_async.Ssl.config 86 | 87 | let upgrade_ssl = 88 | try 89 | let default_config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in 90 | `Supported 91 | (fun ?(ssl_config = default_config) in_channel out_channel -> 92 | Conduit_async.V1.Conduit_async_ssl.ssl_connect ssl_config in_channel out_channel) 93 | with 94 | | _ -> `Not_supported 95 | ;; 96 | 97 | (* The unix getlogin syscall can fail *) 98 | let getlogin () = Unix.getuid () |> Unix.Passwd.getbyuid_exn >>| fun { name; _ } -> name 99 | 100 | let debug msg = 101 | Log.Global.debug ~tags:[ "lib", "pgx_async" ] "%s" msg; 102 | Log.Global.flushed () 103 | ;; 104 | 105 | let protect f ~finally = Monitor.protect f ~finally 106 | 107 | module Sequencer = struct 108 | type 'a monad = 'a t 109 | type 'a t = 'a Sequencer.t 110 | 111 | let create t = Sequencer.create ~continue_on_error:true t 112 | let enqueue = Throttle.enqueue 113 | end 114 | end 115 | 116 | include Pgx.Make (Thread) 117 | 118 | (* pgx uses configures this value at build time. But this breaks when 119 | pgx is installed before postgres itself. We prefer to set this variable 120 | at runtime and override the `connect` function from to respect it *) 121 | let default_unix_domain_socket_dir = 122 | let debian_default = "/var/run/postgresql" in 123 | Lazy_deferred.create (fun () -> 124 | Sys.is_directory debian_default 125 | >>| function 126 | | `Yes -> debian_default 127 | | `No | `Unknown -> "/tmp") 128 | ;; 129 | 130 | (* Fail if PGDATABASE environment variable is not set. *) 131 | let check_pgdatabase = 132 | lazy 133 | (let db = "PGDATABASE" in 134 | if Option.is_none (Sys.getenv db) 135 | then failwithf "%s environment variable must be set." db ()) 136 | ;; 137 | 138 | let connect 139 | ?ssl 140 | ?host 141 | ?port 142 | ?user 143 | ?password 144 | ?database 145 | ?unix_domain_socket_dir 146 | ?verbose 147 | ?max_message_length 148 | () 149 | = 150 | if Option.is_none database then Lazy.force check_pgdatabase; 151 | (match unix_domain_socket_dir with 152 | | Some p -> return p 153 | | None -> Lazy_deferred.force_exn default_unix_domain_socket_dir) 154 | >>= fun unix_domain_socket_dir -> 155 | connect 156 | ?ssl 157 | ?host 158 | ?port 159 | ?user 160 | ?password 161 | ?database 162 | ?verbose 163 | ?max_message_length 164 | ~unix_domain_socket_dir 165 | () 166 | ;; 167 | 168 | let with_conn 169 | ?ssl 170 | ?host 171 | ?port 172 | ?user 173 | ?password 174 | ?database 175 | ?unix_domain_socket_dir 176 | ?verbose 177 | ?max_message_length 178 | f 179 | = 180 | connect 181 | ?ssl 182 | ?host 183 | ?port 184 | ?user 185 | ?password 186 | ?database 187 | ?unix_domain_socket_dir 188 | ?verbose 189 | ?max_message_length 190 | () 191 | >>= fun dbh -> Monitor.protect (fun () -> f dbh) ~finally:(fun () -> close dbh) 192 | ;; 193 | 194 | let execute_pipe ?params db query = 195 | Pipe.create_reader ~close_on_exception:false 196 | @@ fun writer -> 197 | execute_iter ?params db query ~f:(fun row -> Pipe.write_if_open writer row) 198 | ;; 199 | 200 | module Value = Pgx_value_core 201 | -------------------------------------------------------------------------------- /pgx_async/src/pgx_async.mli: -------------------------------------------------------------------------------- 1 | (** Async based Postgres client based on Pgx. *) 2 | open Async_kernel 3 | 4 | include 5 | Pgx.S 6 | with type 'a Io.t = 'a Deferred.t 7 | and type Io.ssl_config = Conduit_async.Ssl.config 8 | 9 | (* for testing purposes *) 10 | module Thread : Pgx.Io with type 'a t = 'a Deferred.t 11 | 12 | (** Like [execute] but returns a pipe so you can operate on the results before they have all returned. 13 | Note that [execute_iter] and [execute_fold] can perform significantly better because they don't have 14 | as much overhead. *) 15 | val execute_pipe : ?params:Pgx.row -> t -> string -> Pgx.row Pipe.Reader.t 16 | 17 | (** Exposed for backwards compatiblity. New code should use [Pgx_value_core] directly. *) 18 | module Value = Pgx_value_core 19 | -------------------------------------------------------------------------------- /pgx_async/src/pgx_async_test.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Async_kernel 3 | open Async_unix 4 | module Pga = Pgx_async 5 | 6 | let default_database = "postgres" 7 | let set_to_default_db () = Unix.putenv ~key:"PGDATABASE" ~data:default_database 8 | 9 | let random_db () = 10 | let random_char () = 10 |> Random.int |> Int.to_string |> Char.of_string in 11 | "pgx_test_" ^ String.init 8 ~f:(fun _ -> random_char ()) 12 | ;; 13 | 14 | let ignore_empty = function 15 | | [] -> () 16 | | _ :: _ -> invalid_arg "ignore_empty" 17 | ;; 18 | 19 | let drop_db dbh ~db_name = Pga.execute dbh ("DROP DATABASE " ^ db_name) >>| ignore_empty 20 | 21 | let create_db dbh ~db_name = 22 | Pga.execute dbh ("CREATE DATABASE " ^ db_name) >>| ignore_empty 23 | ;; 24 | 25 | let with_temp_db f = 26 | let db_name = random_db () in 27 | Pga.with_conn ~database:default_database (fun dbh -> 28 | create_db dbh ~db_name 29 | >>= fun () -> 30 | Monitor.protect 31 | (fun () -> Pga.with_conn ~database:db_name (fun test_dbh -> f test_dbh ~db_name)) 32 | ~finally:(fun () -> drop_db dbh ~db_name)) 33 | ;; 34 | 35 | type 'a new_db_callback = Pgx_async.t -> db_name:string -> 'a Deferred.t 36 | 37 | let () = Random.self_init ~allow_in_tests:true () 38 | -------------------------------------------------------------------------------- /pgx_async/src/pgx_async_test.mli: -------------------------------------------------------------------------------- 1 | (** Testing library for code that uses postgres *) 2 | 3 | open Async_kernel 4 | 5 | val set_to_default_db : unit -> unit 6 | 7 | type 'a new_db_callback = Pgx_async.t -> db_name:string -> 'a Deferred.t 8 | 9 | (** [with_temp_db f] creates a temporary database and executes [f] with a database 10 | handle to this db and the name of the db. Once [f] executes or raises, the temp database 11 | will be deleted. *) 12 | val with_temp_db : 'a new_db_callback -> 'a Deferred.t 13 | -------------------------------------------------------------------------------- /pgx_async/test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test_pgx_async) 3 | (package pgx_async) 4 | (libraries alcotest alcotest-async pgx_async pgx_test)) 5 | -------------------------------------------------------------------------------- /pgx_async/test/test_pgx_async.ml: -------------------------------------------------------------------------------- 1 | module Alcotest_io = struct 2 | type 'a test_case = 'a Alcotest_async.test_case 3 | 4 | let test_case name speed f = Alcotest_async.test_case name speed f 5 | 6 | let run name tests = 7 | Async_unix.Thread_safe.block_on_async_exn @@ fun () -> Alcotest_async.run name tests 8 | ;; 9 | end 10 | 11 | include Pgx_test.Make_tests (Pgx_async) (Alcotest_io) 12 | 13 | let () = run_tests ~library_name:"pgx_async" 14 | -------------------------------------------------------------------------------- /pgx_lwt.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Pgx using Lwt for IO" 4 | description: "Pgx using Lwt for IO" 5 | maintainer: ["Arena Developers "] 6 | authors: ["Arena Developers "] 7 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 8 | homepage: "https://github.com/arenadotio/pgx" 9 | doc: "https://arenadotio.github.io/pgx" 10 | bug-reports: "https://github.com/arenadotio/pgx/issues" 11 | depends: [ 12 | "dune" {>= "3.2"} 13 | "lwt" 14 | "logs" 15 | "ocaml" {>= "4.08"} 16 | "pgx" {= version} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 34 | -------------------------------------------------------------------------------- /pgx_lwt/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "(preprocess (pps bisect_ppx))" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx_lwt) 13 | (libraries lwt logs.lwt pgx) 14 | |} ^ preprocess ^ {|) 15 | |} 16 | -------------------------------------------------------------------------------- /pgx_lwt/src/io_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type in_channel 3 | type out_channel 4 | 5 | type sockaddr = 6 | | Unix of string 7 | | Inet of string * int 8 | 9 | val output_char : out_channel -> char -> unit Lwt.t 10 | val output_string : out_channel -> string -> unit Lwt.t 11 | val flush : out_channel -> unit Lwt.t 12 | val input_char : in_channel -> char Lwt.t 13 | val really_input : in_channel -> bytes -> int -> int -> unit Lwt.t 14 | val close_in : in_channel -> unit Lwt.t 15 | val getlogin : unit -> string Lwt.t 16 | val open_connection : sockaddr -> (in_channel * out_channel) Lwt.t 17 | end 18 | -------------------------------------------------------------------------------- /pgx_lwt/src/pgx_lwt.ml: -------------------------------------------------------------------------------- 1 | module Io_intf = Io_intf 2 | 3 | module type S = Pgx.S with type 'a Io.t = 'a Lwt.t 4 | 5 | module Thread = struct 6 | open Lwt 7 | 8 | module Make (Io : Io_intf.S) = struct 9 | type 'a t = 'a Lwt.t 10 | 11 | let return = return 12 | let ( >>= ) = ( >>= ) 13 | let catch = catch 14 | 15 | type sockaddr = Io.sockaddr = 16 | | Unix of string 17 | | Inet of string * int 18 | 19 | type in_channel = Io.in_channel 20 | type out_channel = Io.out_channel 21 | 22 | let output_char = Io.output_char 23 | let output_string = Io.output_string 24 | 25 | let output_binary_int w n = 26 | let chr = Char.chr in 27 | output_char w (chr (n lsr 24)) 28 | >>= fun () -> 29 | output_char w (chr ((n lsr 16) land 255)) 30 | >>= fun () -> 31 | output_char w (chr ((n lsr 8) land 255)) 32 | >>= fun () -> output_char w (chr (n land 255)) 33 | ;; 34 | 35 | let flush = Io.flush 36 | let input_char = Io.input_char 37 | let really_input = Io.really_input 38 | 39 | let input_binary_int r = 40 | let b = Bytes.create 4 in 41 | really_input r b 0 4 42 | >|= fun () -> 43 | let s = Bytes.to_string b in 44 | let code = Char.code in 45 | (code s.[0] lsl 24) lor (code s.[1] lsl 16) lor (code s.[2] lsl 8) lor code s.[3] 46 | ;; 47 | 48 | let close_in = Io.close_in 49 | let open_connection = Io.open_connection 50 | 51 | type ssl_config 52 | 53 | let upgrade_ssl = `Not_supported 54 | let getlogin = Io.getlogin 55 | let debug s = Logs_lwt.debug (fun m -> m "%s" s) 56 | let protect f ~finally = Lwt.finalize f finally 57 | 58 | module Sequencer = struct 59 | type 'a monad = 'a t 60 | type 'a t = 'a * Lwt_mutex.t 61 | 62 | let create t = t, Lwt_mutex.create () 63 | let enqueue (t, mutex) f = Lwt_mutex.with_lock mutex (fun () -> f t) 64 | end 65 | end 66 | end 67 | 68 | module Make (Io : Io_intf.S) = struct 69 | module Thread = Thread.Make (Io) 70 | include Pgx.Make (Thread) 71 | end 72 | -------------------------------------------------------------------------------- /pgx_lwt/src/pgx_lwt.mli: -------------------------------------------------------------------------------- 1 | module Io_intf = Io_intf 2 | 3 | module type S = Pgx.S with type 'a Io.t = 'a Lwt.t 4 | 5 | module Make (Io : Io_intf.S) : S 6 | -------------------------------------------------------------------------------- /pgx_lwt_mirage.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Pgx using Lwt on Mirage for IO" 4 | description: "Pgx using Lwt on Mirage for IO" 5 | maintainer: ["Arena Developers "] 6 | authors: ["Arena Developers "] 7 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 8 | homepage: "https://github.com/arenadotio/pgx" 9 | doc: "https://arenadotio.github.io/pgx" 10 | bug-reports: "https://github.com/arenadotio/pgx/issues" 11 | depends: [ 12 | "dune" {>= "3.2"} 13 | "lwt" 14 | "ocaml" {>= "4.08"} 15 | "logs" 16 | "mirage-channel" 17 | "conduit-mirage" {>= "2.3.0"} 18 | "dns-client" {>= "6.0.0"} 19 | "mirage-random" 20 | "mirage-time" 21 | "mirage-clock" 22 | "tcpip" {>= "7.0.0"} 23 | "pgx" {= version} 24 | "pgx_lwt" {= version} 25 | "odoc" {with-doc} 26 | ] 27 | build: [ 28 | ["dune" "subst"] {dev} 29 | [ 30 | "dune" 31 | "build" 32 | "-p" 33 | name 34 | "-j" 35 | jobs 36 | "@install" 37 | "@runtest" {with-test} 38 | "@doc" {with-doc} 39 | ] 40 | ] 41 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 42 | -------------------------------------------------------------------------------- /pgx_lwt_mirage/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "(preprocess (pps bisect_ppx))" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx_lwt_mirage) 13 | (libraries pgx_lwt lwt logs.lwt pgx mirage-channel conduit-mirage dns-client mirage-random mirage-time mirage-clock tcpip) 14 | |} ^ preprocess ^ {|) 15 | |} 16 | -------------------------------------------------------------------------------- /pgx_lwt_mirage/src/pgx_lwt_mirage.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2020 Petter A. Urkedal 2 | * 3 | * This library is free software; you can redistribute it and/or 4 | * modify it under the terms of the GNU Library General Public 5 | * License as published by the Free Software Foundation; either 6 | * version 2 of the License, or (at your option) any later version, 7 | * with the OCaml static compilation exception. 8 | * 9 | * This library is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | * Library General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU General Public License 15 | * along with this library; see the file COPYING. If not, write to 16 | * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 17 | * Boston, MA 02111-1307, USA. 18 | *) 19 | 20 | open Lwt.Infix 21 | 22 | (* Defining this inline so we can use older lwt versions. *) 23 | let ( let* ) = Lwt.bind 24 | let ( let+ ) t f = Lwt.map f t 25 | 26 | module Make 27 | (RANDOM : Mirage_random.S) 28 | (TIME : Mirage_time.S) 29 | (MCLOCK : Mirage_clock.MCLOCK) 30 | (PCLOCK : Mirage_clock.PCLOCK) 31 | (STACK : Tcpip.Stack.V4V6) = 32 | struct 33 | module Channel = Mirage_channel.Make (STACK.TCP) 34 | 35 | module Thread = struct 36 | type sockaddr = 37 | | Unix of string 38 | | Inet of string * int 39 | 40 | type in_channel = Channel.t 41 | type out_channel = Channel.t 42 | 43 | let output_char oc c = 44 | Channel.write_char oc c; 45 | Lwt.return_unit 46 | ;; 47 | 48 | let output_string oc s = 49 | Channel.write_string oc s 0 (String.length s); 50 | Lwt.return_unit 51 | ;; 52 | 53 | let flush oc = 54 | Channel.flush oc 55 | >>= function 56 | | Ok () -> Lwt.return_unit 57 | | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err) 58 | ;; 59 | 60 | let input_char ic = 61 | Channel.read_char ic 62 | >>= function 63 | | Ok (`Data c) -> Lwt.return c 64 | | Ok `Eof -> Lwt.fail End_of_file 65 | | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err) 66 | ;; 67 | 68 | let really_input ic buf off len = 69 | Channel.read_exactly ~len ic 70 | >>= function 71 | | Ok (`Data bufs) -> 72 | let content = Cstruct.copyv bufs in 73 | Bytes.blit_string content 0 buf off len; 74 | Lwt.return_unit 75 | | Ok `Eof -> Lwt.fail End_of_file 76 | | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err) 77 | ;; 78 | 79 | let close_in oc = 80 | Channel.close oc 81 | >>= function 82 | | Ok () -> Lwt.return_unit 83 | | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err) 84 | ;; 85 | 86 | let getlogin () = Lwt.fail_with "Running under MirageOS. getlogin not available." 87 | end 88 | 89 | module Dns = Dns_client_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK) 90 | 91 | type sockaddr = Thread.sockaddr = 92 | | Unix of string 93 | | Inet of string * int 94 | 95 | module TCP = Conduit_mirage.TCP (STACK) 96 | 97 | let connect_stack stack sockaddr = 98 | let dns = Dns.create stack in 99 | let* client = 100 | match sockaddr with 101 | | Unix _ -> Lwt.fail_with "Running under MirageOS. Unix sockets are not available." 102 | | Inet (host, port) -> 103 | (match Ipaddr.of_string host with 104 | | Ok ipaddr -> Lwt.return (`TCP (ipaddr, port)) 105 | | Error _ -> 106 | let host' = host |> Domain_name.of_string_exn |> Domain_name.host_exn in 107 | Dns.gethostbyname dns host' 108 | >>= (function 109 | | Ok ipaddr -> Lwt.return (`TCP (Ipaddr.V4 ipaddr, port)) 110 | | Error (`Msg msg) -> Lwt.fail_with msg)) 111 | in 112 | let+ flow = TCP.connect stack client in 113 | let ch = Channel.create flow in 114 | ch, ch 115 | ;; 116 | 117 | let connect stack = 118 | let open_connection = connect_stack stack in 119 | (module struct 120 | module T : Pgx_lwt.Io_intf.S = struct 121 | include Thread 122 | 123 | let open_connection = open_connection 124 | end 125 | 126 | include Pgx_lwt.Make (T) 127 | end : Pgx_lwt.S) 128 | ;; 129 | end 130 | -------------------------------------------------------------------------------- /pgx_lwt_mirage/src/pgx_lwt_mirage.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (C) 2020 Petter A. Urkedal 2 | * 3 | * This library is free software; you can redistribute it and/or 4 | * modify it under the terms of the GNU Library General Public 5 | * License as published by the Free Software Foundation; either 6 | * version 2 of the License, or (at your option) any later version, 7 | * with the OCaml static compilation exception. 8 | * 9 | * This library is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | * Library General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU General Public License 15 | * along with this library; see the file COPYING. If not, write to 16 | * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 17 | * Boston, MA 02111-1307, USA. 18 | *) 19 | 20 | module Make 21 | (RANDOM : Mirage_random.S) 22 | (TIME : Mirage_time.S) 23 | (MCLOCK : Mirage_clock.MCLOCK) 24 | (PCLOCK : Mirage_clock.PCLOCK) 25 | (STACK : Tcpip.Stack.V4V6) : sig 26 | val connect : STACK.t -> (module Pgx_lwt.S) 27 | end 28 | -------------------------------------------------------------------------------- /pgx_lwt_unix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Pgx using Lwt and Unix libraries for IO" 4 | description: "Pgx using Lwt and Unix libraries for IO" 5 | maintainer: ["Arena Developers "] 6 | authors: ["Arena Developers "] 7 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 8 | homepage: "https://github.com/arenadotio/pgx" 9 | doc: "https://arenadotio.github.io/pgx" 10 | bug-reports: "https://github.com/arenadotio/pgx/issues" 11 | depends: [ 12 | "dune" {>= "3.2"} 13 | "alcotest-lwt" {with-test & >= "1.0.0"} 14 | "base64" {with-test & >= "3.0.0"} 15 | "ocaml" {>= "4.08"} 16 | "pgx" {= version} 17 | "pgx_lwt" {= version} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 35 | -------------------------------------------------------------------------------- /pgx_lwt_unix/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "(preprocess (pps bisect_ppx))" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx_lwt_unix) 13 | (libraries pgx pgx_lwt lwt.unix) 14 | |} ^ preprocess ^ {|) 15 | |} 16 | -------------------------------------------------------------------------------- /pgx_lwt_unix/src/pgx_lwt_unix.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | module Thread : Pgx_lwt.Io_intf.S = struct 4 | type sockaddr = 5 | | Unix of string 6 | | Inet of string * int 7 | 8 | type in_channel = Lwt_io.input_channel 9 | type out_channel = Lwt_io.output_channel 10 | 11 | let output_char = Lwt_io.write_char 12 | let output_string = Lwt_io.write 13 | let flush = Lwt_io.flush 14 | let input_char = Lwt_io.read_char 15 | let really_input = Lwt_io.read_into_exactly 16 | let close_in = Lwt_io.close 17 | 18 | (* The unix getlogin syscall can fail *) 19 | let getlogin () = 20 | Unix.getuid () |> Lwt_unix.getpwuid >|= fun { Lwt_unix.pw_name; _ } -> pw_name 21 | ;; 22 | 23 | let open_connection sockaddr = 24 | (match sockaddr with 25 | | Unix path -> return (Unix.ADDR_UNIX path) 26 | | Inet (hostname, port) -> 27 | Lwt_unix.gethostbyname hostname 28 | >|= fun { Lwt_unix.h_addr_list; _ } -> 29 | let len = Array.length h_addr_list in 30 | let i = Random.int len in 31 | let addr = h_addr_list.(i) in 32 | Unix.ADDR_INET (addr, port)) 33 | >>= Lwt_io.open_connection 34 | ;; 35 | end 36 | 37 | include Pgx_lwt.Make (Thread) 38 | -------------------------------------------------------------------------------- /pgx_lwt_unix/src/pgx_lwt_unix.mli: -------------------------------------------------------------------------------- 1 | include Pgx_lwt.S 2 | -------------------------------------------------------------------------------- /pgx_lwt_unix/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_pgx_lwt) 3 | (package pgx_lwt_unix) 4 | (libraries alcotest alcotest-lwt pgx_test pgx_lwt_unix)) 5 | -------------------------------------------------------------------------------- /pgx_lwt_unix/test/test_pgx_lwt.ml: -------------------------------------------------------------------------------- 1 | module Alcotest_io = struct 2 | type 'a test_case = 'a Alcotest_lwt.test_case 3 | 4 | let test_case name speed f = Alcotest_lwt.test_case name speed (fun _ -> f) 5 | let run name tests = Alcotest_lwt.run name tests |> Lwt_main.run 6 | end 7 | 8 | include Pgx_test.Make_tests (Pgx_lwt_unix) (Alcotest_io) 9 | 10 | let () = run_tests ~library_name:"pgx_lwt_unix" 11 | -------------------------------------------------------------------------------- /pgx_test/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name pgx_test) 3 | (libraries alcotest base64 pgx)) 4 | -------------------------------------------------------------------------------- /pgx_test/src/pgx_test.ml: -------------------------------------------------------------------------------- 1 | external reraise : exn -> _ = "%reraise" 2 | 3 | module type S = sig 4 | val run_tests : library_name:string -> unit 5 | end 6 | 7 | module type ALCOTEST_IO = sig 8 | open Alcotest 9 | 10 | type 'a monad 11 | type 'a test_case 12 | 13 | val test_case : string -> speed_level -> ('a -> unit monad) -> 'a test_case 14 | val run : string -> (string * unit test_case list) list -> unit 15 | end 16 | 17 | module Alcotest_ext = struct 18 | let uuid = Alcotest.testable Uuidm.pp Uuidm.equal 19 | 20 | let pgx_value = 21 | Alcotest.testable 22 | (fun fmt t -> 23 | Pgx.Value.sexp_of_t t |> Sexplib0.Sexp.to_string_hum |> Format.pp_print_string fmt) 24 | (fun a b -> Pgx.Value.compare a b = 0) 25 | ;; 26 | end 27 | 28 | let check_result = Alcotest.(check (list (list Alcotest_ext.pgx_value))) 29 | let check_results = Alcotest.(check (list (list (list Alcotest_ext.pgx_value)))) 30 | 31 | module Make_tests 32 | (Pgx_impl : Pgx.S) 33 | (Alcotest_io : ALCOTEST_IO with type 'a monad := 'a Pgx_impl.Io.t) = 34 | struct 35 | open Pgx_impl.Io 36 | open Pgx_impl 37 | 38 | let default_database = "postgres" 39 | 40 | let have_pg_config = 41 | try 42 | Unix.getenv "PGUSER" |> ignore; 43 | true 44 | with 45 | | Not_found -> false 46 | ;; 47 | 48 | let force_tests = 49 | try 50 | (Unix.getenv "PGX_FORCE_TESTS" : string) |> ignore; 51 | true 52 | with 53 | | Not_found -> false 54 | ;; 55 | 56 | let set_to_default_db () = Unix.putenv "PGDATABASE" default_database 57 | let ( >>| ) x f = x >>= fun x -> return (f x) 58 | 59 | type ('a, 'b) result = 60 | | Ok of 'a 61 | | Error of 'b 62 | 63 | let try_with f = 64 | catch (fun () -> f () >>| fun res -> Ok res) (fun e -> return (Error e)) 65 | ;; 66 | 67 | let with_temp_db f = 68 | let random_db () = 69 | let random_char () = 10 |> Random.int |> string_of_int |> fun s -> s.[0] in 70 | "pgx_test_" ^ String.init 8 (fun _ -> random_char ()) 71 | in 72 | let ignore_empty = function 73 | | [] -> () 74 | | _ :: _ -> invalid_arg "ignore_empty" 75 | in 76 | let create_db dbh ~db_name = 77 | execute dbh ("CREATE DATABASE " ^ db_name) >>| ignore_empty 78 | in 79 | let drop_db dbh ~db_name = 80 | execute dbh ("DROP DATABASE " ^ db_name) >>| ignore_empty 81 | in 82 | with_conn ~database:default_database (fun dbh -> 83 | let db_name = random_db () in 84 | create_db dbh ~db_name 85 | >>= fun () -> 86 | connect ~database:db_name () 87 | >>= fun test_dbh -> 88 | protect 89 | (fun () -> f test_dbh ~db_name) 90 | ~finally:(fun () -> close test_dbh >>= fun () -> drop_db dbh ~db_name)) 91 | ;; 92 | 93 | let assert_error_test query () = 94 | try_with (fun () -> with_conn @@ fun dbh -> execute dbh query) 95 | >>= function 96 | | Ok _ -> failwith "error expected" 97 | | Error _ -> return () 98 | ;; 99 | 100 | let deferred_list_map l ~f = 101 | List.fold_left 102 | (fun acc x -> acc >>= fun acc -> f x >>| fun res -> res :: acc) 103 | (return []) 104 | l 105 | >>| List.rev 106 | ;; 107 | 108 | let list_init n f = 109 | let rec output_list x = if x < n then f x :: output_list (x + 1) else [] in 110 | output_list 0 111 | ;; 112 | 113 | let run_tests ~library_name = 114 | Random.self_init (); 115 | set_to_default_db (); 116 | let tests = 117 | [ Alcotest_io.test_case "test db connection" `Quick (fun () -> 118 | with_temp_db (fun _ ~db_name:_ -> return true) 119 | >>| Alcotest.(check bool) "with_temp_db makes a connection" true) 120 | ; Alcotest_io.test_case 121 | "test fake table" 122 | `Quick 123 | (assert_error_test "SELECT * FROM non_exist") 124 | ; Alcotest_io.test_case "query - 1 query" `Quick (fun () -> 125 | with_conn (fun dbh -> 126 | simple_query dbh "select 1" 127 | >>| check_results "select 1" [ [ [ Pgx.Value.of_string "1" ] ] ])) 128 | ; Alcotest_io.test_case "query - multiple" `Quick (fun () -> 129 | with_conn (fun dbh -> 130 | simple_query dbh "select 1; select 2; select 3" 131 | >>| check_results 132 | "select three" 133 | Pgx.Value. 134 | [ [ [ of_string "1" ] ] 135 | ; [ [ of_string "2" ] ] 136 | ; [ [ of_string "3" ] ] 137 | ])) 138 | ; Alcotest_io.test_case "query - multiple single query" `Quick (fun () -> 139 | with_conn (fun dbh -> 140 | simple_query dbh "select 1 union all select 2 union all select 3" 141 | >>| check_results 142 | "select unit all" 143 | Pgx.Value. 144 | [ [ [ of_string "1" ]; [ of_string "2" ]; [ of_string "3" ] ] ])) 145 | ; Alcotest_io.test_case "query - empty" `Quick (fun () -> 146 | with_conn (fun dbh -> simple_query dbh "" >>| check_results "empty query" [])) 147 | ; Alcotest_io.test_case 148 | "test fake column" 149 | `Quick 150 | (assert_error_test "SELECT qqq FROM pg_locks") 151 | ; Alcotest_io.test_case "transaction error recovery" `Quick (fun () -> 152 | with_conn 153 | @@ fun dbh -> 154 | try_with (fun () -> 155 | with_transaction dbh (fun dbh -> simple_query dbh "select * from fake")) 156 | >>| function 157 | | Ok _ -> Alcotest.fail "test should fail. table doesn't exist" 158 | | Error _ -> ()) 159 | ; Alcotest_io.test_case "NoticeResponse in query" `Quick (fun () -> 160 | with_conn 161 | @@ fun dbh -> 162 | simple_query dbh "DROP VIEW IF EXISTS fake_view_doesnt_exist" 163 | >>| List.iter (check_result "drop view if exists" [])) 164 | ; Alcotest_io.test_case "test fold" `Quick (fun () -> 165 | with_conn 166 | @@ fun dbh -> 167 | Prepared.( 168 | with_prepare dbh ~query:"values (1,2),(3,4)" ~f:(fun s -> 169 | execute_fold s ~params:[] ~init:[] ~f:(fun acc a -> return (a :: acc)))) 170 | >>| check_result 171 | "fold values" 172 | Pgx.Value. 173 | [ [ of_string "3"; of_string "4" ]; [ of_string "1"; of_string "2" ] ]) 174 | ; Alcotest_io.test_case "test execute_prepared" `Quick (fun () -> 175 | with_conn 176 | @@ fun dbh -> 177 | Prepared.(prepare dbh ~query:"values (1,2),(3,4)" >>= execute ~params:[]) 178 | >>| check_result 179 | "prepare & execute" 180 | Pgx.Value. 181 | [ [ of_string "1"; of_string "2" ]; [ of_string "3"; of_string "4" ] ]) 182 | ; Alcotest_io.test_case "test execute_iter" `Quick (fun () -> 183 | let n = ref 0 in 184 | let rows = Array.make 2 [] in 185 | with_conn 186 | @@ fun dbh -> 187 | execute_iter dbh "values (1,2),(3,4)" ~f:(fun row -> 188 | rows.(!n) <- row; 189 | n := !n + 1; 190 | return ()) 191 | >>| fun () -> 192 | Array.to_list rows 193 | |> check_result 194 | "execute_iter" 195 | Pgx.Value. 196 | [ [ of_string "1"; of_string "2" ]; [ of_string "3"; of_string "4" ] ]) 197 | ; Alcotest_io.test_case "with_prepare" `Quick (fun () -> 198 | with_conn 199 | @@ fun dbh -> 200 | let name = "with_prepare" in 201 | Prepared.( 202 | with_prepare dbh ~name ~query:"values ($1)" ~f:(fun s -> 203 | execute s ~params:Pgx.Value.[ of_string "test" ])) 204 | >>| check_result name Pgx.Value.[ [ of_string "test" ] ]) 205 | ; Alcotest_io.test_case "interleave unnamed prepares" `Quick (fun () -> 206 | with_conn 207 | @@ fun dbh -> 208 | let open Prepared in 209 | with_prepare dbh ~query:"values ($1)" ~f:(fun s1 -> 210 | with_prepare dbh ~query:"values (1)" ~f:(fun s2 -> 211 | execute s1 ~params:Pgx.Value.[ of_string "test" ] 212 | >>= fun r1 -> execute s2 ~params:[] >>| fun r2 -> r1, r2)) 213 | >>| fun (r1, r2) -> 214 | check_result "outer prepare" Pgx.Value.[ [ of_string "test" ] ] r1; 215 | check_result "inner prepare" Pgx.Value.[ [ of_string "1" ] ] r2) 216 | ; Alcotest_io.test_case "in_transaction invariant" `Quick (fun () -> 217 | with_conn 218 | @@ fun dbh -> 219 | try_with (fun () -> 220 | with_transaction dbh (fun dbh -> 221 | with_transaction dbh (fun _ -> return "unreachable"))) 222 | >>| function 223 | | Ok "unreachable" -> failwith "in_transaction invariant failed" 224 | | Ok _ -> assert false 225 | | Error (Invalid_argument _) -> () 226 | | Error exn -> reraise exn) 227 | ; Alcotest_io.test_case "triple prepare no infinite loop" `Quick (fun () -> 228 | with_conn 229 | @@ fun dbh -> 230 | let name = "triple_prepare" in 231 | let p () = Prepared.prepare ~name dbh ~query:"values (1,2)" in 232 | p () 233 | >>= fun _ -> 234 | try_with p 235 | >>= fun _ -> 236 | try_with p 237 | >>| function 238 | | Ok _ -> failwith "Triple prepare should fail" 239 | | Error (Pgx.PostgreSQL_Error _) -> () 240 | | Error exn -> reraise exn) 241 | ; Alcotest_io.test_case "execute_many function" `Quick (fun () -> 242 | let params = 243 | Pgx.Value.[ [ of_string "1" ]; [ of_string "2" ]; [ of_string "3" ] ] 244 | in 245 | with_conn (fun dbh -> 246 | execute_many dbh ~query:"select $1::int" ~params 247 | >>| check_results 248 | "execute_many result" 249 | Pgx.Value. 250 | [ [ [ of_string "1" ] ] 251 | ; [ [ of_string "2" ] ] 252 | ; [ [ of_string "3" ] ] 253 | ])) 254 | ; Alcotest_io.test_case "query with SET" `Quick (fun () -> 255 | with_conn (fun dbh -> 256 | simple_query dbh "SET LOCAL TIME ZONE 'Europe/Rome'; SELECT 'x'" 257 | >>| function 258 | | [ []; [ [ res ] ] ] -> 259 | Pgx.Value.to_string_exn res 260 | |> Alcotest.(check string) "SELECT after SET" "x" 261 | | _ -> assert false)) 262 | ; Alcotest_io.test_case "ping" `Quick (fun () -> with_conn (fun dbh -> ping dbh)) 263 | ; Alcotest_io.test_case "with_prepare and describe_statement" `Quick (fun () -> 264 | with_conn 265 | @@ fun dbh -> 266 | let name = "some name" in 267 | Prepared.(with_prepare dbh ~name ~query:"values ($1)" ~f:describe) 268 | >>| fun _ -> ()) 269 | ; Alcotest_io.test_case "should fail without sequencer" `Quick (fun () -> 270 | with_conn (fun dbh -> 271 | deferred_list_map 272 | (list_init 100 (fun x -> x)) 273 | ~f:(fun _ -> simple_query dbh "") 274 | >>| fun _ -> ())) 275 | ; Alcotest_io.test_case "copy out simple query" `Quick (fun () -> 276 | with_temp_db (fun dbh ~db_name:_ -> 277 | simple_query 278 | dbh 279 | "CREATE TABLE tennis_greats ( name varchar(40), \ 280 | grand_slams integer); INSERT INTO tennis_greats VALUES ('Roger \ 281 | Federer', 19), ('Rafael Nadal', 15); COPY tennis_greats TO STDOUT \ 282 | (DELIMITER '|')" 283 | >>| check_results 284 | "copy out result" 285 | Pgx.Value. 286 | [ [] 287 | ; [] 288 | ; [ [ of_string "Roger Federer|19\n" ] 289 | ; [ of_string "Rafael Nadal|15\n" ] 290 | ] 291 | ])) 292 | ; Alcotest_io.test_case "copy out extended query" `Quick (fun () -> 293 | with_temp_db (fun dbh ~db_name:_ -> 294 | execute 295 | dbh 296 | "CREATE TABLE tennis_greats ( name varchar(40), \ 297 | grand_slams integer);" 298 | >>= fun _ -> 299 | execute 300 | dbh 301 | "INSERT INTO tennis_greats VALUES ('Roger Federer', 19), ('Rafael \ 302 | Nadal', 15);" 303 | >>= fun _ -> execute dbh "COPY tennis_greats TO STDOUT (DELIMITER '|')") 304 | >>| check_result 305 | "copy out extended result" 306 | Pgx.Value. 307 | [ [ of_string "Roger Federer|19\n" ] 308 | ; [ of_string "Rafael Nadal|15\n" ] 309 | ]) 310 | ; Alcotest_io.test_case "execute_prepared_iter and transact test" `Quick (fun () -> 311 | with_temp_db (fun dbh ~db_name:_ -> 312 | with_transaction dbh (fun dbh -> 313 | execute 314 | dbh 315 | "CREATE TABLE tennis_greats ( name varchar(40), \ 316 | grand_slams integer);" 317 | >>= fun _ -> 318 | execute 319 | dbh 320 | "INSERT INTO tennis_greats VALUES ('Roger Federer', 19), ('Rafael \ 321 | Nadal', 15);" 322 | >>= fun _ -> 323 | let open Prepared in 324 | with_prepare 325 | dbh 326 | ~query: 327 | "SELECT * FROM tennis_greats WHERE name=$1 AND grand_slams=$2" 328 | ~f:(fun s -> 329 | let acc = ref [] in 330 | execute_iter 331 | s 332 | ~params:Pgx.Value.[ of_string "Roger Federer"; of_int 19 ] 333 | ~f:(fun fields -> return (acc := fields :: !acc)) 334 | >>= fun () -> return !acc)) 335 | >>| check_result 336 | "prepare & transact result" 337 | Pgx.Value.[ [ of_string "Roger Federer"; of_string "19" ] ])) 338 | ; Alcotest_io.test_case "commit while not in transaction" `Quick (fun () -> 339 | try_with (fun () -> 340 | with_conn 341 | @@ fun dbh -> 342 | begin_work dbh >>= fun dbh -> commit dbh >>= fun () -> commit dbh) 343 | >>= function 344 | | Ok _ -> failwith "commit while not in transaction error expected" 345 | | Error _ -> return ()) 346 | ; Alcotest_io.test_case "rollback while not in transaction" `Quick (fun () -> 347 | try_with (fun () -> 348 | with_conn 349 | @@ fun dbh -> 350 | begin_work dbh >>= fun dbh -> commit dbh >>= fun () -> rollback dbh) 351 | >>= function 352 | | Ok _ -> failwith "rollback while not in transaction error expected" 353 | | Error _ -> return ()) 354 | ; Alcotest_io.test_case "alive test" `Quick (fun () -> 355 | with_conn 356 | @@ fun dbh -> alive dbh >>| Alcotest.(check bool) "alive result" true) 357 | ; Alcotest_io.test_case "isolation level tests" `Quick (fun () -> 358 | with_temp_db (fun dbh ~db_name:_ -> 359 | execute 360 | dbh 361 | "CREATE TABLE tennis_greats ( name varchar(40), \ 362 | grand_slams integer);" 363 | >>= fun _ -> 364 | with_transaction ~isolation:Pgx.Isolation.Serializable dbh (fun dbh -> 365 | execute dbh "INSERT INTO tennis_greats VALUES ('Roger Federer', 19);") 366 | >>= fun _ -> 367 | with_transaction ~isolation:Pgx.Isolation.Repeatable_read dbh (fun dbh -> 368 | execute dbh "INSERT INTO tennis_greats VALUES ('Rafael Nadal', 15);") 369 | >>= fun _ -> 370 | with_transaction ~isolation:Pgx.Isolation.Read_committed dbh (fun dbh -> 371 | execute dbh "INSERT INTO tennis_greats VALUES ('Novak Djokovic', 12);") 372 | >>= fun _ -> 373 | with_transaction ~isolation:Pgx.Isolation.Read_uncommitted dbh (fun dbh -> 374 | execute dbh "INSERT INTO tennis_greats VALUES ('Andy Murray', 3);") 375 | >>= fun _ -> 376 | let open Prepared in 377 | with_prepare 378 | dbh 379 | ~query:"SELECT * FROM tennis_greats WHERE name=$1 AND grand_slams=$2" 380 | ~f:(fun s -> 381 | let acc = ref [] in 382 | execute_iter 383 | s 384 | ~params:Pgx.Value.[ of_string "Andy Murray"; of_string "3" ] 385 | ~f:(fun fields -> return (acc := fields :: !acc)) 386 | >>= fun () -> return !acc) 387 | >>| check_result 388 | "isolation query result" 389 | Pgx.Value.[ [ of_string "Andy Murray"; of_string "3" ] ])) 390 | ; Alcotest_io.test_case "multi typed table" `Quick (fun () -> 391 | with_temp_db (fun dbh ~db_name:_ -> 392 | simple_query 393 | dbh 394 | "CREATE TABLE multi_typed(uuid uuid, int int, string text, numeric \ 395 | numeric);" 396 | >>= fun _ -> 397 | let expect_uuid = Uuidm.create `V4 in 398 | let params = 399 | let open Pgx.Value in 400 | [ of_uuid expect_uuid 401 | ; of_int 12 402 | ; of_string "asdf" 403 | ; of_string "9223372036854775807" 404 | ] 405 | in 406 | execute 407 | dbh 408 | ~params 409 | "INSERT INTO multi_typed (uuid, int, string, numeric) VALUES ($1, $2, \ 410 | $3, $4)" 411 | >>= fun _ -> 412 | simple_query dbh "SELECT * FROM multi_typed" 413 | >>| function 414 | | [ [ [ uuid; int_; string_; numeric ] ] ] -> 415 | let open Pgx.Value in 416 | let uuid = to_uuid uuid in 417 | let int_ = to_int int_ in 418 | let string_ = to_string string_ in 419 | let numeric = to_string numeric in 420 | Alcotest.(Alcotest_ext.(check (option uuid))) 421 | "uuid" 422 | (Some expect_uuid) 423 | uuid; 424 | Alcotest.(check (option int)) "int" (Some 12) int_; 425 | Alcotest.(check (option string)) "string" (Some "asdf") string_; 426 | Alcotest.(check (option string)) 427 | "numeric" 428 | (Some "9223372036854775807") 429 | numeric 430 | | _ -> 431 | Alcotest.fail "Error: multi typed table: got unexpected query result")) 432 | ; Alcotest_io.test_case "binary string handling" `Quick (fun () -> 433 | let all_chars = String.init 255 char_of_int in 434 | with_conn (fun db -> 435 | [ ( "SELECT decode($1, 'base64')::bytea" 436 | , Base64.encode_exn all_chars |> Pgx.Value.of_string 437 | , Pgx.Value.to_binary_exn 438 | , all_chars ) 439 | (* Postgres adds whitespace to base64 encodings, so we strip it 440 | back out *) 441 | ; ( "SELECT regexp_replace(encode($1::bytea, 'base64'), '\\s', '', 'g')" 442 | , Pgx.Value.of_binary all_chars 443 | , Pgx.Value.to_string_exn 444 | , Base64.encode_exn all_chars ) 445 | ] 446 | |> deferred_list_map ~f:(fun (query, param, read_f, expect) -> 447 | let params = [ param ] in 448 | execute ~params db query 449 | >>| function 450 | | [ [ actual ] ] -> 451 | read_f actual |> Alcotest.(check string) "binary string" expect 452 | | _ -> assert false)) 453 | >>| List.iter (fun () -> ())) 454 | ; Alcotest_io.test_case "binary string round-trip" `Quick (fun () -> 455 | let all_chars = String.init 255 char_of_int in 456 | with_conn (fun db -> 457 | (* This binary string should get encoded as hex and stored as one byte-per-byte of input *) 458 | let params = [ Pgx.Value.of_binary all_chars ] in 459 | (* Checking here that Postgres doesn't throw an exception about null characters in input, since 460 | our encoded input has no null chars *) 461 | execute ~params db "SELECT $1::bytea, octet_length($1::bytea)" 462 | >>| function 463 | | [ [ value; length ] ] -> 464 | Pgx.Value.to_binary_exn value 465 | |> Alcotest.(check string) "binary string contents" all_chars; 466 | (* Our string is 255 bytes so it should be stored as 255 bytes, not as 512 (the length of the 467 | encoded hex). What we're testing here is that we're actually storing binary, not hex 468 | encoded binary *) 469 | Pgx.Value.to_int_exn length 470 | |> Alcotest.(check int) "binary string length" 255 471 | | _ -> assert false)) 472 | ; Alcotest_io.test_case "Non-binary literal hex string round-trip" `Quick (fun () -> 473 | with_conn (fun db -> 474 | (* This hex string should get inserted into the DB as literally "\x0001etc" *) 475 | let input = 476 | "\\x000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfe" 477 | in 478 | let params = [ Pgx.Value.of_string input ] in 479 | execute ~params db "SELECT $1::varchar, octet_length($1::varchar)" 480 | >>| function 481 | | [ [ value; length ] ] -> 482 | Pgx.Value.to_string_exn value 483 | |> Alcotest.(check string) "string contents" input; 484 | Pgx.Value.to_int_exn length |> Alcotest.(check int) "string length" 512 485 | | _ -> assert false)) 486 | ; Alcotest_io.test_case "Binary literal hex string round-trip" `Quick (fun () -> 487 | with_conn (fun db -> 488 | (* This hex string should get double encoded so it makes it into the DB as literally "\x0001etc" *) 489 | let input = 490 | "\\x000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfe" 491 | in 492 | let params = [ Pgx.Value.of_binary input ] in 493 | execute ~params db "SELECT $1::bytea, octet_length($1::bytea)" 494 | >>| function 495 | | [ [ value; length ] ] -> 496 | Pgx.Value.to_binary_exn value 497 | |> Alcotest.(check string) "string contents" input; 498 | Pgx.Value.to_int_exn length |> Alcotest.(check int) "string length" 512 499 | | _ -> assert false)) 500 | ; Alcotest_io.test_case "UTF-8 partial round-trip 1" `Quick (fun () -> 501 | (* Select a literal string *) 502 | let expect = "test-ä-test" in 503 | with_conn (fun db -> 504 | simple_query 505 | db 506 | {| 507 | CREATE TEMPORARY TABLE this_test (id text); 508 | INSERT INTO this_test (id) VALUES ('test-ä-test') 509 | |} 510 | >>= fun _ -> 511 | execute db "SELECT id FROM this_test" 512 | >>| function 513 | | [ [ result ] ] -> 514 | Alcotest.(check (option string)) 515 | "" 516 | (Some expect) 517 | (Pgx.Value.to_string result) 518 | | _ -> assert false)) 519 | ; Alcotest_io.test_case "UTF-8 partial round-trip 1 with where" `Quick (fun () -> 520 | (* Select a literal string *) 521 | let expect = "test-ä-test" in 522 | with_conn (fun db -> 523 | simple_query 524 | db 525 | {| 526 | CREATE TEMPORARY TABLE this_test (id text); 527 | INSERT INTO this_test (id) VALUES ('test-ä-test') 528 | |} 529 | >>= fun _ -> 530 | execute 531 | db 532 | ~params:[ Pgx.Value.of_string expect ] 533 | "SELECT id FROM this_test WHERE id = $1" 534 | >>| function 535 | | [ [ result ] ] -> 536 | Alcotest.(check (option string)) 537 | "" 538 | (Some expect) 539 | (Pgx.Value.to_string result) 540 | | [] -> Alcotest.fail "Expected one row but got zero" 541 | | _ -> assert false)) 542 | ; Alcotest_io.test_case "UTF-8 partial round-trip 2" `Quick (fun () -> 543 | (* Insert string as a param, then select back the contents of 544 | the table *) 545 | let expect = "test-ä-test" in 546 | with_conn (fun db -> 547 | simple_query db "CREATE TEMPORARY TABLE this_test (id text)" 548 | >>= fun _ -> 549 | execute 550 | db 551 | ~params:[ Pgx.Value.of_string expect ] 552 | "INSERT INTO this_test (id) VALUES ($1)" 553 | >>= fun _ -> 554 | execute db "SELECT id FROM this_test" 555 | >>| function 556 | | [ [ result ] ] -> 557 | Alcotest.(check (option string)) 558 | "" 559 | (Some expect) 560 | (Pgx.Value.to_string result) 561 | | _ -> assert false)) 562 | ; Alcotest_io.test_case "UTF-8 partial round-trip 3" `Quick (fun () -> 563 | with_conn (fun db -> 564 | simple_query 565 | db 566 | {| 567 | CREATE TEMPORARY TABLE this_test (id text); 568 | INSERT INTO this_test (id) VALUES('test-\303\244-test') 569 | |} 570 | >>= fun _ -> 571 | execute db "SELECT id FROM this_test" 572 | >>| function 573 | | [ [ result ] ] -> 574 | Alcotest.(check string) 575 | "" 576 | {|test-\303\244-test|} 577 | (Pgx.Value.to_string_exn result) 578 | | _ -> assert false)) 579 | ; Alcotest_io.test_case "UTF-8 round-trip" `Quick (fun () -> 580 | (* Select the contents of a param *) 581 | let expect = "test-ä-test" in 582 | with_conn (fun db -> 583 | execute db ~params:[ Pgx.Value.of_string expect ] "SELECT $1::VARCHAR" 584 | >>| function 585 | | [ [ result ] ] -> 586 | Alcotest.(check (option string)) 587 | "" 588 | (Some expect) 589 | (Pgx.Value.to_string result) 590 | | _ -> assert false)) 591 | ; Alcotest_io.test_case "UTF-8 round-trip where" `Quick (fun () -> 592 | (* Insert string as a param, then select back the contents of 593 | the table using a WHERE *) 594 | let expect = "test-ä-test" in 595 | with_conn (fun db -> 596 | simple_query db "CREATE TEMPORARY TABLE this_test (id text)" 597 | >>= fun _ -> 598 | execute 599 | db 600 | ~params:[ Pgx.Value.of_string expect ] 601 | "INSERT INTO this_test (id) VALUES ($1)" 602 | >>= fun _ -> 603 | execute 604 | db 605 | ~params:[ Pgx.Value.of_string expect ] 606 | "SELECT id FROM this_test WHERE id = $1" 607 | >>| function 608 | | [ [ result ] ] -> 609 | Alcotest.(check (option string)) 610 | "" 611 | (Some expect) 612 | (Pgx.Value.to_string result) 613 | | _ -> assert false)) 614 | ] 615 | in 616 | if force_tests || have_pg_config 617 | then Alcotest_io.run "pgx_test" [ library_name, tests ] 618 | else print_endline "Skipping PostgreSQL tests since PGUSER is unset." 619 | ;; 620 | end 621 | -------------------------------------------------------------------------------- /pgx_test/src/pgx_test.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | val run_tests : library_name:string -> unit 3 | end 4 | 5 | module type ALCOTEST_IO = sig 6 | open Alcotest 7 | 8 | type 'a monad 9 | type 'a test_case 10 | 11 | val test_case : string -> speed_level -> ('a -> unit monad) -> 'a test_case 12 | val run : string -> (string * unit test_case list) list -> unit 13 | end 14 | 15 | module Make_tests 16 | (Pgx_impl : Pgx.S) 17 | (Alcotest_io : ALCOTEST_IO with type 'a monad := 'a Pgx_impl.Io.t) : S 18 | -------------------------------------------------------------------------------- /pgx_unix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "PGX using the standard library's Unix module for IO (synchronous)" 4 | description: 5 | "PGX using the standard library's Unix module for IO (synchronous)" 6 | maintainer: ["Arena Developers "] 7 | authors: ["Arena Developers "] 8 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 9 | homepage: "https://github.com/arenadotio/pgx" 10 | doc: "https://arenadotio.github.io/pgx" 11 | bug-reports: "https://github.com/arenadotio/pgx/issues" 12 | depends: [ 13 | "dune" {>= "3.2"} 14 | "alcotest" {with-test & >= "1.0.0"} 15 | "base64" {with-test & >= "3.0.0"} 16 | "ocaml" {>= "4.08"} 17 | "pgx" {= version} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 35 | -------------------------------------------------------------------------------- /pgx_unix/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "(preprocess (pps bisect_ppx))" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx_unix) 13 | (libraries pgx) 14 | |} ^ preprocess ^ {|) 15 | |} 16 | -------------------------------------------------------------------------------- /pgx_unix/src/pgx_unix.ml: -------------------------------------------------------------------------------- 1 | (* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. 2 | * 3 | * PG'OCaml - type safe interface to PostgreSQL. 4 | * Copyright (C) 2005-2009 Richard Jones and other authors. 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Library General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Library General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this library; see the file COPYING. If not, write to 18 | * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 | * Boston, MA 02111-1307, USA. 20 | *) 21 | 22 | external reraise : exn -> _ = "%reraise" 23 | 24 | module Simple_thread = struct 25 | type 'a t = 'a 26 | 27 | let return x = x 28 | let ( >>= ) v f = f v 29 | 30 | let catch f fexn = 31 | try f () with 32 | | e -> fexn e 33 | ;; 34 | 35 | type sockaddr = 36 | | Unix of string 37 | | Inet of string * int 38 | 39 | type nonrec in_channel = in_channel 40 | type nonrec out_channel = out_channel 41 | 42 | let open_connection sockaddr = 43 | let std_socket = 44 | match sockaddr with 45 | | Unix path -> Unix.ADDR_UNIX path 46 | | Inet (hostname, port) -> 47 | let hostent = Unix.gethostbyname hostname in 48 | (* Choose a random address from the list. *) 49 | let addrs = hostent.Unix.h_addr_list in 50 | let len = Array.length addrs in 51 | let i = Random.int len in 52 | let addr = addrs.(i) in 53 | Unix.ADDR_INET (addr, port) 54 | in 55 | Unix.open_connection std_socket 56 | ;; 57 | 58 | type ssl_config 59 | 60 | let upgrade_ssl = `Not_supported 61 | let output_char = output_char 62 | let output_binary_int = output_binary_int 63 | let output_string = output_string 64 | let flush = flush 65 | let input_char = input_char 66 | let input_binary_int = input_binary_int 67 | let really_input = really_input 68 | let close_in = close_in 69 | 70 | (* The unix getlogin syscall can fail *) 71 | let getlogin () = Unix.getuid () |> Unix.getpwuid |> fun { Unix.pw_name; _ } -> pw_name 72 | let debug = prerr_endline 73 | 74 | let protect f ~(finally : unit -> unit) = 75 | let result = ref None in 76 | try 77 | result := Some (f ()); 78 | raise Exit 79 | with 80 | | Exit as e -> 81 | finally (); 82 | (match !result with 83 | | Some x -> x 84 | | None -> reraise e) 85 | | e -> 86 | finally (); 87 | reraise e 88 | ;; 89 | 90 | module Sequencer = struct 91 | type 'a monad = 'a t 92 | type 'a t = 'a 93 | 94 | let create t = t 95 | let enqueue t f = f t 96 | end 97 | end 98 | 99 | module M = Pgx.Make (Simple_thread) 100 | include M 101 | -------------------------------------------------------------------------------- /pgx_unix/src/pgx_unix.mli: -------------------------------------------------------------------------------- 1 | (* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. 2 | * 3 | * PG'OCaml - type safe interface to PostgreSQL. 4 | * Copyright (C) 2005-2009 Richard Jones and other authors. 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Library General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Library General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this library; see the file COPYING. If not, write to 18 | * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 | * Boston, MA 02111-1307, USA. 20 | *) 21 | 22 | include Pgx.S with type 'a Io.t = 'a 23 | 24 | (* for testing purposes *) 25 | module Simple_thread : Pgx.Io with type 'a t = 'a 26 | -------------------------------------------------------------------------------- /pgx_unix/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_pgx_unix) 3 | (package pgx_unix) 4 | (libraries pgx_test pgx_unix)) 5 | -------------------------------------------------------------------------------- /pgx_unix/test/test_pgx_unix.ml: -------------------------------------------------------------------------------- 1 | module Alcotest_io = struct 2 | type 'a test_case = 'a Alcotest.test_case 3 | 4 | let test_case name speed f = Alcotest.test_case name speed f 5 | let run name tests = Alcotest.run name tests 6 | end 7 | 8 | include Pgx_test.Make_tests (Pgx_unix) (Alcotest_io) 9 | 10 | let () = run_tests ~library_name:"pgx_unix" 11 | -------------------------------------------------------------------------------- /pgx_value_core.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Pgx_value converters for Core types like Date and Time" 4 | description: "Pgx_value converters for Core types like Date and Time" 5 | maintainer: ["Arena Developers "] 6 | authors: ["Arena Developers "] 7 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 8 | homepage: "https://github.com/arenadotio/pgx" 9 | doc: "https://arenadotio.github.io/pgx" 10 | bug-reports: "https://github.com/arenadotio/pgx/issues" 11 | depends: [ 12 | "dune" {>= "3.2"} 13 | "alcotest" {with-test & >= "1.0.0"} 14 | "core_kernel" {>= "v0.13.0"} 15 | "ocaml" {>= "4.08"} 16 | "pgx" {= version} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 34 | -------------------------------------------------------------------------------- /pgx_value_core/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "(preprocess (pps bisect_ppx))" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx_value_core) 13 | (libraries core_kernel pgx) 14 | |} ^ preprocess ^ {|) 15 | |} 16 | -------------------------------------------------------------------------------- /pgx_value_core/src/pgx_value_core.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | include Pgx.Value 3 | 4 | let of_time t = 5 | (* 6 | Postgres behaves differently depending on whether the timestamp data type 7 | includes the timezone or not: 8 | 9 | Without timezone all inserted timezones are ignored 10 | 2016-06-07 15:37:46 (no timezone) 11 | 2016-06-07 15:37:46Z (utc timezone) 12 | 2016-06-07 15:37:46-04 (local timezone) 13 | Get inserted as 14 | 2016-06-07 15:37:46 15 | 16 | With timezones: 17 | 2016-06-07 15:37:46 (no timezone) -> 2016-06-07 15:37:46-04 18 | 2016-06-07 15:37:46Z (utc timezone) -> 2016-06-07 11:37:46-04 19 | 2016-06-07 15:37:46-04 (local timezone) -> 2016-06-07 15:37:46-04 20 | *) 21 | Time.to_string_abs ~zone:Time.Zone.utc t |> Pgx.Value.of_string 22 | ;; 23 | 24 | let to_time' = 25 | (* 26 | The time string can come in various forms depending on whether the 27 | Postgres timestamp used includes the time zone: 28 | 29 | Without timezone 30 | 2016-06-07 15:37:46 31 | 2016-06-07 15:37:46.962425 32 | 33 | With timezone 34 | 2016-06-07 15:37:46-04 35 | 2016-06-07 15:37:46.962425-04 36 | 37 | For the first one we need to indicate that it's a UTC time by appending 38 | a 'Z'. For the second one we need to append the minutes to the timezone. 39 | Without these formattings Time.of_string fails spectacularly 40 | *) 41 | let open Re in 42 | let tz = seq [ alt [ char '-'; char '+' ]; digit; digit ] in 43 | let utctz = seq [ char 'Z'; eol ] |> compile in 44 | let localtz_no_min = seq [ tz; eol ] |> compile in 45 | let localtz = seq [ tz; char ':'; digit; digit; eol ] |> compile in 46 | fun s -> 47 | Time.of_string 48 | @@ 49 | match matches utctz s, matches localtz s, matches localtz_no_min s with 50 | | [], [], [] -> s ^ "Z" 51 | | _, [], [] -> s 52 | | [], _, [] -> s 53 | | [], [], _ -> s ^ ":00" 54 | (* It either finishes in one of the patterns above or it doesn't *) 55 | | _ -> convert_failure "time" s 56 | ;; 57 | 58 | let to_time_exn v = Pgx.Value.to_string_exn v |> to_time' 59 | let to_time v = Pgx.Value.to_string v |> Option.map ~f:to_time' 60 | let of_date d = Date.to_string d |> Pgx.Value.of_string 61 | let to_date' = Date.of_string 62 | let to_date_exn v = Pgx.Value.to_string_exn v |> to_date' 63 | let to_date v = Pgx.Value.to_string v |> Option.map ~f:to_date' 64 | -------------------------------------------------------------------------------- /pgx_value_core/src/pgx_value_core.mli: -------------------------------------------------------------------------------- 1 | (** Pgx_value types using Core_kernel's Date and Time modules *) 2 | open Core_kernel 3 | 4 | type v = Pgx.Value.v [@@deriving compare, sexp_of] 5 | type t = Pgx.Value.t [@@deriving compare, sexp_of] 6 | 7 | include module type of Pgx.Value with type v := v and type t := t 8 | 9 | val of_date : Date.t -> t 10 | val to_date_exn : t -> Date.t 11 | val to_date : t -> Date.t option 12 | val of_time : Time.t -> t 13 | val to_time_exn : t -> Time.t 14 | val to_time : t -> Time.t option 15 | -------------------------------------------------------------------------------- /pgx_value_core/test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test_pgx_value_core) 3 | (package pgx_value_core) 4 | (libraries alcotest pgx_value_core)) 5 | -------------------------------------------------------------------------------- /pgx_value_core/test/test_pgx_value_core.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | module Value = Pgx_value_core 3 | 4 | let time_roundtrip str = Value.of_string str |> Value.to_time_exn 5 | let printer = Time.to_string_abs ~zone:Time.Zone.utc 6 | 7 | let time_testable = 8 | Alcotest.testable (fun ppf t -> Format.pp_print_string ppf (printer t)) Time.equal 9 | ;; 10 | 11 | let check_time = Alcotest.check time_testable 12 | let check_string = Alcotest.(check string) 13 | 14 | let test_time_of_string _ = 15 | let expected = Time.of_string "2016-03-15 19:55:18.123456-04:00" in 16 | check_time "without TZ" expected (time_roundtrip "2016-03-15 23:55:18.123456"); 17 | check_time "zulu" expected (time_roundtrip "2016-03-15 23:55:18.123456Z"); 18 | check_time "hour TZ" expected (time_roundtrip "2016-03-15 19:55:18.123456-04"); 19 | check_time "full TZ" expected (time_roundtrip "2016-03-15 19:55:18.123456-04:00") 20 | ;; 21 | 22 | let test_time_of_string_no_ms _ = 23 | let expected = Time.of_string "2016-03-15 19:55:18-04:00" in 24 | check_time "without TZ" expected (time_roundtrip "2016-03-15 23:55:18"); 25 | check_time "zulu" expected (time_roundtrip "2016-03-15 23:55:18Z"); 26 | check_time "hour TZ" expected (time_roundtrip "2016-03-15 19:55:18-04"); 27 | check_time "full TZ" expected (time_roundtrip "2016-03-15 19:55:18-04:00") 28 | ;; 29 | 30 | let test_time_conversion_roundtrip _ = 31 | let expected_str = "2016-03-15 23:55:18.123456Z" in 32 | check_string "parse-print" expected_str (time_roundtrip expected_str |> printer); 33 | let expected_time = Time.of_string expected_str in 34 | check_time "print-parse" expected_time (Value.of_time expected_time |> Value.to_time_exn) 35 | ;; 36 | 37 | let time_tests = 38 | [ Alcotest.test_case "test time_of_string" `Quick test_time_of_string 39 | ; Alcotest.test_case 40 | "test time_of_string no milliseconds" 41 | `Quick 42 | test_time_of_string_no_ms 43 | ; Alcotest.test_case 44 | "test time conversion roundtrip" 45 | `Quick 46 | test_time_conversion_roundtrip 47 | ] 48 | ;; 49 | 50 | let () = Alcotest.run "pgx_async_conversions" [ "time", time_tests ] 51 | -------------------------------------------------------------------------------- /pgx_value_ptime.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Pgx_value converters for Ptime types" 4 | description: "Pgx_value converters for Ptime types" 5 | maintainer: ["Arena Developers "] 6 | authors: ["Arena Developers "] 7 | license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" 8 | homepage: "https://github.com/arenadotio/pgx" 9 | doc: "https://arenadotio.github.io/pgx" 10 | bug-reports: "https://github.com/arenadotio/pgx/issues" 11 | depends: [ 12 | "dune" {>= "3.2"} 13 | "alcotest" {with-test & >= "1.0.0"} 14 | "ptime" {>= "0.8.3"} 15 | "ocaml" {>= "4.08"} 16 | "pgx" {= version} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/arenadotio/pgx.git" 34 | -------------------------------------------------------------------------------- /pgx_value_ptime/src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | let preprocess = 4 | match Sys.getenv "BISECT_ENABLE" with 5 | | "yes" -> "(preprocess (pps bisect_ppx))" 6 | | _ -> "" 7 | | exception Not_found -> "" 8 | 9 | let () = Jbuild_plugin.V1.send @@ {| 10 | 11 | (library 12 | (public_name pgx_value_ptime) 13 | (libraries ptime pgx) 14 | |} ^ preprocess ^ {|) 15 | |} 16 | -------------------------------------------------------------------------------- /pgx_value_ptime/src/pgx_value_ptime.ml: -------------------------------------------------------------------------------- 1 | include Pgx.Value 2 | 3 | let of_date (year, month, day) = 4 | Printf.sprintf "%04d-%02d-%02d" year month day |> Pgx.Value.of_string 5 | ;; 6 | 7 | let to_date' text = 8 | match text ^ "T00:00:00Z" |> Ptime.of_rfc3339 with 9 | | Result.Ok (t, _, _) -> Ptime.to_date t 10 | | _ -> convert_failure "date" text 11 | ;; 12 | 13 | let to_date_exn v = Pgx.Value.to_string_exn v |> to_date' 14 | let to_date v = Pgx.Value.to_string v |> Option.map to_date' 15 | 16 | let of_time ?tz_offset_s t = 17 | let tz_offset_s = Option.value tz_offset_s ~default:0 in 18 | Ptime.to_rfc3339 ~tz_offset_s ~frac_s:12 t |> Pgx.Value.of_string 19 | ;; 20 | 21 | let time_of_string text = 22 | match Ptime.of_rfc3339 text with 23 | | Result.Ok (t, offset, _) -> t, Option.value ~default:0 offset 24 | | _ -> convert_failure "time" text 25 | ;; 26 | 27 | let to_time' text = 28 | (* 29 | The time string can come in various forms depending on whether the 30 | Postgres timestamp used includes the time zone: 31 | 32 | Without timezone 33 | 2016-06-07 15:37:46 34 | 2016-06-07 15:37:46.962425 35 | 36 | With timezone 37 | 2016-06-07 15:37:46-04 38 | 2016-06-07 15:37:46.962425-04 39 | 40 | For the first one we need to indicate that it's a UTC time by appending 41 | a 'Z'. For the second one we need to append the minutes to the timezone. 42 | *) 43 | let open Re in 44 | let tz = seq [ alt [ char '-'; char '+' ]; digit; digit ] in 45 | let utctz = seq [ char 'Z'; eol ] |> compile in 46 | let localtz = seq [ tz; char ':'; digit; digit; eol ] |> compile in 47 | let localtz_no_min = seq [ tz; eol ] |> compile in 48 | time_of_string 49 | @@ 50 | match matches utctz text, matches localtz text, matches localtz_no_min text with 51 | | [], [], [] -> text ^ "Z" 52 | | _, _, [] -> text 53 | | [], [], _ -> text ^ ":00" 54 | | _ -> convert_failure "time" text 55 | ;; 56 | 57 | let to_time_exn v = Pgx.Value.to_string_exn v |> to_time' 58 | let to_time v = Pgx.Value.to_string v |> Option.map to_time' 59 | -------------------------------------------------------------------------------- /pgx_value_ptime/src/pgx_value_ptime.mli: -------------------------------------------------------------------------------- 1 | (** Pgx_value types using Ptime's Date and Time modules 2 | 3 | To use Ptime in utop, first run: #require "ptime";; 4 | *) 5 | 6 | type v = Pgx.Value.v [@@deriving compare, sexp_of] 7 | type t = Pgx.Value.t [@@deriving compare, sexp_of] 8 | 9 | include module type of Pgx.Value with type v := v and type t := t 10 | 11 | val of_date : Ptime.date -> t 12 | val to_date_exn : t -> Ptime.date 13 | val to_date : t -> Ptime.date option 14 | val of_time : ?tz_offset_s:Ptime.tz_offset_s -> Ptime.t -> t 15 | val to_time_exn : t -> Ptime.t * Ptime.tz_offset_s 16 | val to_time : t -> (Ptime.t * Ptime.tz_offset_s) option 17 | val time_of_string : string -> Ptime.t * Ptime.tz_offset_s 18 | -------------------------------------------------------------------------------- /pgx_value_ptime/test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test_pgx_value_ptime) 3 | (package pgx_value_ptime) 4 | (libraries alcotest pgx_value_ptime)) 5 | -------------------------------------------------------------------------------- /pgx_value_ptime/test/test_pgx_value_ptime.ml: -------------------------------------------------------------------------------- 1 | module Value = Pgx_value_ptime 2 | 3 | (* Show both an human-readable version of the date and the underlying 4 | seconds/offset pair for the input datetime.*) 5 | let print_time (t, tz_offset_s) = 6 | let sec = Ptime.to_float_s t 7 | and txt = Ptime.to_rfc3339 t ~tz_offset_s ~frac_s:6 in 8 | Printf.sprintf "<%s | Seconds: %f, Offset: %d>" txt sec tz_offset_s 9 | ;; 10 | 11 | let value_testable = 12 | let print_time value = 13 | match Pgx.Value.to_string value with 14 | | Some text -> text 15 | | None -> "" 16 | in 17 | let formatter ppf value = Format.pp_print_string ppf (print_time value) in 18 | Alcotest.testable formatter ( = ) 19 | ;; 20 | 21 | let check_value = Alcotest.check value_testable 22 | 23 | let test_to_date _ = 24 | let check_date = Alcotest.(check (triple int int int)) in 25 | let value = Pgx.Value.of_string "2021-11-14" in 26 | let expected = 2021, 11, 14 in 27 | check_date "check date parsing" expected (Value.to_date_exn value); 28 | let value = Pgx.Value.of_string "0900-06-13" in 29 | let expected = 900, 6, 13 in 30 | check_date "check date with leading zeros" expected (Value.to_date_exn value) 31 | ;; 32 | 33 | let test_of_date _ = 34 | let date = 2021, 11, 14 in 35 | let expected = Pgx.Value.of_string "2021-11-14" in 36 | check_value "check date rendering" expected (Value.of_date date); 37 | let date = 900, 6, 13 in 38 | let expected = Pgx.Value.of_string "0900-06-13" in 39 | check_value "dates with leading zeros render properly" expected (Value.of_date date) 40 | ;; 41 | 42 | let date_tests = 43 | [ Alcotest.test_case "of_date renders a Ptime date to a Pgx Value" `Quick test_of_date 44 | ; Alcotest.test_case "to_date parses a Pgx Value to a Ptime date" `Quick test_to_date 45 | ] 46 | ;; 47 | 48 | (* Show only the human-readable version of the date-time. *) 49 | let check_time = 50 | let compare_times (t1, o1) (t2, o2) = 51 | let tf1 = Ptime.to_float_s t1 52 | and tf2 = Ptime.to_float_s t2 in 53 | abs_float (tf1 -. tf2) < 1.0e-6 && o1 = o2 54 | in 55 | let time_testable = 56 | Alcotest.testable 57 | (fun ppf t -> Format.pp_print_string ppf (print_time t)) 58 | compare_times 59 | in 60 | Alcotest.check time_testable 61 | ;; 62 | 63 | let test_time_of_string _ = 64 | let hour = 3600 in 65 | let hourf = 3600. in 66 | let to_pt x = Ptime.of_float_s x |> Option.value ~default:Ptime.min in 67 | check_time 68 | "minimum time parses" 69 | (Ptime.min, 0) 70 | (Value.time_of_string "0000-01-01T00:00:00Z"); 71 | let pt = to_pt (12. *. hourf) in 72 | check_time 73 | "time with tz offset parses" 74 | (pt, ~-4 * hour) 75 | (Value.time_of_string "1970-01-01T08:00:00-04:00"); 76 | let pt = to_pt ((12. *. hourf) +. 0.12345) in 77 | check_time 78 | "a time with milliseconds parses" 79 | (pt, 0) 80 | (Value.time_of_string "1970-01-01T12:00:00.12345Z"); 81 | (* On linux, one can run "TZ='UTC' date -d @1458086118" in a shell to confirm this conversion is correct.*) 82 | check_time 83 | "a recent time parses" 84 | (to_pt 1458086118., ~-4 * hour) 85 | (Value.time_of_string "2016-03-15 19:55:18-04:00") 86 | ;; 87 | 88 | let time_roundtrip str = Value.of_string str |> Value.to_time_exn 89 | 90 | let test_time_tz_handling _ = 91 | let utc_t, tz_offset_s = Value.time_of_string "2016-03-15 19:55:18-04:00" in 92 | check_time "without TZ" (utc_t, 0) (time_roundtrip "2016-03-15 23:55:18"); 93 | check_time "zulu" (utc_t, 0) (time_roundtrip "2016-03-15 23:55:18Z"); 94 | check_time "hour TZ" (utc_t, tz_offset_s) (time_roundtrip "2016-03-15 19:55:18-04"); 95 | check_time "full TZ" (utc_t, tz_offset_s) (time_roundtrip "2016-03-15 19:55:18-04:00") 96 | ;; 97 | 98 | let test_time_conversion_roundtrip _ = 99 | let print_time (t, tz_offset_s) = Ptime.to_rfc3339 t ~tz_offset_s ~frac_s:6 in 100 | let expected_str = "2016-03-15T23:55:18.123456Z" in 101 | Alcotest.(check string) 102 | "parse-print" 103 | expected_str 104 | (time_roundtrip expected_str |> print_time); 105 | let t, tz_offset_s = Value.time_of_string expected_str in 106 | let actual = Value.of_time t ~tz_offset_s |> Value.to_time_exn in 107 | check_time "print-parse" (t, tz_offset_s) actual 108 | ;; 109 | 110 | let time_tests = 111 | [ Alcotest.test_case "test time_of_string" `Quick test_time_of_string 112 | ; Alcotest.test_case 113 | "test time_of_string time zone handling" 114 | `Quick 115 | test_time_tz_handling 116 | ; Alcotest.test_case 117 | "test time conversion roundtrip" 118 | `Quick 119 | test_time_conversion_roundtrip 120 | ] 121 | ;; 122 | 123 | let () = Alcotest.run "pgx_async_conversions" [ "date", date_tests; "time", time_tests ] 124 | -------------------------------------------------------------------------------- /pin_dev.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | for p in *.opam; do 3 | opam pin add -y -n ${p%.opam}.~dev . 4 | done 5 | -------------------------------------------------------------------------------- /unikernel/.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /unikernel/README.md: -------------------------------------------------------------------------------- 1 | # Using pgx on mirage 2 | 3 | ### Network setup 4 | 5 | Assuming one is using linux. The following steps are needed to setup networking for the mirage unikernel. 6 | 7 | ``` 8 | ip tuntap add tap100 mode tap 9 | ip addr add 10.0.0.1/24 dev tap100 10 | ip link set dev tap100 up 11 | 12 | echo 1 > /proc/sys/net/ipv4/ip_forward # enables IP forwarding 13 | 14 | # assuming "eth0" is your default network interface where all the traffic goes to the Internet. 15 | iptables -t nat -A POSTROUTING -o eth0 -j MASQUERADE 16 | iptables -A FORWARD -i eth0 -o tap100 -m state --state RELATED,ESTABLISHED -j ACCEPT 17 | iptables -A FORWARD -i tap100 -o eth0 -j ACCEPT 18 | ``` 19 | 20 | ### Building and running the unikernel 21 | 22 | ``` 23 | opam install mirage 24 | mirage configure -t hvt # replace hvt with spt/unix/xen etc 25 | make depends 26 | make 27 | solo5-hvt --net:service=tap100 -- pgx_unikernel.hvt --pgpassword --pguser --pghost --pgport --pgdatabase # The --pgdatabase flag is optional, but make sure to create the database before trying to run the example 28 | ``` 29 | -------------------------------------------------------------------------------- /unikernel/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let packages = 4 | [ package "pgx" ~pin:"file://../" 5 | ; package "pgx_lwt" ~pin:"file://../" 6 | ; package "pgx_lwt_mirage" ~pin:"file://../" 7 | ; package "logs" 8 | ; package "mirage-logs" 9 | ] 10 | ;; 11 | 12 | let stack = generic_stackv4v6 default_network 13 | 14 | let database = 15 | let doc = Key.Arg.info ~doc:"database to use" [ "db"; "pgdatabase" ] in 16 | Key.(create "pgdatabase" Arg.(opt string "postgres" doc)) 17 | ;; 18 | 19 | let port = 20 | let doc = Key.Arg.info ~doc:"port to use for postgresql" [ "p"; "pgport" ] in 21 | Key.(create "pgport" Arg.(opt int 5432 doc)) 22 | ;; 23 | 24 | let hostname = 25 | let doc = Key.Arg.info ~doc:"host for postgres database" [ "h"; "pghost" ] in 26 | Key.(create "pghost" Arg.(opt string "127.0.0.1" doc)) 27 | ;; 28 | 29 | let user = 30 | let doc = Key.Arg.info ~doc:"postgres user" [ "u"; "pguser" ] in 31 | Key.(create "pguser" Arg.(required string doc)) 32 | ;; 33 | 34 | let password = 35 | let doc = Key.Arg.info ~doc:"postgres password" [ "pgpassword" ] in 36 | Key.(create "pgpassword" Arg.(required string doc)) 37 | ;; 38 | 39 | let server = 40 | foreign 41 | "Unikernel.Make" 42 | ~keys: 43 | [ Key.abstract port 44 | ; Key.abstract hostname 45 | ; Key.abstract user 46 | ; Key.abstract password 47 | ; Key.abstract database 48 | ] 49 | ~packages 50 | (random @-> time @-> pclock @-> mclock @-> stackv4v6 @-> job) 51 | ;; 52 | 53 | let () = 54 | register 55 | "pgx_unikernel" 56 | [ server 57 | $ default_random 58 | $ default_time 59 | $ default_posix_clock 60 | $ default_monotonic_clock 61 | $ stack 62 | ] 63 | ;; 64 | -------------------------------------------------------------------------------- /unikernel/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Make 4 | (RANDOM : Mirage_random.S) 5 | (TIME : Mirage_time.S) 6 | (PCLOCK : Mirage_clock.PCLOCK) 7 | (MCLOCK : Mirage_clock.MCLOCK) 8 | (STACK : Tcpip.Stack.V4V6) = 9 | struct 10 | module Pgx_mirage = Pgx_lwt_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK) 11 | module Logs_reporter = Mirage_logs.Make (PCLOCK) 12 | 13 | type user = 14 | { id : int 15 | ; email : string 16 | } 17 | 18 | let emails = [ "foo@test.com"; "bar@foo.com"; "hello@test.net" ] 19 | 20 | let setup_database ~port ~user ~host ~password ~database pgx () = 21 | Logs.info (fun m -> m "setting up database"); 22 | let module P = (val pgx : Pgx_lwt.S) in 23 | P.with_conn ~user ~host ~password ~port ~database (fun conn -> 24 | P.execute_unit 25 | conn 26 | "CREATE TABLE IF NOT EXISTS users( id SERIAL PRIMARY KEY, email VARCHAR(40) \ 27 | NOT NULL UNIQUE );" 28 | >>= fun () -> 29 | let params = List.map (fun email -> Pgx.Value.[ of_string email ]) emails in 30 | P.execute_many 31 | conn 32 | ~params 33 | ~query:"INSERT INTO USERS (email) VALUES ($1) ON CONFLICT (email) DO NOTHING" 34 | >>= fun rows -> 35 | Logs.info (fun m -> m "Inserted %d rows" (List.length rows)); 36 | Lwt.return_unit) 37 | ;; 38 | 39 | let get_users ~port ~user ~host ~password ~database pgx () = 40 | Logs.info (fun m -> m "Fetching users"); 41 | let module P = (val pgx : Pgx_lwt.S) in 42 | P.with_conn ~user ~host ~password ~port ~database (fun conn -> 43 | P.execute conn "SELECT * FROM USERS" 44 | >|= fun rows -> 45 | List.map 46 | (fun row -> 47 | match row with 48 | | [ id; email ] -> 49 | { id = Pgx.Value.to_int_exn id; email = Pgx.Value.to_string_exn email } 50 | | _ -> failwith "invalid data") 51 | rows) 52 | ;; 53 | 54 | let print_users users = 55 | users 56 | >|= fun users -> 57 | List.iter 58 | (fun { id; email } -> Logs.info (fun m -> m "{id = %d; email = %s}\n" id email)) 59 | users 60 | ;; 61 | 62 | let start _random _time _pclock _mclock stack = 63 | Logs.(set_level (Some Info)); 64 | Logs_reporter.(create () |> run) 65 | @@ fun () -> 66 | let port = Key_gen.pgport () in 67 | let host = Key_gen.pghost () in 68 | let user = Key_gen.pguser () in 69 | let password = Key_gen.pgpassword () in 70 | let database = Key_gen.pgdatabase () in 71 | let pgx = Pgx_mirage.connect stack in 72 | setup_database ~port ~host ~user ~password ~database pgx () 73 | >>= fun () -> print_users (get_users ~port ~host ~user ~password ~database pgx ()) 74 | ;; 75 | end 76 | --------------------------------------------------------------------------------