├── .gitignore ├── .ocamlformat ├── .travis.yml ├── CHANGES.md ├── CODEOWNERS ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── examples ├── hello_world_with_async │ ├── dune │ ├── hello_world_with_async.ml │ ├── mysql_with_async.ml │ └── mysql_with_async.mli ├── hello_world_with_identity │ ├── dune │ └── hello_world_with_identity.ml └── hello_world_with_lwt │ ├── dune │ ├── hello_world_with_lwt.ml │ ├── mysql_with_lwt.ml │ └── mysql_with_lwt.mli ├── lib ├── mysql_with_identity │ ├── dune │ ├── mysql_with_identity.ml │ └── mysql_with_identity.mli └── runtime │ ├── dune │ ├── ppx_mysql_runtime.ml │ └── ppx_mysql_runtime.mli ├── ppx ├── dune ├── ppx_mysql.ml ├── query.mli └── query.mll ├── ppx_mysql.opam ├── ppx_mysql_identity.opam └── tests ├── test_ppx ├── dune ├── pp.ml ├── test_ppx.expected.ml └── test_ppx.ml └── test_query ├── dune └── test_query.ml /.gitignore: -------------------------------------------------------------------------------- 1 | /_build 2 | /_opam 3 | *.install 4 | .merlin 5 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | break-cases=toplevel 2 | break-infix=fit-or-vertical 3 | break-string-literals=wrap 4 | doc-comments=before 5 | extension-sugar=preserve 6 | field-space=loose 7 | if-then-else=keyword-first 8 | indicate-nested-or-patterns=unsafe-no 9 | infix-precedence=parens 10 | leading-nested-match-parens=false 11 | let-and=sparse 12 | let-open=preserve 13 | margin=90 14 | ocp-indent-compat=true 15 | parens-tuple=multi-line-only 16 | parens-tuple-patterns=multi-line-only 17 | sequence-style=terminator 18 | type-decl=sparse 19 | wrap-fun-args=false 20 | module-item-spacing=sparse 21 | break-separators=after-and-docked 22 | break-infix-before-func=false 23 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | global: 7 | - TESTS=true 8 | matrix: 9 | - OCAML_VERSION=4.06 PACKAGE="ppx_mysql" PINS="ppx_mysql:." 10 | - OCAML_VERSION=4.06 PACKAGE="ppx_mysql_identity" PINS="ppx_mysql:. ppx_mysql_identity:." 11 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 1.1.3 2 | ===== 3 | 4 | * Remove the upper limit on ppxlib 5 | 6 | 1.1.2 7 | ===== 8 | 9 | * Fix the generated code to also emit `Stdlib` instead of `Pervasives`. This 10 | means you need `stdlib-shims` if you're building on OCaml <4.07. 11 | 12 | 1.1.1 13 | ===== 14 | 15 | * Fix dune dependency 16 | * Use `Stdlib` instead of `Pervasives` for forward-compatibility 17 | 18 | 1.1 19 | === 20 | 21 | * Caching can be disabled on a per statement basis. 22 | (Caching is enabled by default) 23 | 24 | 1.0 25 | === 26 | 27 | * All statements are now cached 28 | * First public release 29 | 30 | 0.5 31 | === 32 | 33 | * Refactor code generation to eliminate internal use of exceptions 34 | * Support custom types wrapped under modules 35 | 36 | 0.4 37 | === 38 | 39 | * Support for lists of input parameters 40 | * Add examples for Lwt and Async 41 | 42 | 0.3 43 | === 44 | 45 | * More useful error messages 46 | 47 | 0.2 48 | === 49 | 50 | * Minor refactoring of the API 51 | * Creation of ppx\_mysql\_identity subpackage 52 | 53 | 0.1 54 | === 55 | 56 | * Initial release 57 | -------------------------------------------------------------------------------- /CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @issuu/platypus 2 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Apache License 2 | ============== 3 | 4 | _Version 2.0, January 2004_ 5 | _<>_ 6 | 7 | ### Terms and Conditions for use, reproduction, and distribution 8 | 9 | #### 1. Definitions 10 | 11 | “License” shall mean the terms and conditions for use, reproduction, and 12 | distribution as defined by Sections 1 through 9 of this document. 13 | 14 | “Licensor” shall mean the copyright owner or entity authorized by the copyright 15 | owner that is granting the License. 16 | 17 | “Legal Entity” shall mean the union of the acting entity and all other entities 18 | that control, are controlled by, or are under common control with that entity. 19 | For the purposes of this definition, “control” means **(i)** the power, direct or 20 | indirect, to cause the direction or management of such entity, whether by 21 | contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the 22 | outstanding shares, or **(iii)** beneficial ownership of such entity. 23 | 24 | “You” (or “Your”) shall mean an individual or Legal Entity exercising 25 | permissions granted by this License. 26 | 27 | “Source” form shall mean the preferred form for making modifications, including 28 | but not limited to software source code, documentation source, and configuration 29 | files. 30 | 31 | “Object” form shall mean any form resulting from mechanical transformation or 32 | translation of a Source form, including but not limited to compiled object code, 33 | generated documentation, and conversions to other media types. 34 | 35 | “Work” shall mean the work of authorship, whether in Source or Object form, made 36 | available under the License, as indicated by a copyright notice that is included 37 | in or attached to the work (an example is provided in the Appendix below). 38 | 39 | “Derivative Works” shall mean any work, whether in Source or Object form, that 40 | is based on (or derived from) the Work and for which the editorial revisions, 41 | annotations, elaborations, or other modifications represent, as a whole, an 42 | original work of authorship. For the purposes of this License, Derivative Works 43 | shall not include works that remain separable from, or merely link (or bind by 44 | name) to the interfaces of, the Work and Derivative Works thereof. 45 | 46 | “Contribution” shall mean any work of authorship, including the original version 47 | of the Work and any modifications or additions to that Work or Derivative Works 48 | thereof, that is intentionally submitted to Licensor for inclusion in the Work 49 | by the copyright owner or by an individual or Legal Entity authorized to submit 50 | on behalf of the copyright owner. For the purposes of this definition, 51 | “submitted” means any form of electronic, verbal, or written communication sent 52 | to the Licensor or its representatives, including but not limited to 53 | communication on electronic mailing lists, source code control systems, and 54 | issue tracking systems that are managed by, or on behalf of, the Licensor for 55 | the purpose of discussing and improving the Work, but excluding communication 56 | that is conspicuously marked or otherwise designated in writing by the copyright 57 | owner as “Not a Contribution.” 58 | 59 | “Contributor” shall mean Licensor and any individual or Legal Entity on behalf 60 | of whom a Contribution has been received by Licensor and subsequently 61 | incorporated within the Work. 62 | 63 | #### 2. Grant of Copyright License 64 | 65 | Subject to the terms and conditions of this License, each Contributor hereby 66 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 67 | irrevocable copyright license to reproduce, prepare Derivative Works of, 68 | publicly display, publicly perform, sublicense, and distribute the Work and such 69 | Derivative Works in Source or Object form. 70 | 71 | #### 3. Grant of Patent License 72 | 73 | Subject to the terms and conditions of this License, each Contributor hereby 74 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 75 | irrevocable (except as stated in this section) patent license to make, have 76 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where 77 | such license applies only to those patent claims licensable by such Contributor 78 | that are necessarily infringed by their Contribution(s) alone or by combination 79 | of their Contribution(s) with the Work to which such Contribution(s) was 80 | submitted. If You institute patent litigation against any entity (including a 81 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a 82 | Contribution incorporated within the Work constitutes direct or contributory 83 | patent infringement, then any patent licenses granted to You under this License 84 | for that Work shall terminate as of the date such litigation is filed. 85 | 86 | #### 4. Redistribution 87 | 88 | You may reproduce and distribute copies of the Work or Derivative Works thereof 89 | in any medium, with or without modifications, and in Source or Object form, 90 | provided that You meet the following conditions: 91 | 92 | * **(a)** You must give any other recipients of the Work or Derivative Works a copy of 93 | this License; and 94 | * **(b)** You must cause any modified files to carry prominent notices stating that You 95 | changed the files; and 96 | * **(c)** You must retain, in the Source form of any Derivative Works that You distribute, 97 | all copyright, patent, trademark, and attribution notices from the Source form 98 | of the Work, excluding those notices that do not pertain to any part of the 99 | Derivative Works; and 100 | * **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any 101 | Derivative Works that You distribute must include a readable copy of the 102 | attribution notices contained within such NOTICE file, excluding those notices 103 | that do not pertain to any part of the Derivative Works, in at least one of the 104 | following places: within a NOTICE text file distributed as part of the 105 | Derivative Works; within the Source form or documentation, if provided along 106 | with the Derivative Works; or, within a display generated by the Derivative 107 | Works, if and wherever such third-party notices normally appear. The contents of 108 | the NOTICE file are for informational purposes only and do not modify the 109 | License. You may add Your own attribution notices within Derivative Works that 110 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 111 | provided that such additional attribution notices cannot be construed as 112 | modifying the License. 113 | 114 | You may add Your own copyright statement to Your modifications and may provide 115 | additional or different license terms and conditions for use, reproduction, or 116 | distribution of Your modifications, or for any such Derivative Works as a whole, 117 | provided Your use, reproduction, and distribution of the Work otherwise complies 118 | with the conditions stated in this License. 119 | 120 | #### 5. Submission of Contributions 121 | 122 | Unless You explicitly state otherwise, any Contribution intentionally submitted 123 | for inclusion in the Work by You to the Licensor shall be under the terms and 124 | conditions of this License, without any additional terms or conditions. 125 | Notwithstanding the above, nothing herein shall supersede or modify the terms of 126 | any separate license agreement you may have executed with Licensor regarding 127 | such Contributions. 128 | 129 | #### 6. Trademarks 130 | 131 | This License does not grant permission to use the trade names, trademarks, 132 | service marks, or product names of the Licensor, except as required for 133 | reasonable and customary use in describing the origin of the Work and 134 | reproducing the content of the NOTICE file. 135 | 136 | #### 7. Disclaimer of Warranty 137 | 138 | Unless required by applicable law or agreed to in writing, Licensor provides the 139 | Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, 140 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, 141 | including, without limitation, any warranties or conditions of TITLE, 142 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are 143 | solely responsible for determining the appropriateness of using or 144 | redistributing the Work and assume any risks associated with Your exercise of 145 | permissions under this License. 146 | 147 | #### 8. Limitation of Liability 148 | 149 | In no event and under no legal theory, whether in tort (including negligence), 150 | contract, or otherwise, unless required by applicable law (such as deliberate 151 | and grossly negligent acts) or agreed to in writing, shall any Contributor be 152 | liable to You for damages, including any direct, indirect, special, incidental, 153 | or consequential damages of any character arising as a result of this License or 154 | out of the use or inability to use the Work (including but not limited to 155 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or 156 | any and all other commercial damages or losses), even if such Contributor has 157 | been advised of the possibility of such damages. 158 | 159 | #### 9. Accepting Warranty or Additional Liability 160 | 161 | While redistributing the Work or Derivative Works thereof, You may choose to 162 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or 163 | other liability obligations and/or rights consistent with this License. However, 164 | in accepting such obligations, You may act only on Your own behalf and on Your 165 | sole responsibility, not on behalf of any other Contributor, and only if You 166 | agree to indemnify, defend, and hold each Contributor harmless for any liability 167 | incurred by, or claims asserted against, such Contributor by reason of your 168 | accepting any such warranty or additional liability. 169 | 170 | _END OF TERMS AND CONDITIONS_ 171 | 172 | ### APPENDIX: How to apply the Apache License to your work 173 | 174 | To apply the Apache License to your work, attach the following boilerplate 175 | notice, with the fields enclosed by brackets `[]` replaced with your own 176 | identifying information. (Don't include the brackets!) The text should be 177 | enclosed in the appropriate comment syntax for the file format. We also 178 | recommend that a file or class name and description of purpose be included on 179 | the same “printed page” as the copyright notice for easier identification within 180 | third-party archives. 181 | 182 | Copyright [yyyy] [name of copyright owner] 183 | 184 | Licensed under the Apache License, Version 2.0 (the "License"); 185 | you may not use this file except in compliance with the License. 186 | You may obtain a copy of the License at 187 | 188 | http://www.apache.org/licenses/LICENSE-2.0 189 | 190 | Unless required by applicable law or agreed to in writing, software 191 | distributed under the License is distributed on an "AS IS" BASIS, 192 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 193 | See the License for the specific language governing permissions and 194 | limitations under the License. 195 | 196 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default 2 | default: build 3 | 4 | .PHONY: build 5 | build: ## Build the source 6 | dune build @install @examples 7 | 8 | .PHONY: test 9 | test: ## Run tests 10 | dune runtest --force 11 | 12 | .PHONY: promote-ppx-output 13 | promote-ppx-output: MAKEFILE_DIR=$(dir $(realpath $(firstword $(MAKEFILE_LIST)))) 14 | promote-ppx-output: ## Promotes the current output of the ppx unit tests to be the new expected output. 15 | dune runtest --force || true # Without the 'true' Make will abort. 16 | cp $(MAKEFILE_DIR)_build/default/tests/test_ppx/test_ppx.result.reformatted.ml \ 17 | $(MAKEFILE_DIR)tests/test_ppx/test_ppx.expected.ml 18 | 19 | .PHONY: format 20 | format: ## Run OCamlformat on the source 21 | dune build @fmt --auto-promote 22 | 23 | .PHONY: clean 24 | clean: ## Clean the source tree 25 | dune clean 26 | 27 | .PHONY: tag 28 | tag: ## Tag the current release 29 | dune-release tag 30 | 31 | .PHONY: distrib 32 | distrib: ## Create a distribution tarball 33 | dune-release distrib 34 | 35 | .PHONY: publish 36 | publish: ## Put the release on GitHub 37 | dune-release publish distrib 38 | 39 | .PHONY: help 40 | help: ## Show this help 41 | @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Ppx_mysql 2 | ========= 3 | 4 | [![Build Status](https://travis-ci.org/issuu/ppx_mysql.svg?branch=master)](https://travis-ci.org/issuu/ppx_mysql) 5 | 6 | This syntax extension aims to reduce the pain and boilerplate associated with using 7 | MySQL bindings from OCaml. It is similar in spirit to [PG'OCaml](https://github.com/darioteixeira/pgocaml), 8 | but without the compile-time communication with the DB engine for type inference. 9 | 10 | 11 | Preliminaries 12 | ------------- 13 | 14 | Throughout this document we reference a SQL table named `employees`, whose MySQL 15 | definition is as follows: 16 | 17 | ```sql 18 | CREATE TABLE employees 19 | ( 20 | id INT NOT NULL, 21 | supervisor_id INT NULL, 22 | name TEXT NOT NULL, 23 | phone TEXT NULL, 24 | PRIMARY KEY (id), 25 | CONSTRAINT 'fk_supervisor_id' FOREIGN KEY (supervisor_id) REFERENCES employees(id) 26 | ); 27 | ``` 28 | 29 | We also define an OCaml record named `employee` that matches the structure 30 | of the SQL table `employees`: 31 | 32 | ```ocaml 33 | type employee = 34 | { 35 | id: int32; 36 | supervisor_id: int32 option; 37 | name: string; 38 | phone: string option; 39 | } 40 | ``` 41 | 42 | Assume also the existence of functions for converting to and from a tupled representation 43 | of the `employee` record: 44 | 45 | ```ocaml 46 | type employee_tuple = int32 * int32 option * string * string option 47 | 48 | employee_of_tuple: employee_tuple -> employee 49 | tuple_of_employee: employee -> employee_tuple 50 | ``` 51 | 52 | 53 | Setting up the environment 54 | -------------------------- 55 | 56 | To minimise the amount of boilerplate, this syntax extension generates functions which expect 57 | the existence of the following signature in the current context: 58 | 59 | ```ocaml 60 | sig 61 | module IO : sig 62 | type 'a t 63 | 64 | val return : 'a -> 'a t 65 | val bind : 'a t -> ('a -> 'b t) -> 'b t 66 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 67 | end 68 | 69 | module IO_result : sig 70 | type ('a, 'e) t = ('a, 'e) result IO.t 71 | 72 | val return : 'a -> ('a, 'e) t 73 | val bind : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 74 | val ( >>= ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 75 | end 76 | 77 | module Prepared : sig 78 | type dbh 79 | type stmt 80 | type stmt_result 81 | type error 82 | type wrapped_dbh 83 | type wrapped_error = [`Mysql_error of error] 84 | 85 | val init : dbh -> wrapped_dbh 86 | 87 | val execute_null : 88 | stmt -> 89 | string option array -> 90 | (stmt_result, [> wrapped_error]) result IO.t 91 | 92 | val fetch : 93 | stmt_result -> 94 | (string option array option, [> wrapped_error]) result IO.t 95 | 96 | val with_stmt_cached : 97 | wrapped_dbh -> 98 | string -> 99 | (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> 100 | ('a, 'e) result IO.t 101 | 102 | val with_stmt_uncached : 103 | wrapped_dbh -> 104 | string -> 105 | (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> 106 | ('a, 'e) result IO.t 107 | end 108 | end 109 | ``` 110 | 111 | Note that you should **not** manually write the code that satisfies this 112 | signature. Instead, you should use the `Make_context` functor defined in the 113 | `Ppx_mysql_runtime` module, which will produce a module satisfying the above 114 | signature using as argument a module with a much simpler signature. (Please 115 | see the API documentation for details.) 116 | 117 | Note also that in many cases you don't even have to worry about calling the 118 | functor yourself. For your convenience, besides the main `ppx_mysql` package, 119 | you can also find in OPAM the package `ppx_mysql_identity`, which defines module 120 | `Mysql_with_identity` for using Mysql (via the `mysql` package) with the identity 121 | monad for IO, and which takes care of all the nitty-gritty of defining a base 122 | module and passing it to the `Make_context` functor. 123 | 124 | As an example, to compile the samples in this document using Mysql and the identity 125 | monad for IO, just add package `ppx_mysql_identity` to your project dependencies and 126 | `open Mysql_with_identity` either globally or locally. 127 | 128 | 129 | Basic usage: selecting a single row 130 | ----------------------------------- 131 | 132 | Writing a function to fetch one row from the DB is as simple as this: 133 | 134 | ```ocaml 135 | let get_employee dbh employee_id = 136 | [%mysql select_one 137 | "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} 138 | FROM employees 139 | WHERE id = %int32{employee_id}"] dbh ~employee_id >>| employee_of_tuple 140 | ``` 141 | 142 | The `%mysql` extension makes all the "magic" happen: it creates a function 143 | that takes as parameter a database handle plus all the input parameters 144 | present in the SQL statement, and returns a tuple with all the output 145 | parameters present in the SQL statement, properly wrapped in a `result` 146 | and `IO` monad. 147 | 148 | The "magic" is easier to understand if we explicitly declare the type 149 | of the function created by this extension. We will do so for the rest 150 | of this document. Note, however, that this explicit declaration is 151 | neither necessary nor recommended for actual code. Here's the same 152 | `get_employee` function with type annotations: 153 | 154 | ```ocaml 155 | let get_employee dbh employee_id = 156 | let q : 157 | Prepared.wrapped_dbh -> 158 | employee_id:int32 -> 159 | ((int32 * int32 option * string * string option), error) result IO.t = 160 | [%mysql select_one 161 | "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} 162 | FROM employees 163 | WHERE id = %int32{employee_id}"] 164 | in 165 | q dbh ~employee_id >>| employee_of_tuple 166 | ``` 167 | 168 | Things to note: 169 | 170 | - Type `Prepared.wrapped_dbh` is a wrapper around a raw database handle. 171 | You can obtain a value of this type by invoking function `Prepared.init` 172 | with a raw database handle as argument. 173 | 174 | - We denote input parameters using the syntax `%TYPE{name}`, where `TYPE` 175 | is a type specification (see next section), and `name` is the OCaml named 176 | parameter that will be part of the generated function's signature. 177 | 178 | - We denote output parameters using the syntax `@TYPE{name}`, where `TYPE` 179 | is a type specification (see next section), and `name` is the MySQL 180 | column we are selecting. 181 | 182 | - Both input and output parameters may be `NULL`, which is handled 183 | by suffixing the type specification with the character `?` 184 | (Cf. the `supervisor_id` and `phone` columns in this example). 185 | 186 | - The `select_one` built-in function immediately after `%mysql` tells 187 | the extension that the function should return a single value. 188 | In this case, the value is of type `int32 * int32 option * string * string option`, 189 | which is wrapped inside a `result IO.t` because errors may occur. 190 | There are other built-in special functions that may be used instead 191 | of `select_one`, and these are described in a section below. 192 | 193 | 194 | Type specifications 195 | ------------------- 196 | 197 | Serialization of input parameters and deserialization of output parameters 198 | is done according to provided type specifications. A type specification 199 | can either begin with a lowercase or an uppercase letter. In the former case, 200 | its name must either be the same as the base OCaml type you wish to (de)serialize 201 | to and from (presently, the supported types are `int`, `int32`, `int64`, 202 | `bool`, and `string`), or the special type specification `list` (please see 203 | the section on *List of values as input parameter* below for more details). 204 | In the latter case, the syntax extension assumes you are referencing a type 205 | with custom (de)serialization functions (please see the next section for 206 | a detailed explanation of this feature). 207 | 208 | Note that you will get a runtime error if there is a mismatch between 209 | the types in your database and the types you specify in your query. 210 | 211 | 212 | Custom types and (de)serialization functions 213 | -------------------------------------------- 214 | 215 | The syntax extension has limited support for custom types with user-defined 216 | (de)serialization functions. Consider the example below, noting in the particular 217 | the use of `Suit` as a type specification both for an input and an output parameter: 218 | 219 | ```ocaml 220 | module Suit : Ppx_mysql_runtime.SERIALIZABLE = struct 221 | type t = Clubs | Diamonds | Hearts | Spades 222 | 223 | let of_mysql = function 224 | | "c" -> Ok Clubs 225 | | "d" -> Ok Diamonds 226 | | "h" -> Ok Hearts 227 | | "s" -> Ok Spades 228 | | _ -> Error "invalid suit" 229 | 230 | let to_mysql = function 231 | | Clubs -> "c" 232 | | Diamonds -> "d" 233 | | Hearts -> "h" 234 | | Spades -> "s" 235 | end 236 | 237 | let get_cards = [%mysql select_all "SELECT @int{id}, @Suit{suit} FROM cards WHERE suit <> %Suit{suit}"] 238 | ``` 239 | 240 | As you may have guessed, upon encountering a type specification whose first 241 | letter is uppercase -- `Suit` in this case -- the syntax extension assumes it 242 | refers to a module name that implements the `Ppx_mysql_runtime.SERIALIZABLE` 243 | signature listed below: 244 | 245 | ```ocaml 246 | module type SERIALIZABLE = sig 247 | type t 248 | 249 | val of_mysql : string -> (t, string) result 250 | 251 | val to_mysql : t -> string 252 | end 253 | ``` 254 | 255 | Besides defining a type `t`, the module must also implement the deserialization 256 | function `of_mysql` and the serialization function `to_mysql`. The MySQL wire 257 | protocol uses strings for serialization, which explains the signatures of these 258 | functions. 259 | 260 | 261 | Other select queries 262 | -------------------- 263 | 264 | The query below is a variation on the one above, illustrating a case 265 | getting zero results is perfectly normal and should not be an error. 266 | Note the use of the `select_opt` built-in function, which makes the 267 | function return an `option` (wrapped inside a `result IO.t`, because 268 | other errors may still occur). 269 | 270 | ```ocaml 271 | let get_supervisor dbh employee_id = 272 | let q : 273 | Prepared.wrapped_dbh -> 274 | employee_id:int32 -> 275 | ((int32 * int32 option * string * string option) option, error) result IO.t = 276 | [%mysql select_opt 277 | "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} 278 | FROM employees 279 | WHERE supervisor_id = %int32{employee_id}"] 280 | in 281 | q dbh ~employee_id >>| maybe employee_of_tuple (* val maybe: ('a -> 'b) -> 'a option -> 'b option *) 282 | ``` 283 | 284 | For queries where multiple (or zero) rows are expected, use the `select_all` 285 | built-in function. The sample below illustrates its use. Note that the function 286 | now returns a `list` (again wrapped inside a `result IO.t`, because other errors 287 | may occur). 288 | 289 | ```ocaml 290 | let get_underlings dbh supervisor_id = 291 | let q : 292 | Prepared.wrapped_dbh -> 293 | supervisor_id:int32 -> 294 | ((int32 * int32 option * string * string option) list, error) result IO.t = 295 | [%mysql select_all 296 | "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} 297 | FROM employees 298 | WHERE supervisor_id = %int32{supervisor_id}"] 299 | in 300 | q dbh ~supervisor_id >>| List.map employee_of_tuple 301 | ``` 302 | 303 | Insertions, updates, deletions 304 | ------------------------------ 305 | 306 | We don't really expect a value returned from queries that modify the DB, 307 | such as those that use SQL's `INSERT`, `UPDATE`, and `DELETE` statements. 308 | We use the `execute` built-in function for these cases, as the example 309 | below illustrates. Note the use of multiple input parameters, which 310 | show up in the function signature as named parameters in the same order 311 | they appear within the SQL statement (though these being named parameters, 312 | one does not usually need to worry about the order). 313 | 314 | ```ocaml 315 | let insert_employee dbh {id; supervisor_id; name; phone} = 316 | let q : 317 | Prepared.wrapped_dbh -> 318 | id:int32 -> 319 | supervisor_id:int32 option -> 320 | name:string -> 321 | phone:string option -> 322 | (unit, error) result IO.t = 323 | [%mysql execute 324 | "INSERT INTO employees (id, supervisor_id, name, phone) 325 | VALUES (%int32{id}, %int32?{supervisor_id}, %string{name}, %string?{phone})"] 326 | in 327 | q dbh ~id ~supervisor_id ~name ~phone 328 | ``` 329 | 330 | 331 | List of values as input parameter 332 | --------------------------------- 333 | 334 | The syntax extension has limited support for queries involving lists of values, 335 | by way of a special `list` input parameter type whose contents get expanded into 336 | a comma-separated list. 337 | 338 | As an example, suppose you want to insert multiple rows with a single call. 339 | The function below does just that; note the use of `%list{...}` around what 340 | would have been a single value. Moreover, note that the function takes an 341 | additional positional parameter whose type is a list of tuples. The type of 342 | the tuple corresponds to the input parameters present inside the `%list{...}` 343 | declaration. 344 | 345 | ```ocaml 346 | let insert_employees dbh rows = 347 | let q : 348 | Prepared.wrapped_dbh -> 349 | (int32 * int32 option * string * string option) list -> 350 | (unit, error) result IO.t = 351 | [%mysql execute 352 | "INSERT INTO employees (id, supervisor_id, name, phone) 353 | VALUES %list{(%int32{id}, %int32?{supervisor_id}, %string{name}, %string?{phone})}"] 354 | in 355 | q dbh rows 356 | ``` 357 | 358 | It is of course also possible to use the `list` input parameter with `SELECT` 359 | statements, and to construct a statement that mixes regular input parameters 360 | with input parameters nested inside `list`. The following function illustrates 361 | this use case: 362 | 363 | ```ocaml 364 | let select_employees dbh ids = 365 | let q : 366 | Prepared.wrapped_dbh -> 367 | int32 list -> 368 | name:string -> 369 | ((int32 * int32 option * string * string option) list, error) result IO.t = 370 | [%mysql select_all 371 | "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} 372 | FROM employees 373 | WHERE name = %string{name} OR supervisor_id IN (%list{%int32{supervisor_id}})"] 374 | in 375 | q dbh ids >>| List.map employee_of_tuple 376 | ``` 377 | 378 | Note that in contrast with the previous example, the parentheses are placed **outside** 379 | the `%list{...}` declaration. To understand why, bear in mind that the syntax extension 380 | does not know SQL and therefore makes no attempt to parse it or generate it. When it 381 | encounters a `%list{...}` declaration, it expands the declaration by repeatedly concatenating 382 | its contents (after replacing any input parameters within) using a comma as the separator. 383 | In the previous example we wanted the parentheses to be part of the repeated expansion, 384 | whereas in this last example we do not. 385 | 386 | An important caveat concerns empty lists. Their expansion would result in an empty 387 | string which would then be spliced into the SQL statement. In most circumstances 388 | the resulting statement would be invalid SQL (cf. the two examples shown in 389 | this section). For this reason, the code generated by the syntax extension 390 | checks for the list length and immediately returns an error if provided with 391 | an empty list, without even bothering with preparing the statement and waiting 392 | for the MySQL server to complain about the invalid syntax. Please let us know 393 | if you come across a situation where the expanded empty list would result in 394 | valid SQL and you would prefer if the syntax extension would not check for the 395 | list length. 396 | 397 | Another important caveat concerns caching. Each list length results in a separate 398 | entry in the statement cache. If you use lists with a wide range of lengths, you 399 | may end up consuming lots of resources on both the client and the server. To avoid 400 | this problem, you should consider disabling caching for statements that use lists. 401 | Please consult the section on statement caching below. 402 | 403 | Finally, note that at the moment the `%list{...}` declaration may be used only 404 | once per statement. We do intend to lift this limitation in the future. 405 | 406 | 407 | Statement caching 408 | ----------------- 409 | 410 | By default, `ppx_mysql` uses a per connection statement cache. Though this 411 | consumes some resources on both the client and the MySQL server, the performance 412 | benefits justify caching as the correct default. It is however possible to 413 | disable caching on a per statement basis by setting to `false` the optional 414 | parameter `cached` on a query's action. This is particularly useful if the 415 | statement uses the `%list` parameter specification, since each list length 416 | would've created a new entry in the statement cache. Example: 417 | 418 | ```ocaml 419 | let insert_employees = 420 | [%mysql execute ~cached:false 421 | "INSERT INTO employees (id, supervisor_id, name, phone) 422 | VALUES %list{(%int32{id}, %int32?{supervisor_id}, %string{name}, %string?{phone})}"] 423 | ``` 424 | 425 | 426 | Special cases 427 | ------------- 428 | 429 | Should there be no input parameters, the function generated by the syntax 430 | extension will take only the wrapped database handle as parameter: 431 | 432 | ```ocaml 433 | let get_unsupervised dbh = 434 | let q : 435 | Prepared.wrapped_dbh -> 436 | ((int32 * int32 option * string * string option) list, error) result IO.t = 437 | [%mysql select_all 438 | "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} 439 | FROM employees 440 | WHERE supervisor_id IS NULL"] 441 | in 442 | q dbh >>| List.map employee_of_tuple 443 | ``` 444 | 445 | Should an input parameter with the same name appear multiple times in the 446 | SQL statement, the generated function will take it only once: 447 | 448 | ```ocaml 449 | let is_related dbh id = 450 | let q : 451 | Prepared.wrapped_dbh -> 452 | id:int32 -> 453 | ((int32 * int32 option * string * string option) list, error) result IO.t = 454 | [%mysql select_all 455 | "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} 456 | FROM employees 457 | WHERE (id = %int32{id} OR supervisor_id = %int32{id}"] 458 | in 459 | q dbh ~id >>| List.map employee_of_tuple 460 | ``` 461 | 462 | 463 | Limitations 464 | ----------- 465 | 466 | All output columns must be specified explicitly, and queries such as 467 | `SELECT * FROM employees` are not supported. However, since these 468 | queries are brittle and should not be used anyway, this limitation 469 | is unlikely to ever be a problem. Moreover, note that queries such 470 | as `SELECT @int{count(*)} FROM employees` are supported just fine. 471 | 472 | 473 | Summary of the built-in query functions 474 | --------------------------------------- 475 | 476 | Below is a summary of all available built-in query functions: 477 | 478 | - `select_one`: For queries that expect a single row to be returned, 479 | and where anything else (zero or multiple rows) is an error. 480 | 481 | - `select_opt`: For queries that may return a single row or none at all. 482 | Getting multiple rows from the DB is an error. 483 | 484 | - `select_all`: For queries that expect any number of rows from the DB, 485 | including zero. 486 | 487 | - `execute`: For queries that insert, update, or delete data from the DB, 488 | and where no return value is expected. 489 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.4) 2 | (using fmt 1.0) 3 | (name ppx_mysql) 4 | -------------------------------------------------------------------------------- /examples/hello_world_with_async/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name hello_world_with_async) 3 | (libraries async mysql ppx_mysql.runtime) 4 | (preprocess (pps ppx_mysql))) 5 | 6 | (alias 7 | (name examples) 8 | (deps hello_world_with_async.exe)) 9 | -------------------------------------------------------------------------------- /examples/hello_world_with_async/hello_world_with_async.ml: -------------------------------------------------------------------------------- 1 | (* This example assumes that a Mysql database 'test' exists for user 'root'. 2 | * Moreover, a table 'users' defined as follows is also present in the DB: 3 | * 4 | * CREATE TABLE users 5 | * ( 6 | * id INT NOT NULL, 7 | * name TEXT NOT NULL, 8 | * phone TEXT NULL, 9 | * PRIMARY KEY (id) 10 | * ); 11 | *) 12 | 13 | open Core 14 | open Async 15 | open Mysql_with_async 16 | 17 | let stdout = Lazy.force Writer.stdout 18 | 19 | (** Module implementing custom (de)serialization to/from MySQL. *) 20 | 21 | module Phone : Ppx_mysql_runtime.SERIALIZABLE with type t = string = struct 22 | type t = string 23 | 24 | let of_mysql str = if String.length str <= 9 then Ok str else Error "string too long" 25 | 26 | let to_mysql str = str 27 | end 28 | 29 | (** The user type used throughout this example. *) 30 | 31 | type user = { 32 | id : int32; 33 | name : string; 34 | phone : Phone.t option 35 | } 36 | 37 | let user_of_tuple (id, name, phone) = {id; name; phone} 38 | 39 | let print_user {id; name; phone} = 40 | Writer.writef 41 | stdout 42 | "\t%ld -> %s (phone: %s)\n" 43 | id 44 | name 45 | ( match phone with 46 | | Some p -> p 47 | | None -> "--" ) 48 | 49 | (** Database queries using the Ppx_mysql syntax extension. *) 50 | 51 | let get_all_users dbh = 52 | let open Deferred.Result in 53 | [%mysql select_all "SELECT @int32{id}, @string{name}, @string?{phone} FROM users"] dbh 54 | >>| List.map ~f:user_of_tuple 55 | 56 | let get_some_users dbh ids = 57 | let open Deferred.Result in 58 | [%mysql 59 | select_all 60 | "SELECT @int32{id}, @string{name}, @string?{phone} FROM users WHERE id IN \ 61 | (%list{%int32{id}})"] 62 | dbh 63 | ids 64 | >>| List.map ~f:user_of_tuple 65 | 66 | let get_user dbh ~id = 67 | let open Deferred.Result in 68 | [%mysql 69 | select_one 70 | "SELECT @int32{id}, @string{name}, @string?{phone} FROM users WHERE id = %int32{id}"] 71 | dbh 72 | ~id 73 | >>| user_of_tuple 74 | 75 | let insert_user = 76 | [%mysql 77 | execute 78 | "INSERT INTO users (id, name, phone) VALUES (%int32{id}, %string{name}, \ 79 | %string?{phone})"] 80 | 81 | let insert_users = 82 | [%mysql 83 | execute 84 | "INSERT INTO users (id, name, phone) VALUES %list{(%int32{id}, %string{name}, \ 85 | %string?{phone})}"] 86 | 87 | let update_user = 88 | [%mysql 89 | execute 90 | "UPDATE users SET name = %string{name}, phone = %string?{phone} WHERE id = \ 91 | %int32{id}"] 92 | 93 | let delete_user = [%mysql execute "DELETE FROM users WHERE id = %int32{id}"] 94 | 95 | (** Main functions and values. *) 96 | 97 | let test dbh = 98 | let open Deferred.Result in 99 | insert_user dbh ~id:1l ~name:"John" ~phone:(Some "123456") >>= fun () -> 100 | insert_user dbh ~id:2l ~name:"Jane" ~phone:None >>= fun () -> 101 | insert_user dbh ~id:3l ~name:"Claire" ~phone:None >>= fun () -> 102 | insert_users dbh [4l, "Mark", None; 5l, "Alice", Some "234567"] >>= fun () -> 103 | get_all_users dbh >>= fun users -> 104 | Writer.writef stdout "All users:\n"; 105 | List.iter ~f:print_user users; 106 | get_some_users dbh [1l; 2l; 3l] >>= fun users -> 107 | Writer.writef stdout "Users with ID in {1, 2, 3}:\n"; 108 | List.iter ~f:print_user users; 109 | update_user dbh ~id:2l ~name:"Mary" ~phone:(Some "654321") >>= fun () -> 110 | get_user dbh ~id:2l >>= fun user -> 111 | Writer.writef stdout "User with ID = 2 after update:\n"; 112 | print_user user; 113 | delete_user dbh ~id:3l >>= fun () -> 114 | get_all_users dbh >>= fun users -> 115 | Writer.writef stdout "All users after deleting one with ID = 3:\n"; 116 | List.iter ~f:print_user users; 117 | return () 118 | 119 | let main () = 120 | let open Deferred.Infix in 121 | let dbh = Mysql.quick_connect ~database:"test" ~user:"root" () in 122 | let wrapped_dbh = Prepared.init dbh in 123 | test wrapped_dbh >>= fun res -> 124 | Mysql.disconnect dbh; 125 | match res with 126 | | Ok () -> 127 | Writer.writef stdout "All went well!\n"; 128 | return () 129 | | Error _ -> 130 | Writer.writef stdout "An error occurred!\n"; 131 | return () 132 | 133 | let () = Command.(run @@ async ~summary:"Run Async example" @@ Param.return main) 134 | -------------------------------------------------------------------------------- /examples/hello_world_with_async/mysql_with_async.ml: -------------------------------------------------------------------------------- 1 | open Async 2 | open Core 3 | 4 | include Ppx_mysql_runtime.Make_context (struct 5 | module IO = struct 6 | type 'a t = 'a Deferred.t 7 | 8 | let return = Deferred.return 9 | 10 | let bind x f = Deferred.bind x ~f 11 | end 12 | 13 | module Prepared = struct 14 | type dbh = Mysql.dbd 15 | 16 | type stmt = Mysql.Prepared.stmt 17 | 18 | type stmt_result = Mysql.Prepared.stmt_result 19 | 20 | type error = exn 21 | 22 | let wrap f x = Deferred.return (try Ok (f x) with exc -> Error exc) 23 | 24 | let create dbh sql = wrap (Mysql.Prepared.create dbh) sql 25 | 26 | let close stmt = wrap Mysql.Prepared.close stmt 27 | 28 | let execute_null stmt args = wrap (Mysql.Prepared.execute_null stmt) args 29 | 30 | let fetch stmt_res = wrap Mysql.Prepared.fetch stmt_res 31 | end 32 | end) 33 | -------------------------------------------------------------------------------- /examples/hello_world_with_async/mysql_with_async.mli: -------------------------------------------------------------------------------- 1 | include 2 | Ppx_mysql_runtime.PPX_MYSQL_CONTEXT 3 | with type 'a IO.t = 'a Async.Deferred.t 4 | and type Prepared.dbh = Mysql.dbd 5 | and type Prepared.error = exn 6 | -------------------------------------------------------------------------------- /examples/hello_world_with_identity/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name hello_world_with_identity) 3 | (libraries mysql ppx_mysql.runtime ppx_mysql_identity) 4 | (preprocess (pps ppx_mysql))) 5 | 6 | (alias 7 | (name examples) 8 | (deps hello_world_with_identity.exe)) 9 | -------------------------------------------------------------------------------- /examples/hello_world_with_identity/hello_world_with_identity.ml: -------------------------------------------------------------------------------- 1 | (* This example assumes that a Mysql database 'test' exists for user 'root'. 2 | * Moreover, a table 'users' defined as follows is also present in the DB: 3 | * 4 | * CREATE TABLE users 5 | * ( 6 | * id INT NOT NULL, 7 | * name TEXT NOT NULL, 8 | * phone TEXT NULL, 9 | * PRIMARY KEY (id) 10 | * ); 11 | *) 12 | 13 | open Mysql_with_identity 14 | 15 | (** Module implementing custom (de)serialization to/from MySQL. *) 16 | 17 | module Phone : Ppx_mysql_runtime.SERIALIZABLE with type t = string = struct 18 | type t = string 19 | 20 | let of_mysql str = if String.length str <= 9 then Ok str else Error "string too long" 21 | 22 | let to_mysql str = str 23 | end 24 | 25 | (** The user type used throughout this example. *) 26 | 27 | type user = { 28 | id : int32; 29 | name : string; 30 | phone : Phone.t option 31 | } 32 | 33 | let user_of_tuple (id, name, phone) = {id; name; phone} 34 | 35 | let print_user {id; name; phone} = 36 | Printf.printf 37 | "\t%ld -> %s (phone: %s)\n" 38 | id 39 | name 40 | ( match phone with 41 | | Some p -> p 42 | | None -> "--" ) 43 | 44 | (** Database queries using the Ppx_mysql syntax extension. *) 45 | 46 | let ( >>| ) x f = 47 | let open IO_result in 48 | x >>= fun x' -> return @@ f x' 49 | 50 | let get_all_users dbh = 51 | [%mysql select_all "SELECT @int32{id}, @string{name}, @Phone?{phone} FROM users"] dbh 52 | >>| List.map user_of_tuple 53 | 54 | let get_some_users dbh ids = 55 | [%mysql 56 | select_all 57 | "SELECT @int32{id}, @string{name}, @Phone?{phone} FROM users WHERE id IN \ 58 | (%list{%int32{id}})"] 59 | dbh 60 | ids 61 | >>| List.map user_of_tuple 62 | 63 | let get_user dbh ~id = 64 | [%mysql 65 | select_one 66 | "SELECT @int32{id}, @string{name}, @Phone?{phone} FROM users WHERE id = %int32{id}"] 67 | dbh 68 | ~id 69 | >>| user_of_tuple 70 | 71 | let insert_user = 72 | [%mysql 73 | execute 74 | "INSERT INTO users (id, name, phone) VALUES (%int32{id}, %string{name}, \ 75 | %Phone?{phone})"] 76 | 77 | let insert_users = 78 | [%mysql 79 | execute 80 | "INSERT INTO users (id, name, phone) VALUES %list{(%int32{id}, %string{name}, \ 81 | %Phone?{phone})}"] 82 | 83 | let update_user = 84 | [%mysql 85 | execute 86 | "UPDATE users SET name = %string{name}, phone = %Phone?{phone} WHERE id = \ 87 | %int32{id}"] 88 | 89 | let delete_user = [%mysql execute "DELETE FROM users WHERE id = %int32{id}"] 90 | 91 | (** Main functions and values. *) 92 | 93 | let test dbh = 94 | let open IO_result in 95 | insert_user dbh ~id:1l ~name:"John" ~phone:(Some "123456") >>= fun () -> 96 | insert_user dbh ~id:2l ~name:"Jane" ~phone:None >>= fun () -> 97 | insert_user dbh ~id:3l ~name:"Claire" ~phone:None >>= fun () -> 98 | insert_users dbh [4l, "Mark", None; 5l, "Alice", Some "234567"] >>= fun () -> 99 | get_all_users dbh >>= fun users -> 100 | Printf.printf "All users:\n"; 101 | List.iter print_user users; 102 | get_some_users dbh [1l; 2l; 3l] >>= fun users -> 103 | Printf.printf "Users with ID in {1, 2, 3}:\n"; 104 | List.iter print_user users; 105 | update_user dbh ~id:2l ~name:"Mary" ~phone:(Some "654321") >>= fun () -> 106 | get_user dbh ~id:2l >>= fun user -> 107 | Printf.printf "User with ID = 2 after update:\n"; 108 | print_user user; 109 | delete_user dbh ~id:3l >>= fun () -> 110 | get_all_users dbh >>= fun users -> 111 | Printf.printf "All users after deleting one with ID = 3:\n"; 112 | List.iter print_user users; 113 | Ok () 114 | 115 | let main () = 116 | let dbh = Mysql.quick_connect ~database:"test" ~user:"root" () in 117 | let wrapped_dbh = Prepared.init dbh in 118 | let res = test wrapped_dbh in 119 | Mysql.disconnect dbh; 120 | match res with 121 | | Ok () -> Printf.printf "All went well!\n" 122 | | Error _ -> Printf.printf "An error occurred!\n" 123 | 124 | let () = main () 125 | -------------------------------------------------------------------------------- /examples/hello_world_with_lwt/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name hello_world_with_lwt) 3 | (libraries lwt lwt.unix mysql ppx_mysql.runtime) 4 | (preprocess (pps ppx_mysql))) 5 | 6 | (alias 7 | (name examples) 8 | (deps hello_world_with_lwt.exe)) 9 | -------------------------------------------------------------------------------- /examples/hello_world_with_lwt/hello_world_with_lwt.ml: -------------------------------------------------------------------------------- 1 | (* This example assumes that a Mysql database 'test' exists for user 'root'. 2 | * Moreover, a table 'users' defined as follows is also present in the DB: 3 | * 4 | * CREATE TABLE users 5 | * ( 6 | * id INT NOT NULL, 7 | * name TEXT NOT NULL, 8 | * phone TEXT NULL, 9 | * PRIMARY KEY (id) 10 | * ); 11 | *) 12 | 13 | open Mysql_with_lwt 14 | 15 | (** Module implementing custom (de)serialization to/from MySQL. *) 16 | 17 | module Phone : Ppx_mysql_runtime.SERIALIZABLE with type t = string = struct 18 | type t = string 19 | 20 | let of_mysql str = if String.length str <= 9 then Ok str else Error "string too long" 21 | 22 | let to_mysql str = str 23 | end 24 | 25 | (** The user type used throughout this example. *) 26 | 27 | type user = { 28 | id : int32; 29 | name : string; 30 | phone : Phone.t option 31 | } 32 | 33 | let user_of_tuple (id, name, phone) = {id; name; phone} 34 | 35 | let print_user {id; name; phone} = 36 | Lwt_io.printf 37 | "\t%ld -> %s (phone: %s)\n" 38 | id 39 | name 40 | ( match phone with 41 | | Some p -> p 42 | | None -> "--" ) 43 | 44 | (** Database queries using the Ppx_mysql syntax extension. *) 45 | 46 | let get_all_users dbh = 47 | let open Lwt_result.Infix in 48 | [%mysql select_all "SELECT @int32{id}, @string{name}, @string?{phone} FROM users"] dbh 49 | >|= List.map user_of_tuple 50 | 51 | let get_some_users dbh ids = 52 | let open Lwt_result.Infix in 53 | [%mysql 54 | select_all 55 | "SELECT @int32{id}, @string{name}, @string?{phone} FROM users WHERE id IN \ 56 | (%list{%int32{id}})"] 57 | dbh 58 | ids 59 | >|= List.map user_of_tuple 60 | 61 | let get_user dbh ~id = 62 | let open Lwt_result.Infix in 63 | [%mysql 64 | select_one 65 | "SELECT @int32{id}, @string{name}, @string?{phone} FROM users WHERE id = %int32{id}"] 66 | dbh 67 | ~id 68 | >|= user_of_tuple 69 | 70 | let insert_user = 71 | [%mysql 72 | execute 73 | "INSERT INTO users (id, name, phone) VALUES (%int32{id}, %string{name}, \ 74 | %string?{phone})"] 75 | 76 | let insert_users = 77 | [%mysql 78 | execute 79 | "INSERT INTO users (id, name, phone) VALUES %list{(%int32{id}, %string{name}, \ 80 | %string?{phone})}"] 81 | 82 | let update_user = 83 | [%mysql 84 | execute 85 | "UPDATE users SET name = %string{name}, phone = %string?{phone} WHERE id = \ 86 | %int32{id}"] 87 | 88 | let delete_user = [%mysql execute "DELETE FROM users WHERE id = %int32{id}"] 89 | 90 | (** Main functions and values. *) 91 | 92 | let test dbh = 93 | let open Lwt_result.Infix in 94 | insert_user dbh ~id:1l ~name:"John" ~phone:(Some "123456") >>= fun () -> 95 | insert_user dbh ~id:2l ~name:"Jane" ~phone:None >>= fun () -> 96 | insert_user dbh ~id:3l ~name:"Claire" ~phone:None >>= fun () -> 97 | insert_users dbh [4l, "Mark", None; 5l, "Alice", Some "234567"] >>= fun () -> 98 | get_all_users dbh >>= fun users -> 99 | Lwt_result.ok @@ Lwt_io.printf "All users:\n" >>= fun () -> 100 | Lwt_result.ok @@ Lwt_list.iter_s print_user users >>= fun () -> 101 | get_some_users dbh [1l; 2l; 3l] >>= fun users -> 102 | Lwt_result.ok @@ Lwt_io.printf "Users with ID in {1, 2, 3}:\n" >>= fun () -> 103 | Lwt_result.ok @@ Lwt_list.iter_s print_user users >>= fun () -> 104 | update_user dbh ~id:2l ~name:"Mary" ~phone:(Some "654321") >>= fun () -> 105 | get_user dbh ~id:2l >>= fun user -> 106 | Lwt_result.ok @@ Lwt_io.printf "User with ID = 2 after update:\n" >>= fun () -> 107 | Lwt_result.ok @@ print_user user >>= fun () -> 108 | delete_user dbh ~id:3l >>= fun () -> 109 | get_all_users dbh >>= fun users -> 110 | Lwt_result.ok @@ Lwt_io.printf "All users after deleting one with ID = 3:\n" 111 | >>= fun () -> 112 | Lwt_result.ok @@ Lwt_list.iter_s print_user users >>= fun () -> Lwt_result.return () 113 | 114 | let main () = 115 | let open Lwt.Infix in 116 | let dbh = Mysql.quick_connect ~database:"test" ~user:"root" () in 117 | let wrapped_dbh = Prepared.init dbh in 118 | test wrapped_dbh >>= fun res -> 119 | Mysql.disconnect dbh; 120 | match res with 121 | | Ok () -> Lwt_io.printf "All went well!\n" 122 | | Error _ -> Lwt_io.printf "An error occurred!\n" 123 | 124 | let () = Lwt_main.run @@ main () 125 | -------------------------------------------------------------------------------- /examples/hello_world_with_lwt/mysql_with_lwt.ml: -------------------------------------------------------------------------------- 1 | include Ppx_mysql_runtime.Make_context (struct 2 | module IO = Lwt 3 | 4 | module Prepared = struct 5 | type dbh = Mysql.dbd 6 | 7 | type stmt = Mysql.Prepared.stmt 8 | 9 | type stmt_result = Mysql.Prepared.stmt_result 10 | 11 | type error = exn 12 | 13 | let wrap f x = 14 | let open Lwt.Infix in 15 | Lwt.catch 16 | (fun () -> Lwt_preemptive.detach f x >>= fun v -> Lwt.return_ok v) 17 | (fun exn -> Lwt.return_error exn) 18 | 19 | let create dbd sql = wrap (Mysql.Prepared.create dbd) sql 20 | 21 | let close stmt = wrap Mysql.Prepared.close stmt 22 | 23 | let execute_null stmt args = wrap (Mysql.Prepared.execute_null stmt) args 24 | 25 | let fetch stmt_res = wrap Mysql.Prepared.fetch stmt_res 26 | end 27 | end) 28 | -------------------------------------------------------------------------------- /examples/hello_world_with_lwt/mysql_with_lwt.mli: -------------------------------------------------------------------------------- 1 | include 2 | Ppx_mysql_runtime.PPX_MYSQL_CONTEXT 3 | with type 'a IO.t = 'a Lwt.t 4 | and type Prepared.dbh = Mysql.dbd 5 | and type Prepared.error = exn 6 | -------------------------------------------------------------------------------- /lib/mysql_with_identity/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mysql_with_identity) 3 | (libraries mysql ppx_mysql.runtime) 4 | (public_name ppx_mysql_identity)) 5 | -------------------------------------------------------------------------------- /lib/mysql_with_identity/mysql_with_identity.ml: -------------------------------------------------------------------------------- 1 | include Ppx_mysql_runtime.Make_context (struct 2 | module IO = struct 3 | type 'a t = 'a 4 | 5 | let return x = x 6 | 7 | let bind x f = f x 8 | end 9 | 10 | module Prepared = struct 11 | type dbh = Mysql.dbd 12 | 13 | type stmt = Mysql.Prepared.stmt 14 | 15 | type stmt_result = Mysql.Prepared.stmt_result 16 | 17 | type error = exn 18 | 19 | let wrap f x = try Ok (f x) with exn -> Error exn 20 | 21 | let create dbh sql = wrap (Mysql.Prepared.create dbh) sql 22 | 23 | let close stmt = wrap Mysql.Prepared.close stmt 24 | 25 | let execute_null stmt args = wrap (Mysql.Prepared.execute_null stmt) args 26 | 27 | let fetch stmt_res = wrap Mysql.Prepared.fetch stmt_res 28 | end 29 | end) 30 | -------------------------------------------------------------------------------- /lib/mysql_with_identity/mysql_with_identity.mli: -------------------------------------------------------------------------------- 1 | include 2 | Ppx_mysql_runtime.PPX_MYSQL_CONTEXT 3 | with type 'a IO.t = 'a 4 | and type Prepared.dbh = Mysql.dbd 5 | and type Prepared.error = exn 6 | -------------------------------------------------------------------------------- /lib/runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_mysql_runtime) 3 | (public_name ppx_mysql.runtime) 4 | (libraries stdlib-shims)) 5 | -------------------------------------------------------------------------------- /lib/runtime/ppx_mysql_runtime.ml: -------------------------------------------------------------------------------- 1 | type deserialization_error = { 2 | idx : int; 3 | name : string; 4 | func : string; 5 | value : string; 6 | message : string 7 | } 8 | 9 | type column_error = 10 | [ `Expected_non_null_column of int * string 11 | | `Deserialization_error of deserialization_error ] 12 | 13 | type 'a deserializer = string -> ('a, string) result 14 | 15 | let wrap_failure : (string -> 'a) -> 'a deserializer = 16 | fun of_string s -> 17 | match of_string s with 18 | | v -> Ok v 19 | | exception Failure _ -> Error "cannot parse number" 20 | 21 | let string_of_string str = Ok str 22 | 23 | let int_of_string = wrap_failure Stdlib.int_of_string 24 | 25 | let int32_of_string = wrap_failure Int32.of_string 26 | 27 | let int64_of_string = wrap_failure Int64.of_string 28 | 29 | let bool_of_string str = 30 | match Stdlib.int_of_string str with 31 | | v -> Ok (v <> 0) 32 | | exception Failure _ -> Error "cannot parse boolean" 33 | 34 | external identity : 'a -> 'a = "%identity" 35 | 36 | let deserialize_non_nullable_column idx name of_string func err_accum = function 37 | | None -> 38 | let err = `Expected_non_null_column (idx, name) in 39 | None, err :: err_accum 40 | | Some value -> ( 41 | match of_string value with 42 | | Ok ok -> Some ok, err_accum 43 | | Error message -> 44 | let err = `Deserialization_error {idx; name; func; value; message} in 45 | None, err :: err_accum ) 46 | 47 | let deserialize_nullable_column idx name of_string func err_accum = function 48 | | None -> Some None, err_accum 49 | | Some value -> ( 50 | match of_string value with 51 | | Ok ok -> Some (Some ok), err_accum 52 | | Error message -> 53 | let err = `Deserialization_error {idx; name; func; value; message} in 54 | None, err :: err_accum ) 55 | 56 | module type SERIALIZABLE = sig 57 | type t 58 | 59 | val of_mysql : string -> (t, string) result 60 | 61 | val to_mysql : t -> string 62 | end 63 | 64 | module type PPX_MYSQL_CONTEXT_ARG = sig 65 | module IO : sig 66 | type 'a t 67 | 68 | val return : 'a -> 'a t 69 | 70 | val bind : 'a t -> ('a -> 'b t) -> 'b t 71 | end 72 | 73 | module Prepared : sig 74 | type dbh 75 | 76 | type stmt 77 | 78 | type stmt_result 79 | 80 | type error 81 | 82 | val create : dbh -> string -> (stmt, error) result IO.t 83 | 84 | val close : stmt -> (unit, error) result IO.t 85 | 86 | val execute_null : stmt -> string option array -> (stmt_result, error) result IO.t 87 | 88 | val fetch : stmt_result -> (string option array option, error) result IO.t 89 | end 90 | end 91 | 92 | module type PPX_MYSQL_CONTEXT = sig 93 | module IO : sig 94 | type 'a t 95 | 96 | val return : 'a -> 'a t 97 | 98 | val bind : 'a t -> ('a -> 'b t) -> 'b t 99 | 100 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 101 | end 102 | 103 | module IO_result : sig 104 | type ('a, 'e) t = ('a, 'e) result IO.t 105 | 106 | val return : 'a -> ('a, 'e) t 107 | 108 | val bind : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 109 | 110 | val ( >>= ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 111 | end 112 | 113 | module Prepared : sig 114 | type dbh 115 | 116 | type stmt 117 | 118 | type stmt_result 119 | 120 | type error 121 | 122 | type wrapped_dbh 123 | 124 | type wrapped_error = [`Mysql_error of error] 125 | 126 | val init : dbh -> wrapped_dbh 127 | 128 | val execute_null 129 | : stmt -> 130 | string option array -> 131 | (stmt_result, [> wrapped_error]) result IO.t 132 | 133 | val fetch 134 | : stmt_result -> 135 | (string option array option, [> wrapped_error]) result IO.t 136 | 137 | val with_stmt_cached 138 | : wrapped_dbh -> 139 | string -> 140 | (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> 141 | ('a, 'e) result IO.t 142 | 143 | val with_stmt_uncached 144 | : wrapped_dbh -> 145 | string -> 146 | (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> 147 | ('a, 'e) result IO.t 148 | end 149 | end 150 | 151 | module Make_context (M : PPX_MYSQL_CONTEXT_ARG) : 152 | PPX_MYSQL_CONTEXT 153 | with type 'a IO.t = 'a M.IO.t 154 | and type Prepared.dbh = M.Prepared.dbh 155 | and type Prepared.error = M.Prepared.error = struct 156 | module IO = struct 157 | include M.IO 158 | 159 | let ( >>= ) = bind 160 | end 161 | 162 | module IO_result = struct 163 | type ('a, 'e) t = ('a, 'e) result IO.t 164 | 165 | let return x = IO.return @@ Ok x 166 | 167 | let bind x f = 168 | IO.bind x (function 169 | | Ok v -> f v 170 | | Error _ as e -> IO.return e ) 171 | 172 | let ( >>= ) = bind 173 | end 174 | 175 | module Prepared = struct 176 | type dbh = M.Prepared.dbh 177 | 178 | type stmt = M.Prepared.stmt 179 | 180 | type stmt_result = M.Prepared.stmt_result 181 | 182 | type error = M.Prepared.error 183 | 184 | type wrapped_dbh = { 185 | dbh : dbh; 186 | stmt_cache : (string, stmt) Hashtbl.t 187 | } 188 | 189 | type wrapped_error = [`Mysql_error of error] 190 | 191 | let wrap f x = 192 | IO.bind (f x) @@ function 193 | | Ok _ as ok -> IO.return ok 194 | | Error err -> IO.return @@ Error (`Mysql_error err) 195 | 196 | let init dbh = {dbh; stmt_cache = Hashtbl.create 16} 197 | 198 | let create dbh sql = wrap (M.Prepared.create dbh) sql 199 | 200 | let create_or_reuse {dbh; stmt_cache} sql = 201 | match Hashtbl.find_opt stmt_cache sql with 202 | | Some stmt -> IO_result.return stmt 203 | | None -> 204 | IO_result.bind (create dbh sql) @@ fun stmt -> 205 | Hashtbl.replace stmt_cache sql stmt; 206 | IO_result.return stmt 207 | 208 | let close stmt = wrap M.Prepared.close stmt 209 | 210 | let execute_null stmt args = wrap (M.Prepared.execute_null stmt) args 211 | 212 | let fetch stmt_res = wrap M.Prepared.fetch stmt_res 213 | 214 | let with_stmt_cached wrapped_dbh sql f = 215 | IO_result.bind (create_or_reuse wrapped_dbh sql) @@ fun stmt -> f stmt 216 | 217 | let with_stmt_uncached {dbh; stmt_cache = _} sql f = 218 | IO_result.bind (create dbh sql) @@ fun stmt -> 219 | IO.bind (f stmt) @@ fun res -> 220 | IO.bind (close stmt) @@ function 221 | | Ok () -> IO.return res 222 | | Error _ as e -> IO.return e 223 | end 224 | end 225 | 226 | module Stdlib = struct 227 | module Array = Array 228 | module List = List 229 | 230 | module Option = struct 231 | type 'a t = 'a option = 232 | | None 233 | | Some of 'a 234 | 235 | let map f = function 236 | | Some x -> Some (f x) 237 | | None -> None 238 | 239 | let get = function 240 | | Some x -> x 241 | | None -> invalid_arg "Option.get" 242 | end 243 | 244 | module Result = struct 245 | type ('a, 'e) t = ('a, 'e) result = 246 | | Ok of 'a 247 | | Error of 'e 248 | 249 | let bind r f = 250 | match r with 251 | | Ok x -> f x 252 | | Error _ as e -> e 253 | 254 | let ( >>= ) = bind 255 | end 256 | 257 | module String = struct 258 | include String 259 | 260 | let append = ( ^ ) 261 | end 262 | 263 | let ( = ) = ( = ) 264 | end 265 | -------------------------------------------------------------------------------- /lib/runtime/ppx_mysql_runtime.mli: -------------------------------------------------------------------------------- 1 | type deserialization_error = { 2 | idx : int; 3 | name : string; 4 | func : string; 5 | value : string; 6 | message : string 7 | } 8 | 9 | type column_error = 10 | [ `Expected_non_null_column of int * string 11 | | `Deserialization_error of deserialization_error ] 12 | 13 | type 'a deserializer = string -> ('a, string) result 14 | 15 | val string_of_string : string deserializer 16 | 17 | val int_of_string : int deserializer 18 | 19 | val int32_of_string : int32 deserializer 20 | 21 | val int64_of_string : int64 deserializer 22 | 23 | val bool_of_string : bool deserializer 24 | 25 | external identity : 'a -> 'a = "%identity" 26 | 27 | val deserialize_non_nullable_column 28 | : int -> 29 | string -> 30 | 'a deserializer -> 31 | string -> 32 | column_error list -> 33 | string option -> 34 | 'a option * column_error list 35 | 36 | val deserialize_nullable_column 37 | : int -> 38 | string -> 39 | 'a deserializer -> 40 | string -> 41 | column_error list -> 42 | string option -> 43 | 'a option option * column_error list 44 | 45 | module type SERIALIZABLE = sig 46 | type t 47 | 48 | val of_mysql : string -> (t, string) result 49 | 50 | val to_mysql : t -> string 51 | end 52 | 53 | module type PPX_MYSQL_CONTEXT_ARG = sig 54 | module IO : sig 55 | type 'a t 56 | 57 | val return : 'a -> 'a t 58 | 59 | val bind : 'a t -> ('a -> 'b t) -> 'b t 60 | end 61 | 62 | module Prepared : sig 63 | type dbh 64 | 65 | type stmt 66 | 67 | type stmt_result 68 | 69 | type error 70 | 71 | val create : dbh -> string -> (stmt, error) result IO.t 72 | 73 | val close : stmt -> (unit, error) result IO.t 74 | 75 | val execute_null : stmt -> string option array -> (stmt_result, error) result IO.t 76 | 77 | val fetch : stmt_result -> (string option array option, error) result IO.t 78 | end 79 | end 80 | 81 | module type PPX_MYSQL_CONTEXT = sig 82 | module IO : sig 83 | type 'a t 84 | 85 | val return : 'a -> 'a t 86 | 87 | val bind : 'a t -> ('a -> 'b t) -> 'b t 88 | 89 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 90 | end 91 | 92 | module IO_result : sig 93 | type ('a, 'e) t = ('a, 'e) result IO.t 94 | 95 | val return : 'a -> ('a, 'e) t 96 | 97 | val bind : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 98 | 99 | val ( >>= ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 100 | end 101 | 102 | module Prepared : sig 103 | type dbh 104 | 105 | type stmt 106 | 107 | type stmt_result 108 | 109 | type error 110 | 111 | type wrapped_dbh 112 | 113 | type wrapped_error = [`Mysql_error of error] 114 | 115 | val init : dbh -> wrapped_dbh 116 | 117 | val execute_null 118 | : stmt -> 119 | string option array -> 120 | (stmt_result, [> wrapped_error]) result IO.t 121 | 122 | val fetch 123 | : stmt_result -> 124 | (string option array option, [> wrapped_error]) result IO.t 125 | 126 | val with_stmt_cached 127 | : wrapped_dbh -> 128 | string -> 129 | (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> 130 | ('a, 'e) result IO.t 131 | 132 | val with_stmt_uncached 133 | : wrapped_dbh -> 134 | string -> 135 | (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> 136 | ('a, 'e) result IO.t 137 | end 138 | end 139 | 140 | module Make_context (M : PPX_MYSQL_CONTEXT_ARG) : 141 | PPX_MYSQL_CONTEXT 142 | with type 'a IO.t = 'a M.IO.t 143 | and type Prepared.dbh = M.Prepared.dbh 144 | and type Prepared.error = M.Prepared.error 145 | 146 | module Stdlib : sig 147 | module Array : sig 148 | include module type of struct 149 | include Array 150 | end 151 | end 152 | 153 | module List : sig 154 | include module type of struct 155 | include List 156 | end 157 | end 158 | 159 | module Option : sig 160 | type 'a t = 'a option = 161 | | None 162 | | Some of 'a 163 | 164 | val map : ('a -> 'b) -> 'a t -> 'b t 165 | 166 | val get : 'a t -> 'a 167 | end 168 | 169 | module Result : sig 170 | type ('a, 'e) t = ('a, 'e) result = 171 | | Ok of 'a 172 | | Error of 'e 173 | 174 | val bind : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 175 | 176 | val ( >>= ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t 177 | end 178 | 179 | module String : sig 180 | include module type of struct 181 | include String 182 | end 183 | 184 | val append : string -> string -> string 185 | end 186 | 187 | val ( = ) : 'a -> 'a -> bool 188 | end 189 | -------------------------------------------------------------------------------- /ppx/dune: -------------------------------------------------------------------------------- 1 | (ocamllex query) 2 | 3 | (library 4 | (name ppx_mysql) 5 | (public_name ppx_mysql) 6 | (kind ppx_rewriter) 7 | (libraries ppxlib ppx_mysql.runtime) 8 | (preprocess (pps ppxlib.metaquot))) 9 | -------------------------------------------------------------------------------- /ppx/ppx_mysql.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ppx_mysql_runtime.Stdlib 3 | 4 | (* So the unit tests have access to the Query module *) 5 | module Query = Query 6 | module Buildef = Ast_builder.Default 7 | 8 | (* [split_n] has the same signature and semantics as its homonym in Base. 9 | * [split_n xs n] is [(take xs n, drop xs n)]. 10 | *) 11 | let split_n elems index = 12 | let rec loop accum leftovers index = 13 | match leftovers, index with 14 | | _, x when x <= 0 -> List.rev accum, leftovers 15 | | [], _ -> List.rev accum, leftovers 16 | | hd :: tl, i -> loop (hd :: accum) tl (i - 1) 17 | in 18 | loop [] elems index 19 | 20 | let create_unique_var ~loc params base = 21 | let already_exists name = 22 | List.exists (fun param -> Query.(param.name) = name) params 23 | in 24 | let rec add_suffix counter = 25 | let candidate = Printf.sprintf "%s_%d" base counter in 26 | match already_exists candidate with 27 | | true -> add_suffix (counter + 1) 28 | | false -> candidate 29 | in 30 | let name = 31 | match already_exists base with 32 | | true -> add_suffix 0 33 | | false -> base 34 | in 35 | let pat = Buildef.ppat_var ~loc (Loc.make ~loc name) in 36 | let ident = Buildef.pexp_ident ~loc (Loc.make ~loc (Lident name)) in 37 | pat, ident 38 | 39 | let rec build_fun_chain ~loc expr = function 40 | | [] -> expr 41 | | Query.{typ; opt; name; _} :: tl -> 42 | let open Buildef in 43 | let tl' = build_fun_chain ~loc expr tl in 44 | let var = ppat_var ~loc (Loc.make ~loc name) in 45 | let basetyp = 46 | match typ with 47 | | None, typ -> ptyp_constr ~loc (Loc.make ~loc (Lident typ)) [] 48 | | Some module_name, typ -> 49 | ptyp_constr ~loc (Loc.make ~loc (Ldot (Lident module_name, typ))) [] 50 | in 51 | let fulltyp = 52 | match opt with 53 | | true -> ptyp_constr ~loc (Loc.make ~loc (Lident "option")) [basetyp] 54 | | false -> basetyp 55 | in 56 | let pat = ppat_constraint ~loc var fulltyp in 57 | pexp_fun ~loc (Labelled name) None pat tl' 58 | 59 | let build_in_param ~loc param = 60 | let to_string_mod, to_string_fun = Query.(param.to_string) in 61 | let to_string = 62 | Buildef.pexp_ident ~loc (Loc.make ~loc (Ldot (Lident to_string_mod, to_string_fun))) 63 | in 64 | let arg = Buildef.pexp_ident ~loc (Loc.make ~loc (Lident param.name)) in 65 | match param.opt with 66 | | true -> [%expr (Option.map [%e to_string]) [%e arg]] 67 | | false -> [%expr Option.Some ([%e to_string] [%e arg])] 68 | 69 | let make_column_expr ~loc i param = 70 | let of_string_mod, of_string_fun = Query.(param.of_string) in 71 | let of_string = 72 | Buildef.pexp_ident ~loc (Loc.make ~loc (Ldot (Lident of_string_mod, of_string_fun))) 73 | in 74 | let param_name = Buildef.estring ~loc Query.(param.name) in 75 | let of_string_desc = 76 | Buildef.estring ~loc @@ Printf.sprintf "%s.%s" of_string_mod of_string_fun 77 | in 78 | let idx = Buildef.eint ~loc i in 79 | let arg = [%expr row.([%e idx])] in 80 | let processor = 81 | match param.opt with 82 | | true -> [%expr Ppx_mysql_runtime.deserialize_nullable_column] 83 | | false -> [%expr Ppx_mysql_runtime.deserialize_non_nullable_column] 84 | in 85 | [%expr 86 | [%e processor] 87 | [%e idx] 88 | [%e param_name] 89 | [%e of_string] 90 | [%e of_string_desc] 91 | err_accum 92 | [%e arg]] 93 | 94 | let build_out_param_processor ~loc out_params = 95 | let len_out_params = List.length out_params in 96 | let ret_expr = 97 | match out_params with 98 | | [] -> [%expr Result.Ok ()] 99 | | [x] -> 100 | [%expr 101 | let err_accum = [] in 102 | match [%e make_column_expr ~loc 0 x] with 103 | | Option.Some res, _ -> Result.Ok res 104 | | Option.None, err -> Result.Error (`Column_errors err)] 105 | | _ -> 106 | let make_ident_str name i = String.append name @@ string_of_int i in 107 | let make_ident_expr name i = 108 | Buildef.pexp_ident ~loc (Loc.make ~loc (Lident (make_ident_str name i))) 109 | in 110 | let make_ident_pat name i = 111 | Buildef.ppat_var ~loc (Loc.make ~loc @@ make_ident_str name i) 112 | in 113 | let match_expr = 114 | let test_expr = 115 | Buildef.pexp_tuple ~loc @@ List.init len_out_params (make_ident_expr "col") 116 | in 117 | let ok_case = 118 | let lhs = 119 | Buildef.ppat_tuple ~loc 120 | @@ List.init len_out_params (fun i -> 121 | [%pat? Option.Some [%p make_ident_pat "v" i]] ) 122 | in 123 | let rhs = 124 | let tuple = 125 | Buildef.pexp_tuple ~loc @@ List.init len_out_params (make_ident_expr "v") 126 | in 127 | [%expr Result.Ok [%e tuple]] 128 | in 129 | Buildef.case ~lhs ~guard:None ~rhs 130 | in 131 | let error_case = 132 | let lhs = Buildef.ppat_any ~loc in 133 | let rhs = [%expr Result.Error (`Column_errors err_accum)] in 134 | Buildef.case ~lhs ~guard:None ~rhs 135 | in 136 | Buildef.pexp_match ~loc test_expr [ok_case; error_case] 137 | in 138 | let call_chain, _ = 139 | let err_accum_pat = Buildef.ppat_var ~loc (Loc.make ~loc "err_accum") in 140 | let make_call out_param (accum, i) = 141 | let pat = Buildef.ppat_tuple ~loc [make_ident_pat "col" i; err_accum_pat] in 142 | let expr = make_column_expr ~loc i out_param in 143 | let binding = Buildef.value_binding ~loc ~pat ~expr in 144 | Buildef.pexp_let ~loc Nonrecursive [binding] accum, i - 1 145 | in 146 | List.fold_right make_call out_params (match_expr, len_out_params - 1) 147 | in 148 | [%expr 149 | let err_accum = [] in 150 | [%e call_chain]] 151 | in 152 | let len_expected = Buildef.eint ~loc len_out_params in 153 | [%expr 154 | fun row -> 155 | let len_row = Array.length row in 156 | if Ppx_mysql_runtime.Stdlib.( = ) len_row [%e len_expected] 157 | then [%e ret_expr] 158 | else Result.Error (`Unexpected_number_of_columns (len_row, [%e len_expected]))] 159 | 160 | let build_process_rows ~loc = function 161 | | "select_one" -> 162 | Ok 163 | [%expr 164 | fun () -> 165 | let rec loop acc = 166 | Prepared.fetch stmt_result >>= fun maybe_row -> 167 | match acc, maybe_row with 168 | | [], Option.Some row -> ( 169 | match process_out_params row with 170 | | Result.Ok row' -> loop [row'] 171 | | Result.Error _ as err -> IO.return err ) 172 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 173 | | _ :: _, Option.Some _ -> 174 | IO.return (Result.Error `Expected_one_found_many) 175 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 176 | in 177 | loop []] 178 | | "select_opt" -> 179 | Ok 180 | [%expr 181 | fun () -> 182 | let rec loop acc = 183 | Prepared.fetch stmt_result >>= fun maybe_row -> 184 | match acc, maybe_row with 185 | | [], Option.Some row -> ( 186 | match process_out_params row with 187 | | Result.Ok row' -> loop [row'] 188 | | Result.Error _ as err -> IO.return err ) 189 | | [], Option.None -> IO.return (Result.Ok Option.None) 190 | | _ :: _, Option.Some _ -> 191 | IO.return (Result.Error `Expected_maybe_one_found_many) 192 | | hd :: _, Option.None -> IO.return (Result.Ok (Option.Some hd)) 193 | in 194 | loop []] 195 | | "select_all" -> 196 | Ok 197 | [%expr 198 | fun () -> 199 | let rec loop acc = 200 | Prepared.fetch stmt_result >>= function 201 | | Option.Some row -> ( 202 | match process_out_params row with 203 | | Result.Ok row' -> loop (row' :: acc) 204 | | Result.Error _ as err -> IO.return err ) 205 | | Option.None -> IO.return (Result.Ok (List.rev acc)) 206 | in 207 | loop []] 208 | | "execute" -> 209 | Ok 210 | [%expr 211 | fun () -> 212 | Prepared.fetch stmt_result >>= function 213 | | Option.Some _ -> IO.return (Result.Error `Expected_none_found_one) 214 | | Option.None -> IO.return (Result.Ok ())] 215 | | etc -> Error (`Unknown_query_action etc) 216 | 217 | let actually_expand ~loc query_action cached query = 218 | let open Result in 219 | (match cached with 220 | | None | Some "true" -> Ok [%expr Prepared.with_stmt_cached] 221 | | Some "false" -> Ok [%expr Prepared.with_stmt_uncached] 222 | | Some etc -> Error (`Invalid_cached_parameter etc)) >>= fun with_stmt -> 223 | build_process_rows ~loc query_action >>= fun process_rows -> 224 | Query.parse query >>= fun {sql; in_params; out_params; list_params} -> 225 | Query.remove_duplicates in_params >>= fun unique_in_params -> 226 | let dbh_pat, dbh_ident = create_unique_var ~loc unique_in_params "dbh" in 227 | let elems_pat, elems_ident = create_unique_var ~loc unique_in_params "elems" in 228 | ( match list_params with 229 | | None -> 230 | let sql_expr = Buildef.estring ~loc sql in 231 | let param_expr = 232 | Buildef.pexp_array ~loc @@ List.map (build_in_param ~loc) in_params 233 | in 234 | Ok [%expr IO.return (Result.Ok ([%e sql_expr], [%e param_expr]))] 235 | | Some {subsql; string_index; param_index; params} -> 236 | Query.remove_duplicates params >>= fun unique_params -> 237 | let subsql_expr = Buildef.estring ~loc subsql in 238 | let sql_before = Buildef.estring ~loc @@ String.sub sql 0 string_index in 239 | let sql_after = 240 | Buildef.estring ~loc 241 | @@ String.sub sql string_index (String.length sql - string_index) 242 | in 243 | let params_before, params_after = split_n in_params param_index in 244 | let params_before = 245 | Buildef.pexp_array ~loc @@ List.map (build_in_param ~loc) params_before 246 | in 247 | let params_after = 248 | Buildef.pexp_array ~loc @@ List.map (build_in_param ~loc) params_after 249 | in 250 | let list_params_decl = 251 | let make_elem param = Buildef.ppat_var ~loc (Loc.make ~loc Query.(param.name)) in 252 | Buildef.ppat_tuple ~loc @@ List.map make_elem unique_params 253 | in 254 | let list_params_conv = 255 | Buildef.elist ~loc @@ List.map (build_in_param ~loc) params 256 | in 257 | Ok 258 | [%expr 259 | match [%e elems_ident] with 260 | | [] -> IO.return (Result.Error `Empty_input_list) 261 | | elems -> 262 | let subsqls = List.map (fun _ -> [%e subsql_expr]) elems in 263 | let patch = String.concat ", " subsqls in 264 | let sql = 265 | String.append [%e sql_before] (String.append patch [%e sql_after]) 266 | in 267 | let params_between = 268 | Array.of_list 269 | (List.concat 270 | (List.map (fun [%p list_params_decl] -> [%e list_params_conv]) elems)) 271 | in 272 | let params = 273 | Array.concat [[%e params_before]; params_between; [%e params_after]] 274 | in 275 | IO.return (Result.Ok (sql, params))] ) 276 | >>= fun setup_expr -> 277 | (* Note that in the expr fragment below we disable warning 26 (about unused variables) 278 | for the 'process_out_params' function, since it may indeed be unused if there are 279 | no output parameters. *) 280 | let expr = 281 | [%expr 282 | let open IO_result in 283 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 284 | let module List = Ppx_mysql_runtime.Stdlib.List in 285 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 286 | let module String = Ppx_mysql_runtime.Stdlib.String in 287 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 288 | [%e setup_expr] >>= fun (sql, params) -> 289 | let[@warning "-26"] process_out_params = 290 | [%e build_out_param_processor ~loc out_params] 291 | in 292 | [%e with_stmt] [%e dbh_ident] sql (fun stmt -> 293 | Prepared.execute_null stmt params >>= fun stmt_result -> [%e process_rows] () 294 | )] 295 | in 296 | let chain = build_fun_chain ~loc expr unique_in_params in 297 | let chain = 298 | match list_params with 299 | | None -> chain 300 | | Some _ -> Buildef.pexp_fun ~loc Nolabel None elems_pat chain 301 | in 302 | Ok (Buildef.pexp_fun ~loc Nolabel None dbh_pat chain) 303 | 304 | let expand ~loc ~path:_ query_action cached query = 305 | match actually_expand ~loc query_action cached query with 306 | | Ok expr -> expr 307 | | Error err -> 308 | let msg = 309 | match err with 310 | | #Query.error as err -> Query.explain_error err 311 | | `Unknown_query_action action -> 312 | Printf.sprintf "I don't understand query action '%s'" action 313 | | `Invalid_cached_parameter param -> 314 | Printf.sprintf "Only values 'true' or 'false' are accepted, but got '%s' instead" param 315 | in 316 | raise 317 | (Location.Error 318 | (Location.Error.createf ~loc "Error in 'mysql' extension: %s" msg)) 319 | 320 | let pattern = 321 | let open Ast_pattern in 322 | let query_action = pexp_ident (lident __) in 323 | let query = pair nolabel (estring __) in 324 | let cached = pair (labelled @@ string "cached") (pexp_construct (lident __) none) in 325 | let without_cached = query ^:: nil in 326 | let with_cached = cached ^:: without_cached in 327 | Ast_pattern.(pexp_apply query_action @@ Ast_pattern.alt_option with_cached without_cached) 328 | 329 | let name = "mysql" 330 | 331 | let ext = 332 | Extension.declare 333 | name 334 | Extension.Context.expression 335 | Ast_pattern.(single_expr_payload pattern) 336 | expand 337 | 338 | let () = Driver.register_transformation name ~extensions:[ext] 339 | -------------------------------------------------------------------------------- /ppx/query.mli: -------------------------------------------------------------------------------- 1 | (** {1 Type definitions} *) 2 | 3 | type param = { 4 | typ : string option * string; 5 | opt : bool; 6 | name : string; 7 | of_string : string * string; 8 | to_string : string * string 9 | } 10 | 11 | type list_params = { 12 | subsql : string; 13 | string_index : int; 14 | param_index : int; 15 | params : param list 16 | } 17 | 18 | type parsed_query = { 19 | sql : string; 20 | in_params : param list; 21 | out_params : param list; 22 | list_params : list_params option 23 | } 24 | 25 | type parse_error = 26 | [ `Bad_identifier of string 27 | | `Unknown_type_spec of string 28 | | `Empty_list_params 29 | | `Multiple_lists_not_supported 30 | | `Nested_list 31 | | `Optional_list 32 | | `Out_params_in_list 33 | | `Unterminated_list 34 | | `Unterminated_string 35 | | `Unterminated_bracket 36 | | `Escape_at_end ] 37 | 38 | type conflict_error = [`Conflicting_spec of string] 39 | 40 | type error = 41 | [ parse_error 42 | | conflict_error ] 43 | 44 | (** {1 Public functions and values} *) 45 | 46 | val parse : string -> (parsed_query, [> parse_error]) result 47 | 48 | val remove_duplicates : param list -> (param list, [> conflict_error]) result 49 | 50 | val explain_error : [< error] -> string 51 | -------------------------------------------------------------------------------- /ppx/query.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Ppx_mysql_runtime.Stdlib 3 | 4 | module Param_dict = Map.Make (String) 5 | 6 | type param = 7 | { typ : string option * string 8 | ; opt : bool 9 | ; name : string 10 | ; of_string : string * string 11 | ; to_string : string * string } 12 | 13 | type list_params = 14 | { subsql : string 15 | ; string_index : int 16 | ; param_index : int 17 | ; params : param list } 18 | 19 | type parsed_query = 20 | { sql : string 21 | ; in_params : param list 22 | ; out_params : param list 23 | ; list_params : list_params option } 24 | 25 | type parse_error = 26 | [ `Bad_identifier of string 27 | | `Unknown_type_spec of string 28 | | `Empty_list_params 29 | | `Multiple_lists_not_supported 30 | | `Nested_list 31 | | `Optional_list 32 | | `Out_params_in_list 33 | | `Unterminated_list 34 | | `Unterminated_string 35 | | `Unterminated_bracket 36 | | `Escape_at_end ] 37 | 38 | type conflict_error = 39 | [ `Conflicting_spec of string ] 40 | 41 | type error = [ parse_error | conflict_error ] 42 | 43 | type list_status = 44 | | Absent 45 | | Ongoing 46 | | Complete of list_params 47 | 48 | let build_param spec opt name = 49 | let open Result in 50 | begin match spec with 51 | | "int" -> 52 | Ok ((None, "int"), ("Ppx_mysql_runtime", "int_of_string"), ("Stdlib", "string_of_int")) 53 | | "int32" -> 54 | Ok ((None, "int32"), ("Ppx_mysql_runtime", "int32_of_string"), ("Int32", "to_string")) 55 | | "int64" -> 56 | Ok ((None, "int64"), ("Ppx_mysql_runtime", "int64_of_string"), ("Int64", "to_string")) 57 | | "bool" -> 58 | Ok ((None, "bool"), ("Ppx_mysql_runtime", "bool_of_string"), ("Stdlib", "string_of_bool")) 59 | | "string" -> 60 | Ok ((None, "string"), ("Ppx_mysql_runtime", "string_of_string"), ("Ppx_mysql_runtime", "identity")) 61 | | module_name when String.length module_name > 0 && module_name.[0] >= 'A' && module_name.[0] <= 'Z' -> 62 | Ok ((Some module_name, "t"), (module_name, "of_mysql"), (module_name, "to_mysql")) 63 | | spec -> 64 | Error (`Unknown_type_spec spec) 65 | end >>= fun (typ, of_string, to_string) -> 66 | Ok {typ; opt = (opt = "?"); name; of_string; to_string} 67 | } 68 | 69 | let escape = '\\' 70 | let squot = '\'' 71 | let dquot = '"' 72 | let quot = squot | dquot 73 | let digit = ['0'-'9'] 74 | let lower = ['a'-'z'] 75 | let upper = ['A'-'Z'] 76 | let underscore = '_' 77 | let ident = (lower | underscore) (lower | upper | underscore | digit)* 78 | let spec = (lower | upper | underscore | digit)+ 79 | 80 | rule main_parser buf acc_in acc_out list_status = parse 81 | | quot as delim 82 | {Buffer.add_char buf delim; 83 | quotation_parser buf acc_in acc_out list_status delim lexbuf} 84 | | '%' (spec as spec) ('?'? as opt) '{' 85 | {match spec, opt with 86 | | "list", "" -> 87 | begin match list_status with 88 | | Complete _ -> 89 | Error `Multiple_lists_not_supported 90 | | Ongoing -> 91 | Error `Nested_list 92 | | Absent -> 93 | let open Result in 94 | let string_index = Buffer.length buf in 95 | let sub_buf = Buffer.create 64 in 96 | main_parser sub_buf [] [] Ongoing lexbuf >>= function 97 | | {sql = _; in_params = []; out_params = []; list_params = _} -> 98 | Error `Empty_list_params 99 | | {sql = subsql; in_params = params; out_params = []; list_params = _} -> 100 | let param_index = List.length acc_in in 101 | let list_status = Complete {subsql; string_index; param_index; params} in 102 | main_parser buf acc_in acc_out list_status lexbuf 103 | | _ -> 104 | Error `Out_params_in_list 105 | end 106 | | "list", "?" -> 107 | Error `Optional_list 108 | | spec, opt -> 109 | let open Result in 110 | ident_parser lexbuf >>= fun name -> 111 | build_param spec opt name >>= fun in_param -> 112 | Buffer.add_char buf '?'; 113 | main_parser buf (in_param :: acc_in) acc_out list_status lexbuf} 114 | | '@' (spec as spec) ('?'? as opt) '{' 115 | {let open Result in 116 | out_param_parser lexbuf >>= fun name -> 117 | build_param spec opt name >>= fun out_param -> 118 | Buffer.add_string buf name; 119 | main_parser buf acc_in (out_param :: acc_out) list_status lexbuf} 120 | | escape eof 121 | {Error `Escape_at_end} 122 | | escape _ as str 123 | {Buffer.add_string buf str; 124 | main_parser buf acc_in acc_out list_status lexbuf} 125 | | '}' 126 | {match list_status with 127 | | Ongoing -> 128 | let sql = Buffer.contents buf in 129 | let in_params = List.rev acc_in in 130 | let out_params = List.rev acc_out in 131 | Ok {sql; in_params; out_params; list_params = None} 132 | | Absent | Complete _ -> 133 | Buffer.add_char buf '}'; 134 | main_parser buf acc_in acc_out list_status lexbuf} 135 | | _ as chr 136 | {Buffer.add_char buf chr; 137 | main_parser buf acc_in acc_out list_status lexbuf} 138 | | eof 139 | {let sql = Buffer.contents buf in 140 | let in_params = List.rev acc_in in 141 | let out_params = List.rev acc_out in 142 | match list_status with 143 | | Ongoing -> 144 | Error `Unterminated_list 145 | | Absent -> 146 | Ok {sql; in_params; out_params; list_params = None} 147 | | Complete nested -> 148 | Ok {sql; in_params; out_params; list_params = Some nested}} 149 | 150 | and quotation_parser buf acc_in acc_out list_status delim = parse 151 | | escape eof 152 | {Error `Escape_at_end} 153 | | escape _ as str 154 | {Buffer.add_string buf str; 155 | quotation_parser buf acc_in acc_out list_status delim lexbuf} 156 | | squot squot as str 157 | {Buffer.add_string buf str; 158 | quotation_parser buf acc_in acc_out list_status delim lexbuf} 159 | | dquot dquot as str 160 | {Buffer.add_string buf str; 161 | quotation_parser buf acc_in acc_out list_status delim lexbuf} 162 | | quot as chr 163 | {Buffer.add_char buf chr; 164 | if delim = chr 165 | then main_parser buf acc_in acc_out list_status lexbuf 166 | else quotation_parser buf acc_in acc_out list_status delim lexbuf} 167 | | _ as chr 168 | {Buffer.add_char buf chr; 169 | quotation_parser buf acc_in acc_out list_status delim lexbuf} 170 | | eof 171 | {Error `Unterminated_string} 172 | 173 | and ident_parser = parse 174 | | (ident as ident) '}' 175 | {Ok ident} 176 | | ([^ '}' ]+ as etc) '}' 177 | {Error (`Bad_identifier etc)} 178 | | _ 179 | {Error `Unterminated_bracket} 180 | 181 | and out_param_parser = parse 182 | | ([^ '}' ]+ as name) '}' 183 | {Ok name} 184 | | _ 185 | {Error `Unterminated_bracket} 186 | 187 | { 188 | let parse query = 189 | let lexbuf = Lexing.from_string query in 190 | let buf = Buffer.create (String.length query) in 191 | main_parser buf [] [] Absent lexbuf 192 | 193 | let remove_duplicates params = 194 | let rec loop dict accum = function 195 | | [] -> 196 | Ok (List.rev accum) 197 | | {name; typ; opt; _} as hd :: tl -> 198 | match Param_dict.find_opt name dict with 199 | | None -> 200 | let dict = Param_dict.add name hd dict in 201 | let accum = hd :: accum in 202 | loop dict accum tl 203 | | Some el when el.typ = typ && el.opt = opt -> 204 | loop dict accum tl 205 | | Some _el -> 206 | Error (`Conflicting_spec name) 207 | in 208 | loop Param_dict.empty [] params 209 | 210 | let explain_error = function 211 | | `Bad_identifier str -> 212 | Printf.sprintf "'%s' is not a valid OCaml variable identifier" str 213 | | `Unknown_type_spec spec -> 214 | Printf.sprintf "Unknown type specification '%s'" spec 215 | | `Empty_list_params -> 216 | "Lists must have at least one parameter" 217 | | `Multiple_lists_not_supported -> 218 | "The query contains multiple lists. Multiple lists are not supported" 219 | | `Nested_list -> 220 | "The query contains a nested list parameter" 221 | | `Optional_list -> 222 | "Optional lists are not supported (why would you do this?)" 223 | | `Out_params_in_list -> 224 | "Contents of list parameter may not contain an output parameter" 225 | | `Unterminated_list -> 226 | "The query contains an unterminated list parameter" 227 | | `Unterminated_string -> 228 | "The query contains an unterminated string" 229 | | `Unterminated_bracket -> 230 | "The query contains an unterminated bracket" 231 | | `Escape_at_end -> 232 | "The last character of the query cannot be an escape character" 233 | | `Conflicting_spec name -> 234 | Printf.sprintf "Input parameter '%s' appears multiple times with conflicting specifications" name 235 | } 236 | -------------------------------------------------------------------------------- /ppx_mysql.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Dario Teixeira " 3 | author: "Team Raccoons at Issuu" 4 | synopsis: "Syntax extension for facilitating usage of MySQL bindings" 5 | description: """ 6 | This syntax extension aims to reduce the pain and boilerplate associated with 7 | using MySQL bindings from OCaml. It is similar in spirit to PG'OCaml, but 8 | without the compile-time communication with the DB engine for type inference. 9 | """ 10 | homepage: "https://github.com/issuu/ppx_mysql" 11 | dev-repo: "git+https://github.com/issuu/ppx_mysql.git" 12 | bug-reports: "https://github.com/issuu/ppx_mysql/issues" 13 | doc: "https://issuu.github.io/ppx_mysql/" 14 | build: [ 15 | ["dune" "build" "-p" name "-j" jobs] 16 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 17 | ] 18 | depends: [ 19 | "alcotest" {with-test & >= "0.8" & < "0.9"} 20 | "dune" {>= "1.4"} 21 | "ocamlformat" {with-test & >= "0.9" & < "0.10"} 22 | "ocaml" {>= "4.06.0" } 23 | "ppx_deriving" {with-test & >= "4.2" & < "5.0"} 24 | "ppxlib" {>= "0.2"} 25 | "stdlib-shims" 26 | ] 27 | -------------------------------------------------------------------------------- /ppx_mysql_identity.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Dario Teixeira " 3 | author: "Team Raccoons at Issuu" 4 | synopsis: "Convenience package for using ppx_mysql with Mysql and the identity monad for IO" 5 | description: """ 6 | The ppx_mysql extension expects the existence of several modules in the current context. 7 | This package provides the definition of those modules for using ppx_mysql with Mysql 8 | (via OPAM's mysql package) and the identity monad for IO. 9 | """ 10 | homepage: "https://github.com/issuu/ppx_mysql" 11 | dev-repo: "git+https://github.com/issuu/ppx_mysql.git" 12 | bug-reports: "https://github.com/issuu/ppx_mysql/issues" 13 | doc: "https://issuu.github.io/ppx_mysql/" 14 | build: [["dune" "build" "-p" name "-j" jobs]] 15 | depends: [ 16 | "dune" {>= "1.4"} 17 | "mysql" {>= "1.2" & < "2.0"} 18 | "ocaml" {>= "4.06.0"} 19 | "ppx_mysql" {= version} 20 | ] 21 | -------------------------------------------------------------------------------- /tests/test_ppx/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pp) 3 | (modules pp) 4 | (libraries ppx_mysql ppxlib)) 5 | 6 | (rule 7 | (targets test_ppx.result.ml) 8 | (deps test_ppx.ml) 9 | (action (run ./pp.exe --impl %{deps} -o %{targets}))) 10 | 11 | (rule 12 | (targets test_ppx.result.reformatted.ml) 13 | (deps test_ppx.result.ml) 14 | (action (run ocamlformat %{deps} -o %{targets}))) 15 | 16 | (rule 17 | (targets test_ppx.expected.reformatted.ml) 18 | (deps test_ppx.expected.ml) 19 | (action (run ocamlformat %{deps} -o %{targets}))) 20 | 21 | (alias 22 | (name runtest) 23 | (action (diff test_ppx.expected.reformatted.ml test_ppx.result.reformatted.ml))) 24 | -------------------------------------------------------------------------------- /tests/test_ppx/pp.ml: -------------------------------------------------------------------------------- 1 | ;; 2 | Ppxlib.Driver.standalone () 3 | -------------------------------------------------------------------------------- /tests/test_ppx/test_ppx.expected.ml: -------------------------------------------------------------------------------- 1 | let test_no_params dbh = 2 | let open IO_result in 3 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 4 | let module List = Ppx_mysql_runtime.Stdlib.List in 5 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 6 | let module String = Ppx_mysql_runtime.Stdlib.String in 7 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 8 | IO.return (Result.Ok ("SELECT TRUE", [||])) >>= fun (sql, params) -> 9 | let process_out_params row = 10 | let len_row = Array.length row in 11 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 0 12 | then Result.Ok () 13 | else Result.Error (`Unexpected_number_of_columns (len_row, 0)) 14 | [@@warning "-26"] 15 | in 16 | Prepared.with_stmt_cached dbh sql (fun stmt -> 17 | Prepared.execute_null stmt params >>= fun stmt_result -> 18 | (fun () -> 19 | let rec loop acc = 20 | Prepared.fetch stmt_result >>= fun maybe_row -> 21 | match acc, maybe_row with 22 | | [], Option.Some row -> ( 23 | match process_out_params row with 24 | | Result.Ok row' -> loop [row'] 25 | | Result.Error _ as err -> IO.return err ) 26 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 27 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 28 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 29 | in 30 | loop [] ) 31 | () ) 32 | 33 | let test_single_output_params dbh = 34 | let open IO_result in 35 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 36 | let module List = Ppx_mysql_runtime.Stdlib.List in 37 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 38 | let module String = Ppx_mysql_runtime.Stdlib.String in 39 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 40 | IO.return (Result.Ok ("SELECT name FROM users WHERE id = 1", [||])) 41 | >>= fun (sql, params) -> 42 | let process_out_params row = 43 | let len_row = Array.length row in 44 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 1 45 | then 46 | let err_accum = [] in 47 | match 48 | Ppx_mysql_runtime.deserialize_non_nullable_column 49 | 0 50 | "name" 51 | Ppx_mysql_runtime.string_of_string 52 | "Ppx_mysql_runtime.string_of_string" 53 | err_accum 54 | row.(0) 55 | with 56 | | Option.Some res, _ -> Result.Ok res 57 | | Option.None, err -> Result.Error (`Column_errors err) 58 | else Result.Error (`Unexpected_number_of_columns (len_row, 1)) 59 | [@@warning "-26"] 60 | in 61 | Prepared.with_stmt_cached dbh sql (fun stmt -> 62 | Prepared.execute_null stmt params >>= fun stmt_result -> 63 | (fun () -> 64 | let rec loop acc = 65 | Prepared.fetch stmt_result >>= fun maybe_row -> 66 | match acc, maybe_row with 67 | | [], Option.Some row -> ( 68 | match process_out_params row with 69 | | Result.Ok row' -> loop [row'] 70 | | Result.Error _ as err -> IO.return err ) 71 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 72 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 73 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 74 | in 75 | loop [] ) 76 | () ) 77 | 78 | let test_pair_output_params dbh = 79 | let open IO_result in 80 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 81 | let module List = Ppx_mysql_runtime.Stdlib.List in 82 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 83 | let module String = Ppx_mysql_runtime.Stdlib.String in 84 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 85 | IO.return (Result.Ok ("SELECT id, name FROM users WHERE id = 1", [||])) 86 | >>= fun (sql, params) -> 87 | let process_out_params row = 88 | let len_row = Array.length row in 89 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 90 | then 91 | let err_accum = [] in 92 | let col0, err_accum = 93 | Ppx_mysql_runtime.deserialize_non_nullable_column 94 | 0 95 | "id" 96 | Ppx_mysql_runtime.int_of_string 97 | "Ppx_mysql_runtime.int_of_string" 98 | err_accum 99 | row.(0) 100 | in 101 | let col1, err_accum = 102 | Ppx_mysql_runtime.deserialize_non_nullable_column 103 | 1 104 | "name" 105 | Ppx_mysql_runtime.string_of_string 106 | "Ppx_mysql_runtime.string_of_string" 107 | err_accum 108 | row.(1) 109 | in 110 | match col0, col1 with 111 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 112 | | _ -> Result.Error (`Column_errors err_accum) 113 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 114 | [@@warning "-26"] 115 | in 116 | Prepared.with_stmt_cached dbh sql (fun stmt -> 117 | Prepared.execute_null stmt params >>= fun stmt_result -> 118 | (fun () -> 119 | let rec loop acc = 120 | Prepared.fetch stmt_result >>= fun maybe_row -> 121 | match acc, maybe_row with 122 | | [], Option.Some row -> ( 123 | match process_out_params row with 124 | | Result.Ok row' -> loop [row'] 125 | | Result.Error _ as err -> IO.return err ) 126 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 127 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 128 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 129 | in 130 | loop [] ) 131 | () ) 132 | 133 | let test_one_input_params dbh ~(id : int) = 134 | let open IO_result in 135 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 136 | let module List = Ppx_mysql_runtime.Stdlib.List in 137 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 138 | let module String = Ppx_mysql_runtime.Stdlib.String in 139 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 140 | IO.return 141 | (Result.Ok 142 | ("SELECT name FROM users WHERE id = ?", [|Option.Some (Stdlib.string_of_int id)|])) 143 | >>= fun (sql, params) -> 144 | let process_out_params row = 145 | let len_row = Array.length row in 146 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 1 147 | then 148 | let err_accum = [] in 149 | match 150 | Ppx_mysql_runtime.deserialize_non_nullable_column 151 | 0 152 | "name" 153 | Ppx_mysql_runtime.string_of_string 154 | "Ppx_mysql_runtime.string_of_string" 155 | err_accum 156 | row.(0) 157 | with 158 | | Option.Some res, _ -> Result.Ok res 159 | | Option.None, err -> Result.Error (`Column_errors err) 160 | else Result.Error (`Unexpected_number_of_columns (len_row, 1)) 161 | [@@warning "-26"] 162 | in 163 | Prepared.with_stmt_cached dbh sql (fun stmt -> 164 | Prepared.execute_null stmt params >>= fun stmt_result -> 165 | (fun () -> 166 | let rec loop acc = 167 | Prepared.fetch stmt_result >>= fun maybe_row -> 168 | match acc, maybe_row with 169 | | [], Option.Some row -> ( 170 | match process_out_params row with 171 | | Result.Ok row' -> loop [row'] 172 | | Result.Error _ as err -> IO.return err ) 173 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 174 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 175 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 176 | in 177 | loop [] ) 178 | () ) 179 | 180 | let test_two_input_pair_output_params dbh ~(id : int) ~(name : string) = 181 | let open IO_result in 182 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 183 | let module List = Ppx_mysql_runtime.Stdlib.List in 184 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 185 | let module String = Ppx_mysql_runtime.Stdlib.String in 186 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 187 | IO.return 188 | (Result.Ok 189 | ( "SELECT id, name FROM users WHERE id = ? OR name = ?", 190 | [| Option.Some (Stdlib.string_of_int id); 191 | Option.Some (Ppx_mysql_runtime.identity name) |] )) 192 | >>= fun (sql, params) -> 193 | let process_out_params row = 194 | let len_row = Array.length row in 195 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 196 | then 197 | let err_accum = [] in 198 | let col0, err_accum = 199 | Ppx_mysql_runtime.deserialize_non_nullable_column 200 | 0 201 | "id" 202 | Ppx_mysql_runtime.int_of_string 203 | "Ppx_mysql_runtime.int_of_string" 204 | err_accum 205 | row.(0) 206 | in 207 | let col1, err_accum = 208 | Ppx_mysql_runtime.deserialize_non_nullable_column 209 | 1 210 | "name" 211 | Ppx_mysql_runtime.string_of_string 212 | "Ppx_mysql_runtime.string_of_string" 213 | err_accum 214 | row.(1) 215 | in 216 | match col0, col1 with 217 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 218 | | _ -> Result.Error (`Column_errors err_accum) 219 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 220 | [@@warning "-26"] 221 | in 222 | Prepared.with_stmt_cached dbh sql (fun stmt -> 223 | Prepared.execute_null stmt params >>= fun stmt_result -> 224 | (fun () -> 225 | let rec loop acc = 226 | Prepared.fetch stmt_result >>= fun maybe_row -> 227 | match acc, maybe_row with 228 | | [], Option.Some row -> ( 229 | match process_out_params row with 230 | | Result.Ok row' -> loop [row'] 231 | | Result.Error _ as err -> IO.return err ) 232 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 233 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 234 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 235 | in 236 | loop [] ) 237 | () ) 238 | 239 | let test_select_all dbh = 240 | let open IO_result in 241 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 242 | let module List = Ppx_mysql_runtime.Stdlib.List in 243 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 244 | let module String = Ppx_mysql_runtime.Stdlib.String in 245 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 246 | IO.return (Result.Ok ("SELECT id, name FROM users", [||])) >>= fun (sql, params) -> 247 | let process_out_params row = 248 | let len_row = Array.length row in 249 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 250 | then 251 | let err_accum = [] in 252 | let col0, err_accum = 253 | Ppx_mysql_runtime.deserialize_non_nullable_column 254 | 0 255 | "id" 256 | Ppx_mysql_runtime.int_of_string 257 | "Ppx_mysql_runtime.int_of_string" 258 | err_accum 259 | row.(0) 260 | in 261 | let col1, err_accum = 262 | Ppx_mysql_runtime.deserialize_non_nullable_column 263 | 1 264 | "name" 265 | Ppx_mysql_runtime.string_of_string 266 | "Ppx_mysql_runtime.string_of_string" 267 | err_accum 268 | row.(1) 269 | in 270 | match col0, col1 with 271 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 272 | | _ -> Result.Error (`Column_errors err_accum) 273 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 274 | [@@warning "-26"] 275 | in 276 | Prepared.with_stmt_cached dbh sql (fun stmt -> 277 | Prepared.execute_null stmt params >>= fun stmt_result -> 278 | (fun () -> 279 | let rec loop acc = 280 | Prepared.fetch stmt_result >>= function 281 | | Option.Some row -> ( 282 | match process_out_params row with 283 | | Result.Ok row' -> loop (row' :: acc) 284 | | Result.Error _ as err -> IO.return err ) 285 | | Option.None -> IO.return (Result.Ok (List.rev acc)) 286 | in 287 | loop [] ) 288 | () ) 289 | 290 | let test_repeated_input_params dbh ~(id : int) = 291 | let open IO_result in 292 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 293 | let module List = Ppx_mysql_runtime.Stdlib.List in 294 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 295 | let module String = Ppx_mysql_runtime.Stdlib.String in 296 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 297 | IO.return 298 | (Result.Ok 299 | ( "SELECT id, name FROM users WHERE id <> ? AND id <> ?", 300 | [|Option.Some (Stdlib.string_of_int id); Option.Some (Stdlib.string_of_int id)|] 301 | )) 302 | >>= fun (sql, params) -> 303 | let process_out_params row = 304 | let len_row = Array.length row in 305 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 306 | then 307 | let err_accum = [] in 308 | let col0, err_accum = 309 | Ppx_mysql_runtime.deserialize_non_nullable_column 310 | 0 311 | "id" 312 | Ppx_mysql_runtime.int_of_string 313 | "Ppx_mysql_runtime.int_of_string" 314 | err_accum 315 | row.(0) 316 | in 317 | let col1, err_accum = 318 | Ppx_mysql_runtime.deserialize_non_nullable_column 319 | 1 320 | "name" 321 | Ppx_mysql_runtime.string_of_string 322 | "Ppx_mysql_runtime.string_of_string" 323 | err_accum 324 | row.(1) 325 | in 326 | match col0, col1 with 327 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 328 | | _ -> Result.Error (`Column_errors err_accum) 329 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 330 | [@@warning "-26"] 331 | in 332 | Prepared.with_stmt_cached dbh sql (fun stmt -> 333 | Prepared.execute_null stmt params >>= fun stmt_result -> 334 | (fun () -> 335 | let rec loop acc = 336 | Prepared.fetch stmt_result >>= function 337 | | Option.Some row -> ( 338 | match process_out_params row with 339 | | Result.Ok row' -> loop (row' :: acc) 340 | | Result.Error _ as err -> IO.return err ) 341 | | Option.None -> IO.return (Result.Ok (List.rev acc)) 342 | in 343 | loop [] ) 344 | () ) 345 | 346 | let test_select_opt dbh ~(id : int) = 347 | let open IO_result in 348 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 349 | let module List = Ppx_mysql_runtime.Stdlib.List in 350 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 351 | let module String = Ppx_mysql_runtime.Stdlib.String in 352 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 353 | IO.return 354 | (Result.Ok 355 | ( "SELECT id, name FROM users WHERE id = ?", 356 | [|Option.Some (Stdlib.string_of_int id)|] )) 357 | >>= fun (sql, params) -> 358 | let process_out_params row = 359 | let len_row = Array.length row in 360 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 361 | then 362 | let err_accum = [] in 363 | let col0, err_accum = 364 | Ppx_mysql_runtime.deserialize_non_nullable_column 365 | 0 366 | "id" 367 | Ppx_mysql_runtime.int_of_string 368 | "Ppx_mysql_runtime.int_of_string" 369 | err_accum 370 | row.(0) 371 | in 372 | let col1, err_accum = 373 | Ppx_mysql_runtime.deserialize_non_nullable_column 374 | 1 375 | "name" 376 | Ppx_mysql_runtime.string_of_string 377 | "Ppx_mysql_runtime.string_of_string" 378 | err_accum 379 | row.(1) 380 | in 381 | match col0, col1 with 382 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 383 | | _ -> Result.Error (`Column_errors err_accum) 384 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 385 | [@@warning "-26"] 386 | in 387 | Prepared.with_stmt_cached dbh sql (fun stmt -> 388 | Prepared.execute_null stmt params >>= fun stmt_result -> 389 | (fun () -> 390 | let rec loop acc = 391 | Prepared.fetch stmt_result >>= fun maybe_row -> 392 | match acc, maybe_row with 393 | | [], Option.Some row -> ( 394 | match process_out_params row with 395 | | Result.Ok row' -> loop [row'] 396 | | Result.Error _ as err -> IO.return err ) 397 | | [], Option.None -> IO.return (Result.Ok Option.None) 398 | | _ :: _, Option.Some _ -> 399 | IO.return (Result.Error `Expected_maybe_one_found_many) 400 | | hd :: _, Option.None -> IO.return (Result.Ok (Option.Some hd)) 401 | in 402 | loop [] ) 403 | () ) 404 | 405 | let test_execute dbh ~(id : int) = 406 | let open IO_result in 407 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 408 | let module List = Ppx_mysql_runtime.Stdlib.List in 409 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 410 | let module String = Ppx_mysql_runtime.Stdlib.String in 411 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 412 | IO.return 413 | (Result.Ok 414 | ("DELETE FROM users WHERE id = ?", [|Option.Some (Stdlib.string_of_int id)|])) 415 | >>= fun (sql, params) -> 416 | let process_out_params row = 417 | let len_row = Array.length row in 418 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 0 419 | then Result.Ok () 420 | else Result.Error (`Unexpected_number_of_columns (len_row, 0)) 421 | [@@warning "-26"] 422 | in 423 | Prepared.with_stmt_cached dbh sql (fun stmt -> 424 | Prepared.execute_null stmt params >>= fun stmt_result -> 425 | (fun () -> 426 | Prepared.fetch stmt_result >>= function 427 | | Option.Some _ -> IO.return (Result.Error `Expected_none_found_one) 428 | | Option.None -> IO.return (Result.Ok ()) ) 429 | () ) 430 | 431 | let test_int dbh ~(a : int) ~(b : int option) = 432 | let open IO_result in 433 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 434 | let module List = Ppx_mysql_runtime.Stdlib.List in 435 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 436 | let module String = Ppx_mysql_runtime.Stdlib.String in 437 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 438 | IO.return 439 | (Result.Ok 440 | ( "SELECT a, b FROM users where a = ? OR b = ?", 441 | [|Option.Some (Stdlib.string_of_int a); (Option.map Stdlib.string_of_int) b|] )) 442 | >>= fun (sql, params) -> 443 | let process_out_params row = 444 | let len_row = Array.length row in 445 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 446 | then 447 | let err_accum = [] in 448 | let col0, err_accum = 449 | Ppx_mysql_runtime.deserialize_non_nullable_column 450 | 0 451 | "a" 452 | Ppx_mysql_runtime.int_of_string 453 | "Ppx_mysql_runtime.int_of_string" 454 | err_accum 455 | row.(0) 456 | in 457 | let col1, err_accum = 458 | Ppx_mysql_runtime.deserialize_nullable_column 459 | 1 460 | "b" 461 | Ppx_mysql_runtime.int_of_string 462 | "Ppx_mysql_runtime.int_of_string" 463 | err_accum 464 | row.(1) 465 | in 466 | match col0, col1 with 467 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 468 | | _ -> Result.Error (`Column_errors err_accum) 469 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 470 | [@@warning "-26"] 471 | in 472 | Prepared.with_stmt_cached dbh sql (fun stmt -> 473 | Prepared.execute_null stmt params >>= fun stmt_result -> 474 | (fun () -> 475 | let rec loop acc = 476 | Prepared.fetch stmt_result >>= fun maybe_row -> 477 | match acc, maybe_row with 478 | | [], Option.Some row -> ( 479 | match process_out_params row with 480 | | Result.Ok row' -> loop [row'] 481 | | Result.Error _ as err -> IO.return err ) 482 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 483 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 484 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 485 | in 486 | loop [] ) 487 | () ) 488 | 489 | let test_int32 dbh ~(a : int32) ~(b : int32 option) = 490 | let open IO_result in 491 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 492 | let module List = Ppx_mysql_runtime.Stdlib.List in 493 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 494 | let module String = Ppx_mysql_runtime.Stdlib.String in 495 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 496 | IO.return 497 | (Result.Ok 498 | ( "SELECT a, b FROM users where a = ? OR b = ?", 499 | [|Option.Some (Int32.to_string a); (Option.map Int32.to_string) b|] )) 500 | >>= fun (sql, params) -> 501 | let process_out_params row = 502 | let len_row = Array.length row in 503 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 504 | then 505 | let err_accum = [] in 506 | let col0, err_accum = 507 | Ppx_mysql_runtime.deserialize_non_nullable_column 508 | 0 509 | "a" 510 | Ppx_mysql_runtime.int32_of_string 511 | "Ppx_mysql_runtime.int32_of_string" 512 | err_accum 513 | row.(0) 514 | in 515 | let col1, err_accum = 516 | Ppx_mysql_runtime.deserialize_nullable_column 517 | 1 518 | "b" 519 | Ppx_mysql_runtime.int32_of_string 520 | "Ppx_mysql_runtime.int32_of_string" 521 | err_accum 522 | row.(1) 523 | in 524 | match col0, col1 with 525 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 526 | | _ -> Result.Error (`Column_errors err_accum) 527 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 528 | [@@warning "-26"] 529 | in 530 | Prepared.with_stmt_cached dbh sql (fun stmt -> 531 | Prepared.execute_null stmt params >>= fun stmt_result -> 532 | (fun () -> 533 | let rec loop acc = 534 | Prepared.fetch stmt_result >>= fun maybe_row -> 535 | match acc, maybe_row with 536 | | [], Option.Some row -> ( 537 | match process_out_params row with 538 | | Result.Ok row' -> loop [row'] 539 | | Result.Error _ as err -> IO.return err ) 540 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 541 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 542 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 543 | in 544 | loop [] ) 545 | () ) 546 | 547 | let test_int64 dbh ~(a : int64) ~(b : int64 option) = 548 | let open IO_result in 549 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 550 | let module List = Ppx_mysql_runtime.Stdlib.List in 551 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 552 | let module String = Ppx_mysql_runtime.Stdlib.String in 553 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 554 | IO.return 555 | (Result.Ok 556 | ( "SELECT a, b FROM users where a = ? OR b = ?", 557 | [|Option.Some (Int64.to_string a); (Option.map Int64.to_string) b|] )) 558 | >>= fun (sql, params) -> 559 | let process_out_params row = 560 | let len_row = Array.length row in 561 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 562 | then 563 | let err_accum = [] in 564 | let col0, err_accum = 565 | Ppx_mysql_runtime.deserialize_non_nullable_column 566 | 0 567 | "a" 568 | Ppx_mysql_runtime.int64_of_string 569 | "Ppx_mysql_runtime.int64_of_string" 570 | err_accum 571 | row.(0) 572 | in 573 | let col1, err_accum = 574 | Ppx_mysql_runtime.deserialize_nullable_column 575 | 1 576 | "b" 577 | Ppx_mysql_runtime.int64_of_string 578 | "Ppx_mysql_runtime.int64_of_string" 579 | err_accum 580 | row.(1) 581 | in 582 | match col0, col1 with 583 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 584 | | _ -> Result.Error (`Column_errors err_accum) 585 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 586 | [@@warning "-26"] 587 | in 588 | Prepared.with_stmt_cached dbh sql (fun stmt -> 589 | Prepared.execute_null stmt params >>= fun stmt_result -> 590 | (fun () -> 591 | let rec loop acc = 592 | Prepared.fetch stmt_result >>= fun maybe_row -> 593 | match acc, maybe_row with 594 | | [], Option.Some row -> ( 595 | match process_out_params row with 596 | | Result.Ok row' -> loop [row'] 597 | | Result.Error _ as err -> IO.return err ) 598 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 599 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 600 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 601 | in 602 | loop [] ) 603 | () ) 604 | 605 | let test_bool dbh ~(a : bool) ~(b : bool option) = 606 | let open IO_result in 607 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 608 | let module List = Ppx_mysql_runtime.Stdlib.List in 609 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 610 | let module String = Ppx_mysql_runtime.Stdlib.String in 611 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 612 | IO.return 613 | (Result.Ok 614 | ( "SELECT a, b FROM users where a = ? OR b = ?", 615 | [|Option.Some (Stdlib.string_of_bool a); (Option.map Stdlib.string_of_bool) b|] 616 | )) 617 | >>= fun (sql, params) -> 618 | let process_out_params row = 619 | let len_row = Array.length row in 620 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 621 | then 622 | let err_accum = [] in 623 | let col0, err_accum = 624 | Ppx_mysql_runtime.deserialize_non_nullable_column 625 | 0 626 | "a" 627 | Ppx_mysql_runtime.bool_of_string 628 | "Ppx_mysql_runtime.bool_of_string" 629 | err_accum 630 | row.(0) 631 | in 632 | let col1, err_accum = 633 | Ppx_mysql_runtime.deserialize_nullable_column 634 | 1 635 | "b" 636 | Ppx_mysql_runtime.bool_of_string 637 | "Ppx_mysql_runtime.bool_of_string" 638 | err_accum 639 | row.(1) 640 | in 641 | match col0, col1 with 642 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 643 | | _ -> Result.Error (`Column_errors err_accum) 644 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 645 | [@@warning "-26"] 646 | in 647 | Prepared.with_stmt_cached dbh sql (fun stmt -> 648 | Prepared.execute_null stmt params >>= fun stmt_result -> 649 | (fun () -> 650 | let rec loop acc = 651 | Prepared.fetch stmt_result >>= fun maybe_row -> 652 | match acc, maybe_row with 653 | | [], Option.Some row -> ( 654 | match process_out_params row with 655 | | Result.Ok row' -> loop [row'] 656 | | Result.Error _ as err -> IO.return err ) 657 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 658 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 659 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 660 | in 661 | loop [] ) 662 | () ) 663 | 664 | let test_string dbh ~(a : string) ~(b : string option) = 665 | let open IO_result in 666 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 667 | let module List = Ppx_mysql_runtime.Stdlib.List in 668 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 669 | let module String = Ppx_mysql_runtime.Stdlib.String in 670 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 671 | IO.return 672 | (Result.Ok 673 | ( "SELECT a, b FROM users where a = ? OR b = ?", 674 | [| Option.Some (Ppx_mysql_runtime.identity a); 675 | (Option.map Ppx_mysql_runtime.identity) b |] )) 676 | >>= fun (sql, params) -> 677 | let process_out_params row = 678 | let len_row = Array.length row in 679 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 680 | then 681 | let err_accum = [] in 682 | let col0, err_accum = 683 | Ppx_mysql_runtime.deserialize_non_nullable_column 684 | 0 685 | "a" 686 | Ppx_mysql_runtime.string_of_string 687 | "Ppx_mysql_runtime.string_of_string" 688 | err_accum 689 | row.(0) 690 | in 691 | let col1, err_accum = 692 | Ppx_mysql_runtime.deserialize_nullable_column 693 | 1 694 | "b" 695 | Ppx_mysql_runtime.string_of_string 696 | "Ppx_mysql_runtime.string_of_string" 697 | err_accum 698 | row.(1) 699 | in 700 | match col0, col1 with 701 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 702 | | _ -> Result.Error (`Column_errors err_accum) 703 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 704 | [@@warning "-26"] 705 | in 706 | Prepared.with_stmt_cached dbh sql (fun stmt -> 707 | Prepared.execute_null stmt params >>= fun stmt_result -> 708 | (fun () -> 709 | let rec loop acc = 710 | Prepared.fetch stmt_result >>= fun maybe_row -> 711 | match acc, maybe_row with 712 | | [], Option.Some row -> ( 713 | match process_out_params row with 714 | | Result.Ok row' -> loop [row'] 715 | | Result.Error _ as err -> IO.return err ) 716 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 717 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 718 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 719 | in 720 | loop [] ) 721 | () ) 722 | 723 | let test_custom_type dbh ~(a : Id.t) ~(b : Phone.t option) = 724 | let open IO_result in 725 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 726 | let module List = Ppx_mysql_runtime.Stdlib.List in 727 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 728 | let module String = Ppx_mysql_runtime.Stdlib.String in 729 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 730 | IO.return 731 | (Result.Ok 732 | ( "SELECT a, b FROM users where a = ? OR b = ?", 733 | [|Option.Some (Id.to_mysql a); (Option.map Phone.to_mysql) b|] )) 734 | >>= fun (sql, params) -> 735 | let process_out_params row = 736 | let len_row = Array.length row in 737 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 738 | then 739 | let err_accum = [] in 740 | let col0, err_accum = 741 | Ppx_mysql_runtime.deserialize_non_nullable_column 742 | 0 743 | "a" 744 | Id.of_mysql 745 | "Id.of_mysql" 746 | err_accum 747 | row.(0) 748 | in 749 | let col1, err_accum = 750 | Ppx_mysql_runtime.deserialize_nullable_column 751 | 1 752 | "b" 753 | Phone.of_mysql 754 | "Phone.of_mysql" 755 | err_accum 756 | row.(1) 757 | in 758 | match col0, col1 with 759 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 760 | | _ -> Result.Error (`Column_errors err_accum) 761 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 762 | [@@warning "-26"] 763 | in 764 | Prepared.with_stmt_cached dbh sql (fun stmt -> 765 | Prepared.execute_null stmt params >>= fun stmt_result -> 766 | (fun () -> 767 | let rec loop acc = 768 | Prepared.fetch stmt_result >>= fun maybe_row -> 769 | match acc, maybe_row with 770 | | [], Option.Some row -> ( 771 | match process_out_params row with 772 | | Result.Ok row' -> loop [row'] 773 | | Result.Error _ as err -> IO.return err ) 774 | | [], Option.None -> IO.return (Result.Error `Expected_one_found_none) 775 | | _ :: _, Option.Some _ -> IO.return (Result.Error `Expected_one_found_many) 776 | | hd :: _, Option.None -> IO.return (Result.Ok hd) 777 | in 778 | loop [] ) 779 | () ) 780 | 781 | let test_list0 dbh elems = 782 | let open IO_result in 783 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 784 | let module List = Ppx_mysql_runtime.Stdlib.List in 785 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 786 | let module String = Ppx_mysql_runtime.Stdlib.String in 787 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 788 | ( match elems with 789 | | [] -> IO.return (Result.Error `Empty_input_list) 790 | | elems -> 791 | let subsqls = List.map (fun _ -> "?") elems in 792 | let patch = String.concat ", " subsqls in 793 | let sql = 794 | String.append 795 | "SELECT id, name FROM users WHERE id IN (" 796 | (String.append patch ")") 797 | in 798 | let params_between = 799 | Array.of_list 800 | (List.concat 801 | (List.map (fun id -> [Option.Some (Stdlib.string_of_int id)]) elems)) 802 | in 803 | let params = Array.concat [[||]; params_between; [||]] in 804 | IO.return (Result.Ok (sql, params)) ) 805 | >>= fun (sql, params) -> 806 | let process_out_params row = 807 | let len_row = Array.length row in 808 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 809 | then 810 | let err_accum = [] in 811 | let col0, err_accum = 812 | Ppx_mysql_runtime.deserialize_non_nullable_column 813 | 0 814 | "id" 815 | Ppx_mysql_runtime.int_of_string 816 | "Ppx_mysql_runtime.int_of_string" 817 | err_accum 818 | row.(0) 819 | in 820 | let col1, err_accum = 821 | Ppx_mysql_runtime.deserialize_non_nullable_column 822 | 1 823 | "name" 824 | Ppx_mysql_runtime.string_of_string 825 | "Ppx_mysql_runtime.string_of_string" 826 | err_accum 827 | row.(1) 828 | in 829 | match col0, col1 with 830 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 831 | | _ -> Result.Error (`Column_errors err_accum) 832 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 833 | [@@warning "-26"] 834 | in 835 | Prepared.with_stmt_cached dbh sql (fun stmt -> 836 | Prepared.execute_null stmt params >>= fun stmt_result -> 837 | (fun () -> 838 | let rec loop acc = 839 | Prepared.fetch stmt_result >>= function 840 | | Option.Some row -> ( 841 | match process_out_params row with 842 | | Result.Ok row' -> loop (row' :: acc) 843 | | Result.Error _ as err -> IO.return err ) 844 | | Option.None -> IO.return (Result.Ok (List.rev acc)) 845 | in 846 | loop [] ) 847 | () ) 848 | 849 | let test_list1 dbh elems = 850 | let open IO_result in 851 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 852 | let module List = Ppx_mysql_runtime.Stdlib.List in 853 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 854 | let module String = Ppx_mysql_runtime.Stdlib.String in 855 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 856 | ( match elems with 857 | | [] -> IO.return (Result.Error `Empty_input_list) 858 | | elems -> 859 | let subsqls = List.map (fun _ -> "(?, ?, NULL)") elems in 860 | let patch = String.concat ", " subsqls in 861 | let sql = 862 | String.append 863 | "INSERT INTO users (id, name, phone) VALUES " 864 | (String.append patch "") 865 | in 866 | let params_between = 867 | Array.of_list 868 | (List.concat 869 | (List.map 870 | (fun (id, name) -> 871 | [ Option.Some (Stdlib.string_of_int id); 872 | Option.Some (Ppx_mysql_runtime.identity name) ] ) 873 | elems)) 874 | in 875 | let params = Array.concat [[||]; params_between; [||]] in 876 | IO.return (Result.Ok (sql, params)) ) 877 | >>= fun (sql, params) -> 878 | let process_out_params row = 879 | let len_row = Array.length row in 880 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 0 881 | then Result.Ok () 882 | else Result.Error (`Unexpected_number_of_columns (len_row, 0)) 883 | [@@warning "-26"] 884 | in 885 | Prepared.with_stmt_cached dbh sql (fun stmt -> 886 | Prepared.execute_null stmt params >>= fun stmt_result -> 887 | (fun () -> 888 | Prepared.fetch stmt_result >>= function 889 | | Option.Some _ -> IO.return (Result.Error `Expected_none_found_one) 890 | | Option.None -> IO.return (Result.Ok ()) ) 891 | () ) 892 | 893 | let test_list2 dbh elems ~(name : string) ~(age : int) = 894 | let open IO_result in 895 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 896 | let module List = Ppx_mysql_runtime.Stdlib.List in 897 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 898 | let module String = Ppx_mysql_runtime.Stdlib.String in 899 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 900 | ( match elems with 901 | | [] -> IO.return (Result.Error `Empty_input_list) 902 | | elems -> 903 | let subsqls = List.map (fun _ -> "?") elems in 904 | let patch = String.concat ", " subsqls in 905 | let sql = 906 | String.append 907 | "SELECT id, name FROM users WHERE name = ? OR id IN (" 908 | (String.append patch ") OR age > ?") 909 | in 910 | let params_between = 911 | Array.of_list 912 | (List.concat 913 | (List.map (fun id -> [Option.Some (Stdlib.string_of_int id)]) elems)) 914 | in 915 | let params = 916 | Array.concat 917 | [ [|Option.Some (Ppx_mysql_runtime.identity name)|]; 918 | params_between; 919 | [|Option.Some (Stdlib.string_of_int age)|] ] 920 | in 921 | IO.return (Result.Ok (sql, params)) ) 922 | >>= fun (sql, params) -> 923 | let process_out_params row = 924 | let len_row = Array.length row in 925 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 926 | then 927 | let err_accum = [] in 928 | let col0, err_accum = 929 | Ppx_mysql_runtime.deserialize_non_nullable_column 930 | 0 931 | "id" 932 | Ppx_mysql_runtime.int_of_string 933 | "Ppx_mysql_runtime.int_of_string" 934 | err_accum 935 | row.(0) 936 | in 937 | let col1, err_accum = 938 | Ppx_mysql_runtime.deserialize_non_nullable_column 939 | 1 940 | "name" 941 | Ppx_mysql_runtime.string_of_string 942 | "Ppx_mysql_runtime.string_of_string" 943 | err_accum 944 | row.(1) 945 | in 946 | match col0, col1 with 947 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 948 | | _ -> Result.Error (`Column_errors err_accum) 949 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 950 | [@@warning "-26"] 951 | in 952 | Prepared.with_stmt_cached dbh sql (fun stmt -> 953 | Prepared.execute_null stmt params >>= fun stmt_result -> 954 | (fun () -> 955 | let rec loop acc = 956 | Prepared.fetch stmt_result >>= function 957 | | Option.Some row -> ( 958 | match process_out_params row with 959 | | Result.Ok row' -> loop (row' :: acc) 960 | | Result.Error _ as err -> IO.return err ) 961 | | Option.None -> IO.return (Result.Ok (List.rev acc)) 962 | in 963 | loop [] ) 964 | () ) 965 | 966 | let test_list3 dbh elems = 967 | let open IO_result in 968 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 969 | let module List = Ppx_mysql_runtime.Stdlib.List in 970 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 971 | let module String = Ppx_mysql_runtime.Stdlib.String in 972 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 973 | ( match elems with 974 | | [] -> IO.return (Result.Error `Empty_input_list) 975 | | elems -> 976 | let subsqls = List.map (fun _ -> "(?, ?, ?, ?)") elems in 977 | let patch = String.concat ", " subsqls in 978 | let sql = 979 | String.append 980 | "INSERT INTO users (id, name, real_name, age) VALUES " 981 | (String.append patch "") 982 | in 983 | let params_between = 984 | Array.of_list 985 | (List.concat 986 | (List.map 987 | (fun (id, name, age) -> 988 | [ Option.Some (Stdlib.string_of_int id); 989 | Option.Some (Ppx_mysql_runtime.identity name); 990 | Option.Some (Ppx_mysql_runtime.identity name); 991 | Option.Some (Stdlib.string_of_int age) ] ) 992 | elems)) 993 | in 994 | let params = Array.concat [[||]; params_between; [||]] in 995 | IO.return (Result.Ok (sql, params)) ) 996 | >>= fun (sql, params) -> 997 | let process_out_params row = 998 | let len_row = Array.length row in 999 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 0 1000 | then Result.Ok () 1001 | else Result.Error (`Unexpected_number_of_columns (len_row, 0)) 1002 | [@@warning "-26"] 1003 | in 1004 | Prepared.with_stmt_cached dbh sql (fun stmt -> 1005 | Prepared.execute_null stmt params >>= fun stmt_result -> 1006 | (fun () -> 1007 | Prepared.fetch stmt_result >>= function 1008 | | Option.Some _ -> IO.return (Result.Error `Expected_none_found_one) 1009 | | Option.None -> IO.return (Result.Ok ()) ) 1010 | () ) 1011 | 1012 | let test_cached0 dbh elems = 1013 | let open IO_result in 1014 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 1015 | let module List = Ppx_mysql_runtime.Stdlib.List in 1016 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 1017 | let module String = Ppx_mysql_runtime.Stdlib.String in 1018 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 1019 | ( match elems with 1020 | | [] -> IO.return (Result.Error `Empty_input_list) 1021 | | elems -> 1022 | let subsqls = List.map (fun _ -> "?") elems in 1023 | let patch = String.concat ", " subsqls in 1024 | let sql = 1025 | String.append 1026 | "SELECT id, name FROM users WHERE id IN (" 1027 | (String.append patch ")") 1028 | in 1029 | let params_between = 1030 | Array.of_list 1031 | (List.concat 1032 | (List.map (fun id -> [Option.Some (Stdlib.string_of_int id)]) elems)) 1033 | in 1034 | let params = Array.concat [[||]; params_between; [||]] in 1035 | IO.return (Result.Ok (sql, params)) ) 1036 | >>= fun (sql, params) -> 1037 | let process_out_params row = 1038 | let len_row = Array.length row in 1039 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 1040 | then 1041 | let err_accum = [] in 1042 | let col0, err_accum = 1043 | Ppx_mysql_runtime.deserialize_non_nullable_column 1044 | 0 1045 | "id" 1046 | Ppx_mysql_runtime.int_of_string 1047 | "Ppx_mysql_runtime.int_of_string" 1048 | err_accum 1049 | row.(0) 1050 | in 1051 | let col1, err_accum = 1052 | Ppx_mysql_runtime.deserialize_non_nullable_column 1053 | 1 1054 | "name" 1055 | Ppx_mysql_runtime.string_of_string 1056 | "Ppx_mysql_runtime.string_of_string" 1057 | err_accum 1058 | row.(1) 1059 | in 1060 | match col0, col1 with 1061 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 1062 | | _ -> Result.Error (`Column_errors err_accum) 1063 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 1064 | [@@warning "-26"] 1065 | in 1066 | Prepared.with_stmt_cached dbh sql (fun stmt -> 1067 | Prepared.execute_null stmt params >>= fun stmt_result -> 1068 | (fun () -> 1069 | let rec loop acc = 1070 | Prepared.fetch stmt_result >>= function 1071 | | Option.Some row -> ( 1072 | match process_out_params row with 1073 | | Result.Ok row' -> loop (row' :: acc) 1074 | | Result.Error _ as err -> IO.return err ) 1075 | | Option.None -> IO.return (Result.Ok (List.rev acc)) 1076 | in 1077 | loop [] ) 1078 | () ) 1079 | 1080 | let test_cached1 dbh elems = 1081 | let open IO_result in 1082 | let module Array = Ppx_mysql_runtime.Stdlib.Array in 1083 | let module List = Ppx_mysql_runtime.Stdlib.List in 1084 | let module Option = Ppx_mysql_runtime.Stdlib.Option in 1085 | let module String = Ppx_mysql_runtime.Stdlib.String in 1086 | let module Result = Ppx_mysql_runtime.Stdlib.Result in 1087 | ( match elems with 1088 | | [] -> IO.return (Result.Error `Empty_input_list) 1089 | | elems -> 1090 | let subsqls = List.map (fun _ -> "?") elems in 1091 | let patch = String.concat ", " subsqls in 1092 | let sql = 1093 | String.append 1094 | "SELECT id, name FROM users WHERE id IN (" 1095 | (String.append patch ")") 1096 | in 1097 | let params_between = 1098 | Array.of_list 1099 | (List.concat 1100 | (List.map (fun id -> [Option.Some (Stdlib.string_of_int id)]) elems)) 1101 | in 1102 | let params = Array.concat [[||]; params_between; [||]] in 1103 | IO.return (Result.Ok (sql, params)) ) 1104 | >>= fun (sql, params) -> 1105 | let process_out_params row = 1106 | let len_row = Array.length row in 1107 | if Ppx_mysql_runtime.Stdlib.( = ) len_row 2 1108 | then 1109 | let err_accum = [] in 1110 | let col0, err_accum = 1111 | Ppx_mysql_runtime.deserialize_non_nullable_column 1112 | 0 1113 | "id" 1114 | Ppx_mysql_runtime.int_of_string 1115 | "Ppx_mysql_runtime.int_of_string" 1116 | err_accum 1117 | row.(0) 1118 | in 1119 | let col1, err_accum = 1120 | Ppx_mysql_runtime.deserialize_non_nullable_column 1121 | 1 1122 | "name" 1123 | Ppx_mysql_runtime.string_of_string 1124 | "Ppx_mysql_runtime.string_of_string" 1125 | err_accum 1126 | row.(1) 1127 | in 1128 | match col0, col1 with 1129 | | Option.Some v0, Option.Some v1 -> Result.Ok (v0, v1) 1130 | | _ -> Result.Error (`Column_errors err_accum) 1131 | else Result.Error (`Unexpected_number_of_columns (len_row, 2)) 1132 | [@@warning "-26"] 1133 | in 1134 | Prepared.with_stmt_uncached dbh sql (fun stmt -> 1135 | Prepared.execute_null stmt params >>= fun stmt_result -> 1136 | (fun () -> 1137 | let rec loop acc = 1138 | Prepared.fetch stmt_result >>= function 1139 | | Option.Some row -> ( 1140 | match process_out_params row with 1141 | | Result.Ok row' -> loop (row' :: acc) 1142 | | Result.Error _ as err -> IO.return err ) 1143 | | Option.None -> IO.return (Result.Ok (List.rev acc)) 1144 | in 1145 | loop [] ) 1146 | () ) 1147 | -------------------------------------------------------------------------------- /tests/test_ppx/test_ppx.ml: -------------------------------------------------------------------------------- 1 | let test_no_params = [%mysql select_one "SELECT TRUE"] 2 | 3 | let test_single_output_params = 4 | [%mysql select_one "SELECT @string{name} FROM users WHERE id = 1"] 5 | 6 | let test_pair_output_params = 7 | [%mysql select_one "SELECT @int{id}, @string{name} FROM users WHERE id = 1"] 8 | 9 | let test_one_input_params = 10 | [%mysql select_one "SELECT @string{name} FROM users WHERE id = %int{id}"] 11 | 12 | let test_two_input_pair_output_params = 13 | [%mysql 14 | select_one 15 | "SELECT @int{id}, @string{name} FROM users WHERE id = %int{id} OR name = \ 16 | %string{name}"] 17 | 18 | let test_select_all = [%mysql select_all "SELECT @int{id}, @string{name} FROM users"] 19 | 20 | let test_repeated_input_params = 21 | [%mysql 22 | select_all 23 | "SELECT @int{id}, @string{name} FROM users WHERE id <> %int{id} AND id <> %int{id}"] 24 | 25 | let test_select_opt = 26 | [%mysql select_opt "SELECT @int{id}, @string{name} FROM users WHERE id = %int{id}"] 27 | 28 | let test_execute = [%mysql execute "DELETE FROM users WHERE id = %int{id}"] 29 | 30 | let test_int = 31 | [%mysql 32 | select_one "SELECT @int{a}, @int?{b} FROM users where a = %int{a} OR b = %int?{b}"] 33 | 34 | let test_int32 = 35 | [%mysql 36 | select_one 37 | "SELECT @int32{a}, @int32?{b} FROM users where a = %int32{a} OR b = %int32?{b}"] 38 | 39 | let test_int64 = 40 | [%mysql 41 | select_one 42 | "SELECT @int64{a}, @int64?{b} FROM users where a = %int64{a} OR b = %int64?{b}"] 43 | 44 | let test_bool = 45 | [%mysql 46 | select_one 47 | "SELECT @bool{a}, @bool?{b} FROM users where a = %bool{a} OR b = %bool?{b}"] 48 | 49 | let test_string = 50 | [%mysql 51 | select_one 52 | "SELECT @string{a}, @string?{b} FROM users where a = %string{a} OR b = %string?{b}"] 53 | 54 | let test_custom_type = 55 | [%mysql 56 | select_one "SELECT @Id{a}, @Phone?{b} FROM users where a = %Id{a} OR b = %Phone?{b}"] 57 | 58 | let test_list0 = 59 | [%mysql 60 | select_all "SELECT @int{id}, @string{name} FROM users WHERE id IN (%list{%int{id}})"] 61 | 62 | let test_list1 = 63 | [%mysql 64 | execute 65 | "INSERT INTO users (id, name, phone) VALUES %list{(%int{id}, %string{name}, NULL)}"] 66 | 67 | let test_list2 = 68 | [%mysql 69 | select_all 70 | "SELECT @int{id}, @string{name} FROM users WHERE name = %string{name} OR id IN \ 71 | (%list{%int{id}}) OR age > %int{age}"] 72 | 73 | let test_list3 = 74 | [%mysql 75 | execute 76 | "INSERT INTO users (id, name, real_name, age) VALUES %list{(%int{id}, \ 77 | %string{name}, %string{name}, %int{age})}"] 78 | 79 | let test_cached0 = 80 | [%mysql 81 | select_all ~cached:true "SELECT @int{id}, @string{name} FROM users WHERE id IN (%list{%int{id}})"] 82 | 83 | let test_cached1 = 84 | [%mysql 85 | select_all ~cached:false "SELECT @int{id}, @string{name} FROM users WHERE id IN (%list{%int{id}})"] 86 | -------------------------------------------------------------------------------- /tests/test_query/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_query) 3 | (libraries alcotest ppx_mysql) 4 | (preprocess (pps ppx_deriving.show ppx_deriving.eq))) 5 | -------------------------------------------------------------------------------- /tests/test_query/test_query.ml: -------------------------------------------------------------------------------- 1 | open Ppx_mysql 2 | 3 | (** {1 Type definitions} *) 4 | 5 | type param = Query.param = { 6 | typ : string option * string; 7 | opt : bool; 8 | name : string; 9 | of_string : string * string; 10 | to_string : string * string 11 | } 12 | [@@deriving eq, show] 13 | 14 | type list_params = Query.list_params = { 15 | subsql : string; 16 | string_index : int; 17 | param_index : int; 18 | params : param list 19 | } 20 | [@@deriving eq, show] 21 | 22 | type parsed_query = Query.parsed_query = { 23 | sql : string; 24 | in_params : param list; 25 | out_params : param list; 26 | list_params : list_params option 27 | } 28 | [@@deriving eq, show] 29 | 30 | type parse_error = 31 | [ `Bad_identifier of string 32 | | `Unknown_type_spec of string 33 | | `Empty_list_params 34 | | `Multiple_lists_not_supported 35 | | `Nested_list 36 | | `Optional_list 37 | | `Out_params_in_list 38 | | `Unterminated_list 39 | | `Unterminated_string 40 | | `Unterminated_bracket 41 | | `Escape_at_end ] 42 | [@@deriving eq, show] 43 | 44 | type conflicting_spec = [`Conflicting_spec of string] [@@deriving eq, show] 45 | 46 | (** {1 TESTABLE modules} *) 47 | 48 | let param_mod = Alcotest.testable pp_param equal_param 49 | 50 | let parsed_query_mod = Alcotest.testable pp_parsed_query equal_parsed_query 51 | 52 | let parse_error_mod = Alcotest.testable pp_parse_error equal_parse_error 53 | 54 | let conflicting_spec_mod = Alcotest.testable pp_conflicting_spec equal_conflicting_spec 55 | 56 | (** {1 Functions and values for {!test_parse_query}} *) 57 | 58 | let query_0 = "SELECT true" 59 | 60 | let parsed_query_0 = 61 | {sql = "SELECT true"; in_params = []; out_params = []; list_params = None} 62 | 63 | let query_out1 = "SELECT @int64{id} FROM users" 64 | 65 | let parsed_query_out1 = 66 | { sql = "SELECT id FROM users"; 67 | in_params = []; 68 | out_params = 69 | [ { typ = None, "int64"; 70 | opt = false; 71 | name = "id"; 72 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 73 | to_string = "Int64", "to_string" } ]; 74 | list_params = None } 75 | 76 | let query_out2 = "SELECT @int64{id}, @string{name} FROM users" 77 | 78 | let parsed_query_out2 = 79 | { sql = "SELECT id, name FROM users"; 80 | in_params = []; 81 | out_params = 82 | [ { typ = None, "int64"; 83 | opt = false; 84 | name = "id"; 85 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 86 | to_string = "Int64", "to_string" }; 87 | { typ = None, "string"; 88 | opt = false; 89 | name = "name"; 90 | of_string = "Ppx_mysql_runtime", "string_of_string"; 91 | to_string = "Ppx_mysql_runtime", "identity" } ]; 92 | list_params = None } 93 | 94 | let query_out3 = "SELECT @int64{id}, @string{name}, @string?{phone} FROM users" 95 | 96 | let parsed_query_out3 = 97 | { sql = "SELECT id, name, phone FROM users"; 98 | in_params = []; 99 | out_params = 100 | [ { typ = None, "int64"; 101 | opt = false; 102 | name = "id"; 103 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 104 | to_string = "Int64", "to_string" }; 105 | { typ = None, "string"; 106 | opt = false; 107 | name = "name"; 108 | of_string = "Ppx_mysql_runtime", "string_of_string"; 109 | to_string = "Ppx_mysql_runtime", "identity" }; 110 | { typ = None, "string"; 111 | opt = true; 112 | name = "phone"; 113 | of_string = "Ppx_mysql_runtime", "string_of_string"; 114 | to_string = "Ppx_mysql_runtime", "identity" } ]; 115 | list_params = None } 116 | 117 | let query_out4 = "SELECT @Id{id}, @Name{name}, @Phone?{phone} FROM users" 118 | 119 | let parsed_query_out4 = 120 | { sql = "SELECT id, name, phone FROM users"; 121 | in_params = []; 122 | out_params = 123 | [ { typ = Some "Id", "t"; 124 | opt = false; 125 | name = "id"; 126 | of_string = "Id", "of_mysql"; 127 | to_string = "Id", "to_mysql" }; 128 | { typ = Some "Name", "t"; 129 | opt = false; 130 | name = "name"; 131 | of_string = "Name", "of_mysql"; 132 | to_string = "Name", "to_mysql" }; 133 | { typ = Some "Phone", "t"; 134 | opt = true; 135 | name = "phone"; 136 | of_string = "Phone", "of_mysql"; 137 | to_string = "Phone", "to_mysql" } ]; 138 | list_params = None } 139 | 140 | let query_in1 = "INSERT INTO users (id) VALUES (%int64{id})" 141 | 142 | let parsed_query_in1 = 143 | { sql = "INSERT INTO users (id) VALUES (?)"; 144 | in_params = 145 | [ { typ = None, "int64"; 146 | opt = false; 147 | name = "id"; 148 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 149 | to_string = "Int64", "to_string" } ]; 150 | out_params = []; 151 | list_params = None } 152 | 153 | let query_in2 = "INSERT INTO users (id, name) VALUES (%int64{id}, %string{name})" 154 | 155 | let parsed_query_in2 = 156 | { sql = "INSERT INTO users (id, name) VALUES (?, ?)"; 157 | in_params = 158 | [ { typ = None, "int64"; 159 | opt = false; 160 | name = "id"; 161 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 162 | to_string = "Int64", "to_string" }; 163 | { typ = None, "string"; 164 | opt = false; 165 | name = "name"; 166 | of_string = "Ppx_mysql_runtime", "string_of_string"; 167 | to_string = "Ppx_mysql_runtime", "identity" } ]; 168 | out_params = []; 169 | list_params = None } 170 | 171 | let query_in3 = 172 | "INSERT INTO users (id, name, phone) VALUES (%int64{id}, %string{name}, \ 173 | %string?{phone})" 174 | 175 | let parsed_query_in3 = 176 | { sql = "INSERT INTO users (id, name, phone) VALUES (?, ?, ?)"; 177 | in_params = 178 | [ { typ = None, "int64"; 179 | opt = false; 180 | name = "id"; 181 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 182 | to_string = "Int64", "to_string" }; 183 | { typ = None, "string"; 184 | opt = false; 185 | name = "name"; 186 | of_string = "Ppx_mysql_runtime", "string_of_string"; 187 | to_string = "Ppx_mysql_runtime", "identity" }; 188 | { typ = None, "string"; 189 | opt = true; 190 | name = "phone"; 191 | of_string = "Ppx_mysql_runtime", "string_of_string"; 192 | to_string = "Ppx_mysql_runtime", "identity" } ]; 193 | out_params = []; 194 | list_params = None } 195 | 196 | let query_in4 = 197 | "INSERT INTO users (id, name, phone) VALUES (%Id{id}, %Name{name}, %Phone?{phone})" 198 | 199 | let parsed_query_in4 = 200 | { sql = "INSERT INTO users (id, name, phone) VALUES (?, ?, ?)"; 201 | in_params = 202 | [ { typ = Some "Id", "t"; 203 | opt = false; 204 | name = "id"; 205 | of_string = "Id", "of_mysql"; 206 | to_string = "Id", "to_mysql" }; 207 | { typ = Some "Name", "t"; 208 | opt = false; 209 | name = "name"; 210 | of_string = "Name", "of_mysql"; 211 | to_string = "Name", "to_mysql" }; 212 | { typ = Some "Phone", "t"; 213 | opt = true; 214 | name = "phone"; 215 | of_string = "Phone", "of_mysql"; 216 | to_string = "Phone", "to_mysql" } ]; 217 | out_params = []; 218 | list_params = None } 219 | 220 | let query_inout = 221 | "SELECT @int64{id}, @string{name}, @string?{phone} FROM users WHERE id = %int64{id} \ 222 | OR name = %string{name} OR PHONE = %string?{phone}" 223 | 224 | let parsed_query_inout = 225 | { sql = "SELECT id, name, phone FROM users WHERE id = ? OR name = ? OR PHONE = ?"; 226 | in_params = 227 | [ { typ = None, "int64"; 228 | opt = false; 229 | name = "id"; 230 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 231 | to_string = "Int64", "to_string" }; 232 | { typ = None, "string"; 233 | opt = false; 234 | name = "name"; 235 | of_string = "Ppx_mysql_runtime", "string_of_string"; 236 | to_string = "Ppx_mysql_runtime", "identity" }; 237 | { typ = None, "string"; 238 | opt = true; 239 | name = "phone"; 240 | of_string = "Ppx_mysql_runtime", "string_of_string"; 241 | to_string = "Ppx_mysql_runtime", "identity" } ]; 242 | out_params = 243 | [ { typ = None, "int64"; 244 | opt = false; 245 | name = "id"; 246 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 247 | to_string = "Int64", "to_string" }; 248 | { typ = None, "string"; 249 | opt = false; 250 | name = "name"; 251 | of_string = "Ppx_mysql_runtime", "string_of_string"; 252 | to_string = "Ppx_mysql_runtime", "identity" }; 253 | { typ = None, "string"; 254 | opt = true; 255 | name = "phone"; 256 | of_string = "Ppx_mysql_runtime", "string_of_string"; 257 | to_string = "Ppx_mysql_runtime", "identity" } ]; 258 | list_params = None } 259 | 260 | let query_quoted0 = 261 | "SELECT @int64{id}, @string{name} FROM users WHERE id = %int64{id} OR NAME = 'Hello \ 262 | @int64{name} world'" 263 | 264 | let parsed_query_quoted0 = 265 | { sql = "SELECT id, name FROM users WHERE id = ? OR NAME = 'Hello @int64{name} world'"; 266 | in_params = 267 | [ { typ = None, "int64"; 268 | opt = false; 269 | name = "id"; 270 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 271 | to_string = "Int64", "to_string" } ]; 272 | out_params = 273 | [ { typ = None, "int64"; 274 | opt = false; 275 | name = "id"; 276 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 277 | to_string = "Int64", "to_string" }; 278 | { typ = None, "string"; 279 | opt = false; 280 | name = "name"; 281 | of_string = "Ppx_mysql_runtime", "string_of_string"; 282 | to_string = "Ppx_mysql_runtime", "identity" } ]; 283 | list_params = None } 284 | 285 | let query_quoted1 = 286 | "SELECT @int64{id}, @string{name} FROM users WHERE id = %int64{id} OR NAME = \"Hello \ 287 | @int64{name} world\"" 288 | 289 | let parsed_query_quoted1 = 290 | { sql = "SELECT id, name FROM users WHERE id = ? OR NAME = \"Hello @int64{name} world\""; 291 | in_params = 292 | [ { typ = None, "int64"; 293 | opt = false; 294 | name = "id"; 295 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 296 | to_string = "Int64", "to_string" } ]; 297 | out_params = 298 | [ { typ = None, "int64"; 299 | opt = false; 300 | name = "id"; 301 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 302 | to_string = "Int64", "to_string" }; 303 | { typ = None, "string"; 304 | opt = false; 305 | name = "name"; 306 | of_string = "Ppx_mysql_runtime", "string_of_string"; 307 | to_string = "Ppx_mysql_runtime", "identity" } ]; 308 | list_params = None } 309 | 310 | let query_quoted2 = 311 | "SELECT @int64{id}, @string{name} FROM users WHERE id = %int64{id} OR NAME = 'Hello \ 312 | ''@int64{name}'' world'" 313 | 314 | let parsed_query_quoted2 = 315 | { sql = 316 | "SELECT id, name FROM users WHERE id = ? OR NAME = 'Hello ''@int64{name}'' world'"; 317 | in_params = 318 | [ { typ = None, "int64"; 319 | opt = false; 320 | name = "id"; 321 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 322 | to_string = "Int64", "to_string" } ]; 323 | out_params = 324 | [ { typ = None, "int64"; 325 | opt = false; 326 | name = "id"; 327 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 328 | to_string = "Int64", "to_string" }; 329 | { typ = None, "string"; 330 | opt = false; 331 | name = "name"; 332 | of_string = "Ppx_mysql_runtime", "string_of_string"; 333 | to_string = "Ppx_mysql_runtime", "identity" } ]; 334 | list_params = None } 335 | 336 | let query_quoted3 = 337 | "SELECT @int64{id}, @string{name} FROM users WHERE id = %int64{id} OR NAME = \"Hello \ 338 | '@int64{name}' world\"" 339 | 340 | let parsed_query_quoted3 = 341 | { sql = 342 | "SELECT id, name FROM users WHERE id = ? OR NAME = \"Hello '@int64{name}' world\""; 343 | in_params = 344 | [ { typ = None, "int64"; 345 | opt = false; 346 | name = "id"; 347 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 348 | to_string = "Int64", "to_string" } ]; 349 | out_params = 350 | [ { typ = None, "int64"; 351 | opt = false; 352 | name = "id"; 353 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 354 | to_string = "Int64", "to_string" }; 355 | { typ = None, "string"; 356 | opt = false; 357 | name = "name"; 358 | of_string = "Ppx_mysql_runtime", "string_of_string"; 359 | to_string = "Ppx_mysql_runtime", "identity" } ]; 360 | list_params = None } 361 | 362 | let query_list0 = 363 | "SELECT @int{COUNT(*)} FROM users WHERE age > %int{age} AND id IN (%list{%int64{id}})" 364 | 365 | let parsed_query_list0 = 366 | { sql = "SELECT COUNT(*) FROM users WHERE age > ? AND id IN ()"; 367 | in_params = 368 | [ { typ = None, "int"; 369 | opt = false; 370 | name = "age"; 371 | of_string = "Ppx_mysql_runtime", "int_of_string"; 372 | to_string = "Stdlib", "string_of_int" } ]; 373 | out_params = 374 | [ { typ = None, "int"; 375 | opt = false; 376 | name = "COUNT(*)"; 377 | of_string = "Ppx_mysql_runtime", "int_of_string"; 378 | to_string = "Stdlib", "string_of_int" } ]; 379 | list_params = 380 | Some 381 | { subsql = "?"; 382 | string_index = 52; 383 | param_index = 1; 384 | params = 385 | [ { typ = None, "int64"; 386 | opt = false; 387 | name = "id"; 388 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 389 | to_string = "Int64", "to_string" } ] } } 390 | 391 | let query_list1 = 392 | "INSERT INTO users (id, name, phone) VALUES %list{(%int{id}, %string{name}, \ 393 | %string?{phone})}" 394 | 395 | let parsed_query_list1 = 396 | { sql = "INSERT INTO users (id, name, phone) VALUES "; 397 | in_params = []; 398 | out_params = []; 399 | list_params = 400 | Some 401 | { subsql = "(?, ?, ?)"; 402 | string_index = 43; 403 | param_index = 0; 404 | params = 405 | [ { typ = None, "int"; 406 | opt = false; 407 | name = "id"; 408 | of_string = "Ppx_mysql_runtime", "int_of_string"; 409 | to_string = "Stdlib", "string_of_int" }; 410 | { typ = None, "string"; 411 | opt = false; 412 | name = "name"; 413 | of_string = "Ppx_mysql_runtime", "string_of_string"; 414 | to_string = "Ppx_mysql_runtime", "identity" }; 415 | { typ = None, "string"; 416 | opt = true; 417 | name = "phone"; 418 | of_string = "Ppx_mysql_runtime", "string_of_string"; 419 | to_string = "Ppx_mysql_runtime", "identity" } ] } } 420 | 421 | let query_list2 = 422 | "INSERT INTO users (id, name, phone) VALUES %list{(%int{id}, %string{name}, NULL)}" 423 | 424 | let parsed_query_list2 = 425 | { sql = "INSERT INTO users (id, name, phone) VALUES "; 426 | in_params = []; 427 | out_params = []; 428 | list_params = 429 | Some 430 | { subsql = "(?, ?, NULL)"; 431 | string_index = 43; 432 | param_index = 0; 433 | params = 434 | [ { typ = None, "int"; 435 | opt = false; 436 | name = "id"; 437 | of_string = "Ppx_mysql_runtime", "int_of_string"; 438 | to_string = "Stdlib", "string_of_int" }; 439 | { typ = None, "string"; 440 | opt = false; 441 | name = "name"; 442 | of_string = "Ppx_mysql_runtime", "string_of_string"; 443 | to_string = "Ppx_mysql_runtime", "identity" } ] } } 444 | 445 | let query_list3 = 446 | "SELECT @int{COUNT(*)} FROM users WHERE age > %int{age} OR id IN (%list{%int64{id}}) \ 447 | OR name = %string{name}" 448 | 449 | let parsed_query_list3 = 450 | { sql = "SELECT COUNT(*) FROM users WHERE age > ? OR id IN () OR name = ?"; 451 | in_params = 452 | [ { typ = None, "int"; 453 | opt = false; 454 | name = "age"; 455 | of_string = "Ppx_mysql_runtime", "int_of_string"; 456 | to_string = "Stdlib", "string_of_int" }; 457 | { typ = None, "string"; 458 | opt = false; 459 | name = "name"; 460 | of_string = "Ppx_mysql_runtime", "string_of_string"; 461 | to_string = "Ppx_mysql_runtime", "identity" } ]; 462 | out_params = 463 | [ { typ = None, "int"; 464 | opt = false; 465 | name = "COUNT(*)"; 466 | of_string = "Ppx_mysql_runtime", "int_of_string"; 467 | to_string = "Stdlib", "string_of_int" } ]; 468 | list_params = 469 | Some 470 | { subsql = "?"; 471 | string_index = 51; 472 | param_index = 1; 473 | params = 474 | [ { typ = None, "int64"; 475 | opt = false; 476 | name = "id"; 477 | of_string = "Ppx_mysql_runtime", "int64_of_string"; 478 | to_string = "Int64", "to_string" } ] } } 479 | 480 | let query_bad0 = "SELECT true FROM users WHERE id = %int{ID}" 481 | 482 | let error_bad0 = `Bad_identifier "ID" 483 | 484 | let query_bad1 = "SELECT @foo{id} FROM users" 485 | 486 | let error_bad1 = `Unknown_type_spec "foo" 487 | 488 | let query_bad2 = "SELECT id, name FROM users WHERE id = %foo{id}" 489 | 490 | let error_bad2 = `Unknown_type_spec "foo" 491 | 492 | let query_bad3 = "SELECT 'hello" 493 | 494 | let error_bad3 = `Unterminated_string 495 | 496 | let query_bad4 = "SELECT \"hello" 497 | 498 | let error_bad4 = `Unterminated_string 499 | 500 | let query_bad5 = "SELECT true\\" 501 | 502 | let error_bad5 = `Escape_at_end 503 | 504 | let query_bad6 = "SELECT @int{true FROM users" 505 | 506 | let error_bad6 = `Unterminated_bracket 507 | 508 | let query_bad7 = "SELECT true FROM users WHERE %int{id" 509 | 510 | let error_bad7 = `Unterminated_bracket 511 | 512 | let query_list_bad0 = "SELECT true FROM users WHERE id IN (%list?{%int{id}})" 513 | 514 | let error_list_bad0 = `Optional_list 515 | 516 | let query_list_bad1 = "SELECT true FROM users WHERE id IN (%list{%list{%int{id}}})" 517 | 518 | let error_list_bad1 = `Nested_list 519 | 520 | let query_list_bad2 = "SELECT true FROM users WHERE id IN (%list{@int{id}}})" 521 | 522 | let error_list_bad2 = `Out_params_in_list 523 | 524 | let query_list_bad3 = "SELECT true FROM users WHERE id IN (%list{%int{id})" 525 | 526 | let error_list_bad3 = `Unterminated_list 527 | 528 | let query_list_bad4 = "SELECT @list{*} FROM users" 529 | 530 | let error_list_bad4 = `Unknown_type_spec "list" 531 | 532 | let query_list_bad5 = "SELECT * FROM users WHERE id IN (%list{})" 533 | 534 | let error_list_bad5 = `Empty_list_params 535 | 536 | let query_list_bad6 = 537 | "SELECT * FROM users WHERE id IN (%list{%int{id}}) AND name IN (%list{%string{name}})" 538 | 539 | let error_list_bad6 = `Multiple_lists_not_supported 540 | 541 | let test_parse_query () = 542 | let run desc query expected = 543 | Alcotest.( 544 | check (result parsed_query_mod parse_error_mod) desc expected (Query.parse query)) 545 | in 546 | run "query_0" query_0 (Ok parsed_query_0); 547 | run "query_out1" query_out1 (Ok parsed_query_out1); 548 | run "query_out2" query_out2 (Ok parsed_query_out2); 549 | run "query_out3" query_out3 (Ok parsed_query_out3); 550 | run "query_out4" query_out4 (Ok parsed_query_out4); 551 | run "query_in1" query_in1 (Ok parsed_query_in1); 552 | run "query_in2" query_in2 (Ok parsed_query_in2); 553 | run "query_in3" query_in3 (Ok parsed_query_in3); 554 | run "query_in4" query_in4 (Ok parsed_query_in4); 555 | run "query_inout" query_inout (Ok parsed_query_inout); 556 | run "query_quoted0" query_quoted0 (Ok parsed_query_quoted0); 557 | run "query_quoted1" query_quoted1 (Ok parsed_query_quoted1); 558 | run "query_quoted2" query_quoted2 (Ok parsed_query_quoted2); 559 | run "query_quoted3" query_quoted3 (Ok parsed_query_quoted3); 560 | run "query_list0" query_list0 (Ok parsed_query_list0); 561 | run "query_list1" query_list1 (Ok parsed_query_list1); 562 | run "query_list2" query_list2 (Ok parsed_query_list2); 563 | run "query_list3" query_list3 (Ok parsed_query_list3); 564 | run "query_bad0" query_bad0 (Error error_bad0); 565 | run "query_bad1" query_bad1 (Error error_bad1); 566 | run "query_bad2" query_bad2 (Error error_bad2); 567 | run "query_bad3" query_bad3 (Error error_bad3); 568 | run "query_bad4" query_bad4 (Error error_bad4); 569 | run "query_bad5" query_bad5 (Error error_bad5); 570 | run "query_bad6" query_bad6 (Error error_bad6); 571 | run "query_bad7" query_bad7 (Error error_bad7); 572 | run "query_list_bad0" query_list_bad0 (Error error_list_bad0); 573 | run "query_list_bad1" query_list_bad1 (Error error_list_bad1); 574 | run "query_list_bad2" query_list_bad2 (Error error_list_bad2); 575 | run "query_list_bad3" query_list_bad3 (Error error_list_bad3); 576 | run "query_list_bad4" query_list_bad4 (Error error_list_bad4); 577 | run "query_list_bad5" query_list_bad5 (Error error_list_bad5); 578 | run "query_list_bad6" query_list_bad6 (Error error_list_bad6) 579 | 580 | (** {1 Functions and values for {!test_remove_duplicates}} *) 581 | 582 | let param_foo32t = 583 | { typ = None, "int32"; 584 | opt = true; 585 | name = "foo"; 586 | of_string = "Int32", "of_string"; 587 | to_string = "Int32", "to_string" } 588 | 589 | let param_foo64t = 590 | { typ = None, "int64"; 591 | opt = true; 592 | name = "foo"; 593 | of_string = "Int64", "of_string"; 594 | to_string = "Int64", "to_string" } 595 | 596 | let param_foo32f = 597 | { typ = None, "int32"; 598 | opt = false; 599 | name = "foo"; 600 | of_string = "Int32", "of_string"; 601 | to_string = "Int32", "to_string" } 602 | 603 | let param_bar32t = 604 | { typ = None, "int32"; 605 | opt = true; 606 | name = "bar"; 607 | of_string = "Int32", "of_string"; 608 | to_string = "Int32", "to_string" } 609 | 610 | let test_remove_duplicates () = 611 | let run desc params expected = 612 | Alcotest.( 613 | check 614 | (result (list param_mod) conflicting_spec_mod) 615 | desc 616 | expected 617 | (Query.remove_duplicates params)) 618 | in 619 | run "Duplicate 'foo'" [param_foo32t; param_foo32t] (Ok [param_foo32t]); 620 | run 621 | "Duplicate 'foo' and 'bar'" 622 | [param_foo32t; param_bar32t; param_foo32t; param_bar32t] 623 | (Ok [param_foo32t; param_bar32t]); 624 | run 625 | "Redefined 'foo' with different type" 626 | [param_foo32t; param_foo64t] 627 | (Error (`Conflicting_spec "foo")); 628 | run 629 | "Redefined 'foo' with different opt" 630 | [param_foo32t; param_foo32f] 631 | (Error (`Conflicting_spec "foo")) 632 | 633 | (** {1 Main} *) 634 | 635 | let testset = 636 | [ "parse_query", `Quick, test_parse_query; 637 | "remove_duplicates", `Quick, test_remove_duplicates ] 638 | 639 | let () = Alcotest.run "Query module" ["Query", testset] 640 | --------------------------------------------------------------------------------