├── .github ├── CODEOWNERS └── workflows │ └── workflow.yml ├── .gitignore ├── .merlin ├── CHANGES.md ├── LICENSE ├── README.md ├── bindings ├── dune └── ffi_bindings.ml ├── discover.ml ├── dune ├── dune-project ├── dune-workspace ├── examples ├── async │ ├── .merlin │ ├── dune │ └── nonblocking_async_example.ml ├── blocking │ ├── blocking_example.ml │ └── dune ├── lwt │ ├── .merlin │ ├── dune │ └── nonblocking_lwt_example.ml └── select │ ├── dune │ └── nonblocking_select_example.ml ├── lib ├── bind.ml ├── binding_wrappers.ml ├── blocking.ml ├── common.ml ├── dune ├── field.ml ├── mariadb.ml ├── mariadb.mli ├── nonblocking.ml ├── row.ml ├── time.ml ├── util.ml └── wait_status.ml ├── mariadb.opam └── tests ├── README.md ├── blocking ├── blocking_testsuite.ml └── dune ├── nonblocking-async ├── dune └── nonblocking_testsuite_async.ml ├── nonblocking-lwt ├── dune └── nonblocking_testsuite_lwt.ml └── nonblocking ├── dune └── nonblocking_testsuite.ml /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @paurkedal 2 | -------------------------------------------------------------------------------- /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: Build, test, and lint 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | permissions: read-all 8 | 9 | jobs: 10 | build-and-test: 11 | 12 | services: 13 | mariadb: 14 | image: mariadb:latest 15 | env: 16 | MARIADB_USER: testuser 17 | MARIADB_PASSWORD: testpw 18 | MARIADB_DATABASE: testdb 19 | MARIADB_RANDOM_ROOT_PASSWORD: 1 20 | 21 | strategy: 22 | fail-fast: false 23 | matrix: 24 | os: 25 | # The main aim is to target different kinds of MariaDB client 26 | # libraries; see the OPAM specification of conf-mariadb. 27 | - "alpine" # MariaDB C connector 28 | - "ubuntu" # libmariadb 29 | # "ubuntu-18.04" has libmariadbclient but has too old libc for node.js 30 | ocaml-compiler: 31 | - "5.3" 32 | - "4.14" 33 | - "4.07" 34 | 35 | runs-on: ubuntu-latest 36 | container: 37 | image: "ocaml/opam:${{ matrix.os }}-ocaml-${{ matrix.ocaml-compiler }}" 38 | # Currently needed for the GitHub Actions, use sudo for other steps. 39 | options: "--user root" 40 | 41 | steps: 42 | - name: Check out source code 43 | uses: actions/checkout@v4 44 | 45 | - name: Install system dependencies (alpine) 46 | if: "${{ matrix.os == 'alpine' }}" 47 | run: "apk add --no-cache linux-headers mariadb-connector-c-dev" 48 | 49 | - name: Install system dependencies (ubuntu) 50 | if: "${{ matrix.os == 'ubuntu' }}" 51 | run: "apt-get update && apt-get install -y pkg-config libmariadb-dev libzstd-dev" 52 | 53 | - name: Restore cached dependencies 54 | uses: actions/cache@v3 55 | with: 56 | # This gives the precise OCaml version via .opam/config, but only the 57 | # approximate OS version via the matrix. In particular we cannot use 58 | # /etc/*-release, since hashFiles only works within GITHUB_WORKSPACE. 59 | key: "${{ matrix.os }}-${{ hashFiles('*.opam', '.opam/config') }}" 60 | path: /home/opam/.opam 61 | 62 | - name: Give the opam user access to the workspace 63 | run: "chown -Rh opam: ." 64 | 65 | - name: Install dependencies 66 | run: "sudo -u opam opam install -y --deps-only -t ." 67 | if: "${{ matrix.os == 'ubuntu' && matrix.ocaml-compiler == '4.14' }}" 68 | 69 | - name: Install minimal dependencies 70 | run: | 71 | sudo -u opam opam install -y --deps-only . 72 | sudo -u opam opam install -y lwt 73 | if: "${{ matrix.os != 'ubuntu' || matrix.ocaml-compiler != '4.14' }}" 74 | 75 | - name: Build 76 | run: "sudo -u opam opam exec -- dune build @install @runtest" 77 | # Skipping @check, since it would force compilation of (optional) 78 | # targets. 79 | 80 | - name: Run tests 81 | run: "sudo -u opam --preserve-env=OCAML_MARIADB_HOST,OCAML_MARIADB_PORT,OCAML_MARIADB_USER,OCAML_MARIADB_PASS,OCAML_MARIADB_DB,OCAML_MARIADB_QUERY opam exec -- dune runtest" 82 | env: 83 | OCAML_MARIADB_HOST: mariadb 84 | OCAML_MARIADB_PORT: 3306 85 | OCAML_MARIADB_USER: testuser 86 | OCAML_MARIADB_PASS: testpw 87 | OCAML_MARIADB_DB: testdb 88 | 89 | # lint-opam: 90 | # runs-on: ubuntu-latest 91 | # steps: 92 | # - name: Check out source code 93 | # uses: actions/checkout@v4 94 | # 95 | # - name: Set up OCaml 96 | # uses: ocaml/setup-ocaml@v3 97 | # with: 98 | # ocaml-compiler: 5 99 | # 100 | # - name: Lint OPAM package descriptions 101 | # uses: ocaml/setup-ocaml/lint-opam@v3 102 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /_build/ 2 | *.swp 3 | _opam 4 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S lib 2 | S bindings 3 | S stubgen 4 | B _build/lib 5 | B _build/bindings 6 | B _build/stubgen 7 | B +threads 8 | PKG ctypes 9 | PKG unix 10 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 1.3.0 - 2025-05-08 2 | 3 | - The `mariadb_config` and `mysql_config` scripts are now used, if 4 | available, to discover MariaDB client library (#65 by Albert Peschar). 5 | - Added server-side properties `get_server_info`, `get_server_version`, 6 | `get_host_info` and `get_proto_info` (#62 by Petter A. Urkedal). 7 | - Avoid calling `mysql_stmt_free_result` if there is no result set, since 8 | this is not allowed by recent versions of the client library (by Petter 9 | A. Urkedal, fixes #64). 10 | - Avoid possibly blocking calls to `mysql_free_result` in the nonblocking 11 | implementation. This was only an issue if a previous result set had not 12 | been consumed (#68 by Petter A. Urkedal, fixes #67). 13 | - Fix memory leak in non-blocking test suite (Petter A. Urkedal, fixes 14 | #29). 15 | 16 | ## 1.2.0 - 2024-11-28 17 | 18 | - Added `Stmt.start_txn` (#59 by Corentin Leruth). 19 | - Added `Res.insert_id` as binding for `mysql_stmt_insert_id` (#58 by 20 | Corentin Leruth). 21 | - Updated to support recent OCaml versions (#45 by @kit-ty-kate). 22 | - Fixed too-early retrieval of statement metadata (#41 by Albert Peschar). 23 | - Fixed decoding bug for the integer type (#54 by Raman Varabets, tested 24 | by #61 by Corentin Leruth). 25 | - Fixed a memory leaks related to result metadata (#39 by Albert Peschar). 26 | - The build system is now dune and dune-configurator (#52 by Petter A. 27 | Urkedal) and some of the examples have been converted to a test suite 28 | (#60 by Petter A. Urkedal). 29 | - The project has been transferred to ocaml-community with Petter A. 30 | Urkedal as the new maintainer. 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Permission is hereby granted, free of charge, to any person obtaining a copy 2 | of this software and associated documentation files (the "Software"), to 3 | deal in the Software without restriction, including without limitation the 4 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 5 | sell copies of the Software, and to permit persons to whom the Software is 6 | furnished to do so, subject to the following conditions: 7 | 8 | The above copyright notice and this permission notice (including the next 9 | paragraph) shall be included in all copies or substantial portions of the 10 | Software. 11 | 12 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 13 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 14 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 15 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 16 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 17 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 18 | IN THE SOFTWARE. 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OCaml-MariaDB 2 | 3 | ## Introduction 4 | 5 | OCaml-MariaDB is a library containing 6 | [Ctypes](https://github.com/ocamllabs/ocaml-ctypes)-based bindings for MariaDB. 7 | The library provides access to the traditional MySQL blocking API via the 8 | `Mariadb.Blocking` module, as well as the MariaDB nonblocking API, via 9 | `Mariadb.Nonblocking`, which is designed mainly for use with OCaml's monadic 10 | concurrent programming libraries such as [Lwt](https://ocsigen.org/lwt) and 11 | [Async](https://github.com/janestreet/async). 12 | 13 | Only the prepared-statement APIs are exposed by OCaml-MariaDB, as these 14 | functions provide typed query parameters and database field access. 15 | 16 | ## Installation 17 | 18 | OCaml-MariaDB requires MariaDB's client library version 5.5.21 or greater or 19 | the C connector library version 2.1.0 or greater (but version 3.0.0 or greater 20 | is recommended). If your distribution has these already packaged those versions, 21 | simply install either package. For example, on Debian or Ubuntu, run 22 | 23 | ```console 24 | # apt-get install libmariadbclient-dev 25 | ``` 26 | 27 | to use the client library, or 28 | 29 | ```console 30 | # apt-get install libmariadb-dev 31 | ``` 32 | 33 | to use the C connector. 34 | 35 | In case both are installed, OCaml-MariaDB will link against C connector. 36 | 37 | If your distribution doesn't yet package those versions, you can either install 38 | them manually, set up a third-party package archive (for example, there's an 39 | [Ubuntu PPA](https://launchpad.net/~jonathonf/+archive/ubuntu/mysql) that 40 | provides version 2.3.1 of the C connector), or configure MariaDB's own 41 | [repositories](https://downloads.mariadb.org/mariadb/repositories/), from which 42 | the client library will be available. 43 | 44 | To install OCaml-MariaDB via [OPAM](https://opam.ocaml.org/) simply type 45 | 46 | ```console 47 | $ opam install mariadb 48 | ``` 49 | 50 | To install it manually, type 51 | 52 | ```console 53 | $ ./configure 54 | $ ocaml setup.ml -build 55 | $ ocaml setup.ml -install 56 | 57 | If you want to build the Lwt and/or Async example programs, pass respectively 58 | `--enable-lwt` and `--enable-async` to the `configure` command above. 59 | OCaml-Mariadb itself has no dependency on either of those libraries. 60 | ``` 61 | 62 | ## The blocking API 63 | 64 | OCaml-MariaDB's API should be familiar to those who have used other MySQL 65 | libraries in OCaml or other languages before. A query must be initially 66 | *prepared*, resulting in a prepared statement, which can then be *executed* 67 | when given an appropriate set of parameters. Statement execution leads to a 68 | query *result* which can then be used to *fetch* rows, one at a time. 69 | 70 | A simple example is given below. 71 | 72 | ```ocaml 73 | open Printf 74 | 75 | module M = Mariadb.Blocking 76 | 77 | let or_die = function 78 | | Ok x -> x 79 | | Error (num, msg) -> failwith (sprintf "error #%d: %s" num msg) 80 | 81 | let main () = 82 | let mariadb = 83 | M.connect 84 | ~host:"localhost" 85 | ~user:"myuser" 86 | ~pass:"secret" 87 | () 88 | |> or_die in 89 | let query = "SELECT * FROM mysql.users WHERE Host LIKE ? LIMIT ?" in 90 | let stmt = M.prepare mariadb query |> or_die in 91 | let res = M.Stmt.execute stmt [| `String "%"; `Int 10 |] |> or_die in 92 | printf "number of rows: %d\n%!" (M.Res.num_rows res); 93 | print_rows res; (* see below *) 94 | M.Stmt.close stmt |> or_die; 95 | M.close mariadb; 96 | (* Call this only once, before you're done using all 97 | your database handles. *) 98 | M.library_end () 99 | 100 | let () = main () 101 | ``` 102 | 103 | ## The nonblocking API 104 | 105 | Usage of the nonblocking API is very similar to the blocking one, but designed 106 | to support OCaml's popular monadic concurrency libraries (though usage of a 107 | monadic library is not mandatory -- see the `examples` directory for an example 108 | using `Unix.select`). 109 | 110 | To use the nonblocking API, a module of type `Mariadb.Nonblocking.Wait` must be 111 | provided to the functor `Mariadb.Nonblocking.Make`. This module must contain 112 | an asynchronous I/O type definition along with the usual *bind* and *return* 113 | monadic operations, as well as a `wait` function that specifies how to wait for 114 | the MariaDB socket to become readable and/or writable. 115 | 116 | The signature is as follows. 117 | 118 | ```ocaml 119 | module type Wait = sig 120 | module IO : sig 121 | type 'a future 122 | 123 | val (>>=) : 'a future -> ('a -> 'b future) -> 'b future 124 | val return : 'a -> 'a future 125 | end 126 | 127 | val wait : t -> Mariadb.Nonblocking.Status.t 128 | -> Mariadb.Nonblocking.Status.t IO.future 129 | end 130 | ``` 131 | 132 | The `wait` function receives a *status* parameter that specifies which socket 133 | events are to be waited for (which can be checked via `Status.read`, 134 | `Status.write` and `Status.timeout` -- see the `ocamldoc` for more details). 135 | It must then return a new status, specifying which of those events have actually 136 | occurred. 137 | 138 | A simple example of the nonblocking library usage is given below. Full examples 139 | of wait modules for Lwt and Async can be found in the `examples` directory. 140 | 141 | ```ocaml 142 | module M = Mariadb.Nonblocking.Make(struct 143 | module IO = struct 144 | type 'a future = ... 145 | let (>>=) m f = ... 146 | let return x = ... 147 | end 148 | 149 | let wait mariadb status = 150 | ... 151 | end) 152 | 153 | let main () = 154 | M.connect 155 | ~host:"localhost" 156 | ~user:"myuser" 157 | ~pass:"secret" 158 | () 159 | >>= or_die 160 | >>= fun mariadb -> 161 | let query = "SELECT * FROM mysql.users WHERE Host LIKE ? LIMIT ?" in 162 | M.prepare mariadb query >>= or_die 163 | >>= fun stmt -> 164 | M.Stmt.execute stmt [| `String "%"; `Int 10 |] >>= or_die 165 | >>= fun res -> 166 | print_rows res >>= fun () -> (* see below *) 167 | M.Stmt.close stmt >>= or_die >>= fun () -> 168 | M.close mariadb >>= fun () -> 169 | M.library_end () 170 | ``` 171 | 172 | ## Fetching rows 173 | 174 | Rows can be fetched using the `Res.fetch` function. This function takes a 175 | module as its first parameter that defines the data structure in which the 176 | row is to be fetched. 177 | 178 | For example, 179 | 180 | ```ocaml 181 | M.Res.fetch (module M.Row.Array) res 182 | ``` 183 | 184 | returns the row as an `array` of `Field.t` values. The following built-in 185 | modules are provided with OCaml-MariaDB, but the user is free to implement 186 | one if so desired, in which case it must conform to the `Row.S` module type 187 | (see the `ocamldoc` for details). 188 | 189 | * `Row.Array`: fetch row as `Field.t array`; 190 | * `Row.Map`: fetch row as a map of column name (`string`) to `Field.t`; 191 | * `Row.Hashtbl`: fetch row as a `(string, Field.t) Hashtbl.t`. 192 | 193 | The `fetch` function returns a `row option result`, where `row` represents the 194 | row type given by the module argument, and `result` is a wrapper for the 195 | `Pervasives.result` type that carries an `error` in the `Error` case. In the 196 | `Ok` case, `fetch` returns `Some row`, containing the next available row, or 197 | `None`, in which case no more rows are available in the result. 198 | 199 | ## Reading fields 200 | 201 | A database field is represented by the `Field.t` type, and its value by the 202 | `Field.value` type, which can be obtained by calling the `Field.value` 203 | function. 204 | 205 | ```ocaml 206 | type value = 207 | [ `Int of int 208 | | `Int64 of Int64.t 209 | | `UInt64 of Unsigned.UInt64.t 210 | | `Float of float 211 | | `String of string 212 | | `Bytes of bytes 213 | | `Time of Time.t 214 | ] 215 | ``` 216 | 217 | The `Field.value` function can also return `` `Null`` in case the field is an 218 | SQL `NULL`. 219 | 220 | Since the type of a field is in most cases known beforehand, as the user must 221 | be aware of the table definition in order to query it, helper functions are 222 | provided to extract the OCaml types directly from a field: 223 | 224 | ```ocaml 225 | val int : Field.t -> int 226 | val int64 : Field.t -> Int64.t 227 | val uint64 : Field.t -> Unsigned.Int64.t 228 | val float : Field.t -> float 229 | val string : Field.t -> string 230 | val bytes : Field.t -> bytes 231 | val time : Field.t -> Time.t 232 | ``` 233 | 234 | These functions will raise an exception if the field value is not of the 235 | expected type, but as noted above this shouldn't be a problem. 236 | 237 | For nullable fields, the following analogous functions are also provided: 238 | 239 | ```ocaml 240 | val int_opt : Field.t -> int option 241 | val int64_opt : Field.t -> Int64.t option 242 | val uint64_opt : Field.t -> Unsigned.UInt64.t option 243 | val float_opt : Field.t -> float option 244 | val string_opt : Field.t -> string option 245 | val bytes_opt : Field.t -> bytes option 246 | val time_opt : Field.t -> Time.t option 247 | ``` 248 | 249 | These functions return `None` if the field value is `` `Null``, or `Some v` 250 | otherwise. 251 | -------------------------------------------------------------------------------- /bindings/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mariadb_bindings) 3 | (public_name mariadb.bindings) 4 | (synopsis "OCaml bindings for MariaDB") 5 | (wrapped false) 6 | (libraries ctypes ctypes.stubs)) 7 | -------------------------------------------------------------------------------- /bindings/ffi_bindings.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | module Types (F: Ctypes.TYPE) = struct 4 | open F 5 | 6 | module Protocol = struct 7 | let default = constant "MYSQL_PROTOCOL_DEFAULT" int 8 | let tcp = constant "MYSQL_PROTOCOL_TCP" int 9 | let socket = constant "MYSQL_PROTOCOL_SOCKET" int 10 | let pipe = constant "MYSQL_PROTOCOL_PIPE" int 11 | let memory = constant "MYSQL_PROTOCOL_MEMORY" int 12 | end 13 | 14 | module Options = struct 15 | let connect_timeout = constant "MYSQL_OPT_CONNECT_TIMEOUT" int 16 | let compress = constant "MYSQL_OPT_COMPRESS" int 17 | let named_pipe = constant "MYSQL_OPT_NAMED_PIPE" int 18 | let init_command = constant "MYSQL_INIT_COMMAND" int 19 | let read_default_file = constant "MYSQL_READ_DEFAULT_FILE" int 20 | let read_default_group = constant "MYSQL_READ_DEFAULT_GROUP" int 21 | let set_charset_dir = constant "MYSQL_SET_CHARSET_DIR" int 22 | let set_charset_name = constant "MYSQL_SET_CHARSET_NAME" int 23 | let local_infile = constant "MYSQL_OPT_LOCAL_INFILE" int 24 | let protocol = constant "MYSQL_OPT_PROTOCOL" int 25 | let shared_memory_base_name = constant "MYSQL_SHARED_MEMORY_BASE_NAME" int 26 | let read_timeout = constant "MYSQL_OPT_READ_TIMEOUT" int 27 | let write_timeout = constant "MYSQL_OPT_WRITE_TIMEOUT" int 28 | let secure_auth = constant "MYSQL_SECURE_AUTH" int 29 | let report_data_truncation = constant "MYSQL_REPORT_DATA_TRUNCATION" int 30 | let reconnect = constant "MYSQL_OPT_RECONNECT" int 31 | let ssl_verify_server_cert = constant "MYSQL_OPT_SSL_VERIFY_SERVER_CERT" int 32 | let plugin_dir = constant "MYSQL_PLUGIN_DIR" int 33 | let default_auth = constant "MYSQL_DEFAULT_AUTH" int 34 | let bind = constant "MYSQL_OPT_BIND" int 35 | let ssl_key = constant "MYSQL_OPT_SSL_KEY" int 36 | let ssl_cert = constant "MYSQL_OPT_SSL_CERT" int 37 | let ssl_ca = constant "MYSQL_OPT_SSL_CA" int 38 | let ssl_capath = constant "MYSQL_OPT_SSL_CAPATH" int 39 | let ssl_cipher = constant "MYSQL_OPT_SSL_CIPHER" int 40 | let ssl_crl = constant "MYSQL_OPT_SSL_CRL" int 41 | let ssl_crlpath = constant "MYSQL_OPT_SSL_CRLPATH" int 42 | let connect_attr_reset = constant "MYSQL_OPT_CONNECT_ATTR_RESET" int 43 | let connect_attr_add = constant "MYSQL_OPT_CONNECT_ATTR_ADD" int 44 | let connect_attr_delete = constant "MYSQL_OPT_CONNECT_ATTR_DELETE" int 45 | let server_public_key = constant "MYSQL_SERVER_PUBLIC_KEY" int 46 | let enable_cleartext_plugin = constant "MYSQL_ENABLE_CLEARTEXT_PLUGIN" int 47 | let nonblock = constant "MYSQL_OPT_NONBLOCK" int 48 | end 49 | 50 | module Flags = struct 51 | let compress = constant "CLIENT_COMPRESS" int32_t 52 | let found_rows = constant "CLIENT_FOUND_ROWS" int32_t 53 | let ignore_sigpipe = constant "CLIENT_IGNORE_SIGPIPE" int32_t 54 | let ignore_space = constant "CLIENT_IGNORE_SPACE" int32_t 55 | let interactive = constant "CLIENT_INTERACTIVE" int32_t 56 | let local_files = constant "CLIENT_LOCAL_FILES" int32_t 57 | let multi_results = constant "CLIENT_MULTI_RESULTS" int32_t 58 | let multi_statements = constant "CLIENT_MULTI_STATEMENTS" int32_t 59 | let no_schema = constant "CLIENT_NO_SCHEMA" int32_t 60 | let odbc = constant "CLIENT_ODBC" int32_t 61 | let ssl = constant "CLIENT_SSL" int32_t 62 | let remember_options = constant "CLIENT_REMEMBER_OPTIONS" int32_t 63 | end 64 | 65 | module Server_options = struct 66 | let multi_statements_on = constant "MYSQL_OPTION_MULTI_STATEMENTS_ON" int 67 | let multi_statements_off = constant "MYSQL_OPTION_MULTI_STATEMENTS_OFF" int 68 | end 69 | 70 | module Wait_status = struct 71 | let read = constant "MYSQL_WAIT_READ" int 72 | let write = constant "MYSQL_WAIT_WRITE" int 73 | let except = constant "MYSQL_WAIT_EXCEPT" int 74 | let timeout = constant "MYSQL_WAIT_TIMEOUT" int 75 | end 76 | 77 | module Type = struct 78 | let null = constant "MYSQL_TYPE_NULL" int 79 | let tiny = constant "MYSQL_TYPE_TINY" int 80 | let year = constant "MYSQL_TYPE_YEAR" int 81 | let short = constant "MYSQL_TYPE_SHORT" int 82 | let int24 = constant "MYSQL_TYPE_INT24" int 83 | let long = constant "MYSQL_TYPE_LONG" int 84 | let float = constant "MYSQL_TYPE_FLOAT" int 85 | let long_long = constant "MYSQL_TYPE_LONGLONG" int 86 | let double = constant "MYSQL_TYPE_DOUBLE" int 87 | let decimal = constant "MYSQL_TYPE_DECIMAL" int 88 | let new_decimal = constant "MYSQL_TYPE_NEWDECIMAL" int 89 | let string = constant "MYSQL_TYPE_STRING" int 90 | let var_string = constant "MYSQL_TYPE_VAR_STRING" int 91 | let tiny_blob = constant "MYSQL_TYPE_TINY_BLOB" int 92 | let blob = constant "MYSQL_TYPE_BLOB" int 93 | let medium_blob = constant "MYSQL_TYPE_MEDIUM_BLOB" int 94 | let long_blob = constant "MYSQL_TYPE_LONG_BLOB" int 95 | let bit = constant "MYSQL_TYPE_BIT" int 96 | let time = constant "MYSQL_TYPE_TIME" int 97 | let date = constant "MYSQL_TYPE_DATE" int 98 | let datetime = constant "MYSQL_TYPE_DATETIME" int 99 | let timestamp = constant "MYSQL_TYPE_TIMESTAMP" int 100 | let json = constant "MYSQL_TYPE_JSON" int 101 | end 102 | 103 | module Stmt_attr = struct 104 | let update_max_length = constant "STMT_ATTR_UPDATE_MAX_LENGTH" int 105 | let cursor_type = constant "STMT_ATTR_CURSOR_TYPE" int 106 | let prefetch_rows = constant "STMT_ATTR_PREFETCH_ROWS" int 107 | end 108 | 109 | module Return_code = struct 110 | let no_data = constant "MYSQL_NO_DATA" int 111 | let data_truncated = constant "MYSQL_DATA_TRUNCATED" int 112 | end 113 | 114 | module Bind = struct 115 | type bind 116 | type t = bind structure 117 | let t : t typ = structure "st_mysql_bind" 118 | 119 | let length = field t "length" (ptr ulong) 120 | let is_null = field t "is_null" (ptr char) 121 | let buffer = field t "buffer" (ptr void) 122 | let error = field t "error" (ptr char) 123 | let buffer_length = field t "buffer_length" ulong 124 | let buffer_type = field t "buffer_type" int 125 | let is_unsigned = field t "is_unsigned" char 126 | 127 | let () = seal t 128 | end 129 | 130 | module Field = struct 131 | type field 132 | type t = field structure 133 | let t : t typ = structure "st_mysql_field" 134 | 135 | let name = field t "name" string 136 | let max_length = field t "max_length" ulong 137 | let flags = field t "flags" uint 138 | let typ = field t "type" int 139 | 140 | let () = seal t 141 | 142 | module Flags = struct 143 | let not_null = constant "NOT_NULL_FLAG" uint 144 | let unsigned = constant "UNSIGNED_FLAG" uint 145 | end 146 | end 147 | 148 | module Time = struct 149 | type time 150 | type t = time structure 151 | let t : t typ = structure "st_mysql_time" 152 | 153 | let year = field t "year" uint 154 | let month = field t "month" uint 155 | let day = field t "day" uint 156 | let hour = field t "hour" uint 157 | let minute = field t "minute" uint 158 | let second = field t "second" uint 159 | let second_part = field t "second_part" ulong 160 | 161 | let () = seal t 162 | end 163 | end 164 | 165 | module Functions (F : Ctypes.FOREIGN) = struct 166 | open F 167 | 168 | type st_mysql 169 | let st_mysql : st_mysql structure typ = structure "st_mysql" 170 | 171 | type mysql = st_mysql structure ptr 172 | let mysql : mysql typ = ptr st_mysql 173 | 174 | type mysql_opt = st_mysql structure ptr option 175 | let mysql_opt : mysql_opt typ = ptr_opt st_mysql 176 | 177 | type st_mysql_res 178 | let st_mysql_res : st_mysql_res structure typ = structure "st_mysql_res" 179 | 180 | type res = st_mysql_res structure ptr 181 | let res : res typ = ptr st_mysql_res 182 | 183 | type res_opt = st_mysql_res structure ptr option 184 | let res_opt : res_opt typ = ptr_opt st_mysql_res 185 | 186 | type row = char ptr ptr 187 | let row : row typ = ptr (ptr char) 188 | 189 | type row_opt = char ptr ptr option 190 | let row_opt : row_opt typ = ptr_opt (ptr char) 191 | 192 | type st_mysql_stmt 193 | let st_mysql_stmt : st_mysql_stmt structure typ = structure "st_mysql_stmt" 194 | 195 | type stmt = st_mysql_stmt structure ptr 196 | let stmt : stmt typ = ptr st_mysql_stmt 197 | 198 | type stmt_opt = st_mysql_stmt structure ptr option 199 | let stmt_opt : stmt_opt typ = ptr_opt st_mysql_stmt 200 | 201 | type st_mysql_field 202 | let st_mysql_field : st_mysql_field structure typ = structure "st_mysql_field" 203 | 204 | type field = st_mysql_field structure ptr 205 | let field : field typ = ptr st_mysql_field 206 | 207 | type my_bool = char 208 | let my_bool : char typ = char 209 | 210 | (* Common API *) 211 | 212 | let mysql_library_init = foreign "mysql_server_init" 213 | (int @-> ptr_opt (ptr char) @-> ptr_opt (ptr char) @-> returning int) 214 | 215 | let mysql_library_end = foreign "mysql_server_end" 216 | (void @-> returning void) 217 | 218 | let mysql_init = foreign "mysql_init" 219 | (mysql_opt @-> returning mysql_opt) 220 | 221 | let mysql_close = foreign "mysql_close" 222 | (mysql @-> returning void) 223 | 224 | let mysql_options = foreign "mysql_options" 225 | (mysql @-> int @-> ptr void @-> returning int) 226 | 227 | let mysql_options4 = foreign "mysql_options4" 228 | (mysql @-> int @-> ptr void @-> ptr void @-> returning int) 229 | 230 | let mysql_num_fields = foreign "mysql_num_fields" 231 | (res @-> returning int) 232 | 233 | let mysql_errno = foreign "mysql_errno" 234 | (mysql @-> returning int) 235 | 236 | let mysql_error = foreign "mysql_error" 237 | (mysql @-> returning string) 238 | 239 | let mysql_stmt_init = foreign "mysql_stmt_init" 240 | (mysql @-> returning stmt_opt) 241 | 242 | let mysql_stmt_errno = foreign "mysql_stmt_errno" 243 | (stmt @-> returning int) 244 | 245 | let mysql_stmt_error = foreign "mysql_stmt_error" 246 | (stmt @-> returning string) 247 | 248 | let mysql_stmt_attr_set = foreign "mysql_stmt_attr_set" 249 | (stmt @-> int @-> ptr void @-> returning my_bool) 250 | 251 | (* XXX ptr void because we can't access Bind.t here *) 252 | let mysql_stmt_bind_param = foreign "mysql_stmt_bind_param" 253 | (stmt @-> ptr void @-> returning my_bool) 254 | 255 | let mysql_stmt_param_count = foreign "mysql_stmt_param_count" 256 | (stmt @-> returning ulong) 257 | 258 | let mysql_stmt_result_metadata = foreign "mysql_stmt_result_metadata" 259 | (stmt @-> returning res_opt) 260 | 261 | (* XXX ptr void because we can't access Field.t here *) 262 | let mysql_fetch_field_direct = foreign "mysql_fetch_field_direct" 263 | (res @-> uint @-> returning (ptr void)) 264 | 265 | (* XXX ptr void because we can't access Bind.t here *) 266 | let mysql_stmt_bind_result = foreign "mysql_stmt_bind_result" 267 | (stmt @-> ptr void @-> returning my_bool) 268 | 269 | let mysql_stmt_num_rows = foreign "mysql_stmt_num_rows" 270 | (stmt @-> returning ullong) 271 | 272 | let mysql_stmt_affected_rows = foreign "mysql_stmt_affected_rows" 273 | (stmt @-> returning ullong) 274 | 275 | let mysql_stmt_insert_id = foreign "mysql_stmt_insert_id" 276 | (stmt @-> returning ullong) 277 | 278 | (* Blocking API *) 279 | 280 | let mysql_free_result = foreign "mysql_free_result" 281 | (res @-> returning void) 282 | 283 | let mysql_real_connect = foreign "mysql_real_connect" 284 | (mysql @-> ptr_opt char @-> ptr_opt char @-> 285 | ptr_opt char @-> ptr_opt char @-> uint @-> ptr_opt char @-> ulong @-> 286 | returning mysql_opt) 287 | 288 | let mysql_commit = foreign "mysql_commit" 289 | (mysql @-> returning my_bool) 290 | 291 | let mysql_rollback = foreign "mysql_rollback" 292 | (mysql @-> returning my_bool) 293 | 294 | let mysql_autocommit = foreign "mysql_autocommit" 295 | (mysql @-> my_bool @-> returning my_bool) 296 | 297 | let mysql_set_character_set = foreign "mysql_set_character_set" 298 | (mysql @-> ptr char @-> returning int) 299 | 300 | let mysql_select_db = foreign "mysql_select_db" 301 | (mysql @-> ptr char @-> returning int) 302 | 303 | let mysql_change_user = foreign "mysql_change_user" 304 | (mysql @-> ptr char @-> ptr char @-> ptr_opt char @-> returning my_bool) 305 | 306 | let mysql_set_server_option = foreign "mysql_set_server_option" 307 | (mysql @-> int @-> returning int) 308 | 309 | let mysql_ping = foreign "mysql_ping" 310 | (mysql @-> returning int) 311 | 312 | let mysql_get_server_info = foreign "mysql_get_server_info" 313 | (mysql @-> returning string) 314 | 315 | let mysql_get_server_version = foreign "mysql_get_server_version" 316 | (mysql @-> returning ulong) 317 | 318 | let mysql_get_host_info = foreign "mysql_get_host_info" 319 | (mysql @-> returning string) 320 | 321 | let mysql_get_proto_info = foreign "mysql_get_proto_info" 322 | (mysql @-> returning uint) 323 | 324 | let mysql_stmt_prepare = foreign "mysql_stmt_prepare" 325 | (stmt @-> ptr char @-> ulong @-> returning int) 326 | 327 | let mysql_stmt_reset = foreign "mysql_stmt_reset" 328 | (stmt @-> returning my_bool) 329 | 330 | let mysql_stmt_execute = foreign "mysql_stmt_execute" 331 | (stmt @-> returning int) 332 | 333 | let mysql_stmt_fetch = foreign "mysql_stmt_fetch" 334 | (stmt @-> returning int) 335 | 336 | let mysql_stmt_close = foreign "mysql_stmt_close" 337 | (stmt @-> returning my_bool) 338 | 339 | let mysql_stmt_store_result = foreign "mysql_stmt_store_result" 340 | (stmt @-> returning int) 341 | 342 | let mysql_stmt_free_result = foreign "mysql_stmt_free_result" 343 | (stmt @-> returning my_bool) 344 | 345 | let mysql_real_query = foreign "mysql_real_query" 346 | (mysql @-> ptr char @-> ulong @-> returning int) 347 | 348 | (* Nonblocking API *) 349 | 350 | let mysql_free_result_start = foreign "mysql_free_result_start" 351 | (res @-> returning int) 352 | 353 | let mysql_free_result_cont = foreign "mysql_free_result_cont" 354 | (res @-> int @-> returning int) 355 | 356 | let mysql_close_start = foreign "mysql_close_start" 357 | (mysql @-> returning int) 358 | 359 | let mysql_close_cont = foreign "mysql_close_cont" 360 | (mysql @-> int @-> returning int) 361 | 362 | let mysql_real_connect_start = foreign "mysql_real_connect_start" 363 | (ptr mysql_opt @-> mysql @-> ptr_opt char @-> ptr_opt char @-> 364 | ptr_opt char @-> ptr_opt char @-> uint @-> ptr_opt char @-> ulong @-> 365 | returning int) 366 | 367 | let mysql_real_connect_cont = foreign "mysql_real_connect_cont" 368 | (ptr mysql_opt @-> mysql @-> int @-> returning int) 369 | 370 | let mysql_get_socket = foreign "mysql_get_socket" 371 | (mysql @-> returning int) 372 | 373 | let mysql_get_timeout_value = foreign "mysql_get_timeout_value" 374 | (mysql @-> returning uint) 375 | 376 | let mysql_get_timeout_value_ms = foreign "mysql_get_timeout_value_ms" 377 | (mysql @-> returning uint) 378 | 379 | let mysql_set_character_set_start = foreign "mysql_set_character_set_start" 380 | (ptr int @-> mysql @-> ptr char @-> returning int) 381 | 382 | let mysql_set_character_set_cont = foreign "mysql_set_character_set_cont" 383 | (ptr int @-> mysql @-> int @-> returning int) 384 | 385 | let mysql_select_db_start = foreign "mysql_select_db_start" 386 | (ptr int @-> mysql @-> ptr char @-> returning int) 387 | 388 | let mysql_select_db_cont = foreign "mysql_select_db_cont" 389 | (ptr int @-> mysql @-> int @-> returning int) 390 | 391 | let mysql_change_user_start = foreign "mysql_change_user_start" 392 | (ptr my_bool @-> mysql @-> ptr char @-> ptr char @-> ptr_opt char @-> 393 | returning int) 394 | 395 | let mysql_change_user_cont = foreign "mysql_change_user_cont" 396 | (ptr my_bool @-> mysql @-> int @-> returning int) 397 | 398 | let mysql_set_server_option_start = foreign "mysql_set_server_option_start" 399 | (ptr int @-> mysql @-> int @-> returning int) 400 | 401 | let mysql_set_server_option_cont = foreign "mysql_set_server_option_cont" 402 | (ptr int @-> mysql @-> int @-> returning int) 403 | 404 | let mysql_ping_start = foreign "mysql_ping_start" 405 | (ptr int @-> mysql @-> returning int) 406 | 407 | let mysql_ping_cont = foreign "mysql_ping_cont" 408 | (ptr int @-> mysql @-> int @-> returning int) 409 | 410 | let mysql_stmt_prepare_start = foreign "mysql_stmt_prepare_start" 411 | (ptr int @-> stmt @-> ptr char @-> ulong @-> returning int) 412 | 413 | let mysql_stmt_prepare_cont = foreign "mysql_stmt_prepare_cont" 414 | (ptr int @-> stmt @-> int @-> returning int) 415 | 416 | let mysql_stmt_reset_start = foreign "mysql_stmt_reset_start" 417 | (ptr my_bool @-> stmt @-> returning int) 418 | 419 | let mysql_stmt_reset_cont = foreign "mysql_stmt_reset_cont" 420 | (ptr my_bool @-> stmt @-> int @-> returning int) 421 | 422 | let mysql_stmt_execute_start = foreign "mysql_stmt_execute_start" 423 | (ptr int @-> stmt @-> returning int) 424 | 425 | let mysql_stmt_execute_cont = foreign "mysql_stmt_execute_cont" 426 | (ptr int @-> stmt @-> int @-> returning int) 427 | 428 | let mysql_stmt_fetch_start = foreign "mysql_stmt_fetch_start" 429 | (ptr int @-> stmt @-> returning int) 430 | 431 | let mysql_stmt_fetch_cont = foreign "mysql_stmt_fetch_cont" 432 | (ptr int @-> stmt @-> int @-> returning int) 433 | 434 | let mysql_stmt_store_result_start = foreign "mysql_stmt_store_result_start" 435 | (ptr int @-> stmt @-> returning int) 436 | 437 | let mysql_stmt_store_result_cont = foreign "mysql_stmt_store_result_cont" 438 | (ptr int @-> stmt @-> int @-> returning int) 439 | 440 | let mysql_stmt_close_start = foreign "mysql_stmt_close_start" 441 | (ptr my_bool @-> stmt @-> returning int) 442 | 443 | let mysql_stmt_close_cont = foreign "mysql_stmt_close_cont" 444 | (ptr my_bool @-> stmt @-> int @-> returning int) 445 | 446 | let mysql_stmt_free_result_start = foreign "mysql_stmt_free_result_start" 447 | (ptr my_bool @-> stmt @-> returning int) 448 | 449 | let mysql_stmt_free_result_cont = foreign "mysql_stmt_free_result_cont" 450 | (ptr my_bool @-> stmt @-> int @-> returning int) 451 | 452 | let mysql_commit_start = foreign "mysql_commit_start" 453 | (ptr my_bool @-> mysql @-> returning int) 454 | 455 | let mysql_commit_cont = foreign "mysql_commit_cont" 456 | (ptr my_bool @-> mysql @-> int @-> returning int) 457 | 458 | let mysql_rollback_start = foreign "mysql_rollback_start" 459 | (ptr my_bool @-> mysql @-> returning int) 460 | 461 | let mysql_rollback_cont = foreign "mysql_rollback_cont" 462 | (ptr my_bool @-> mysql @-> int @-> returning int) 463 | 464 | let mysql_autocommit_start = foreign "mysql_autocommit_start" 465 | (ptr my_bool @-> mysql @-> my_bool @-> returning int) 466 | 467 | let mysql_autocommit_cont = foreign "mysql_autocommit_cont" 468 | (ptr my_bool @-> mysql @-> int @-> returning int) 469 | 470 | let mysql_stmt_next_result_start = foreign "mysql_stmt_next_result_start" 471 | (ptr int @-> stmt @-> returning int) 472 | 473 | let mysql_stmt_next_result_cont = foreign "mysql_stmt_next_result_cont" 474 | (ptr int @-> stmt @-> int @-> returning int) 475 | 476 | let mysql_real_query_start = foreign "mysql_real_query_start" 477 | (ptr int @-> mysql @-> ptr char @-> ulong @-> returning int) 478 | 479 | let mysql_real_query_cont = foreign "mysql_real_query_cont" 480 | (ptr int @-> mysql @-> int @-> returning int) 481 | end 482 | -------------------------------------------------------------------------------- /discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let preamble ~include_base = Printf.sprintf "#include <%s/mysql.h>" include_base 4 | 5 | let detect_src ~include_base = 6 | Printf.sprintf 7 | {| 8 | #include 9 | %s 10 | 11 | int 12 | main(void) 13 | { 14 | MYSQL *m = mysql_init(NULL); 15 | mysql_close(m); 16 | return 0; 17 | } 18 | |} 19 | (preamble ~include_base) 20 | 21 | module Variant = struct 22 | type t = { link_flags : string list; include_base : string } 23 | 24 | let try_compile c { link_flags; include_base } = 25 | C.c_test c (detect_src ~include_base) ~link_flags 26 | end 27 | 28 | let split_flags s = String.split_on_char ' ' (String.trim s) 29 | 30 | let use_config cmd c = 31 | match C.Process.run c cmd [ "--libs" ] with 32 | | { exit_code = 0; stdout = libs_out; _ } -> ( 33 | match C.Process.run c cmd [ "--variable=pkgincludedir" ] with 34 | | { exit_code = 0; stdout = pkgincludedir; _ } -> 35 | Some 36 | { 37 | Variant.link_flags = split_flags libs_out; 38 | include_base = String.trim pkgincludedir; 39 | } 40 | | _ -> None) 41 | | _ -> None 42 | 43 | let static v = fun _ -> Some v 44 | 45 | let variants = 46 | Variant. 47 | [ 48 | use_config "mariadb_config"; 49 | static { link_flags = [ "-lmariadb" ]; include_base = "mariadb" }; 50 | static { link_flags = [ "-lmariadbclient" ]; include_base = "mysql" }; 51 | use_config "mysql_config"; 52 | static { link_flags = [ "-lmysqlclient" ]; include_base = "mysql" }; 53 | ] 54 | 55 | (* Available in stdlib since OCaml 4.10. *) 56 | let rec find_map_list f = function 57 | | [] -> None 58 | | x :: xs -> (match f x with Some y -> Some y | None -> find_map_list f xs) 59 | 60 | let () = 61 | C.main ~name:"mariadb" @@ fun c -> 62 | let variant = 63 | match 64 | find_map_list 65 | (fun f -> 66 | match f c with 67 | | Some v when Variant.try_compile c v -> Some v 68 | | _ -> None) 69 | variants 70 | with 71 | | Some v -> v 72 | | None -> C.die "Cannot find MariaDB client library." 73 | in 74 | C.Flags.write_sexp "mariadb_link_flags.sexp" variant.Variant.link_flags; 75 | C.Flags.write_lines "mariadb_preamble.h" 76 | [ preamble ~include_base:variant.Variant.include_base ] 77 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (libraries dune-configurator)) 4 | 5 | (rule 6 | (targets mariadb_link_flags.sexp mariadb_preamble.h) 7 | (action (run ./discover.exe))) 8 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.15) 2 | (using ctypes 0.3) 3 | (name mariadb) 4 | -------------------------------------------------------------------------------- /dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.15) 2 | 3 | ; Warnings left after the dune migration PR, as they may provide valuable 4 | ; information: 5 | (env (_ (flags :standard -warn-error -3))) 6 | -------------------------------------------------------------------------------- /examples/async/.merlin: -------------------------------------------------------------------------------- 1 | PKG async 2 | REC 3 | -------------------------------------------------------------------------------- /examples/async/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name nonblocking_async_example) 3 | (libraries async mariadb threads) 4 | (optional)) 5 | -------------------------------------------------------------------------------- /examples/async/nonblocking_async_example.ml: -------------------------------------------------------------------------------- 1 | module Caml_bytes = Bytes 2 | open Core 3 | open Async 4 | 5 | module S = Mariadb.Nonblocking.Status 6 | module M = Mariadb.Nonblocking.Make(struct 7 | module IO = struct 8 | type 'a future = 'a Deferred.t 9 | let (>>=) = (>>=) 10 | let return = Deferred.return 11 | end 12 | 13 | let is_ready = function 14 | | `Ready -> true 15 | | `Bad_fd | `Closed -> false 16 | 17 | let ready (rt, wt, tt) = 18 | let r = ref false in 19 | let w = ref false in 20 | let t = ref false in 21 | let rc = Deferred.choice rt (fun x -> r := is_ready x) in 22 | let wc = Deferred.choice wt (fun x -> w := is_ready x) in 23 | let tc = Deferred.choice tt (fun _ -> t := true) in 24 | Deferred.enabled [rc; wc; tc] >>= fun f -> 25 | ignore (f ()); 26 | Deferred.return (!r, !w, !t) 27 | 28 | let wait mariadb status = 29 | let fd = 30 | Fd.create 31 | (Fd.Kind.Socket `Active) 32 | (Mariadb.Nonblocking.fd mariadb) 33 | (Info.of_string "") in 34 | assert (S.read status || S.write status || S.timeout status); 35 | let idle = Deferred.never () in 36 | let rt = 37 | if S.read status then Fd.ready_to fd `Read 38 | else idle in 39 | let wt = 40 | if S.write status then begin Fd.ready_to fd `Write 41 | end 42 | else idle in 43 | let tt = 44 | let tmout = float (Mariadb.Nonblocking.timeout mariadb) in 45 | if S.timeout status then Clock.after (Time_float.Span.of_sec tmout) 46 | else idle in 47 | ready (rt, wt, tt) >>= fun (read, write, timeout) -> 48 | Fd.close ~file_descriptor_handling:Fd.Do_not_close_file_descriptor fd 49 | >>= fun () -> 50 | Deferred.return @@ S.create ~read ~write ~timeout () 51 | end) 52 | 53 | let env var def = 54 | match Sys.getenv var with 55 | | Some v -> v 56 | | None -> def 57 | 58 | let or_die where = function 59 | | Stdlib.Ok r -> return r 60 | | Stdlib.Error (i, e) -> failwith @@ sprintf "%s: (%d) %s" where i e 61 | 62 | let print_row row = 63 | printf "---\n%!"; 64 | M.Row.StringMap.fold 65 | (fun name field _ -> 66 | printf "%20s " name; 67 | match M.Field.value field with 68 | | `Int i -> printf "%d\n%!" i 69 | | `Int64 i -> printf "%Ld\n%!" i 70 | | `UInt64 i -> printf "%s\n%!" (Unsigned.UInt64.to_string i) 71 | | `Float x -> printf "%f\n%!" x 72 | | `String s -> printf "%s\n%!" s 73 | | `Bytes b -> printf "%s\n%!" (Caml_bytes.to_string b) 74 | | `Time t -> 75 | printf "%04d-%02d-%02d %02d:%02d:%02d\n%!" 76 | (M.Time.year t) 77 | (M.Time.month t) 78 | (M.Time.day t) 79 | (M.Time.hour t) 80 | (M.Time.minute t) 81 | (M.Time.second t) 82 | | `Null -> printf "NULL\n%!") 83 | row 84 | (); 85 | return () 86 | 87 | let connect () = 88 | M.connect 89 | ~host:(env "OCAML_MARIADB_HOST" "localhost") 90 | ~user:(env "OCAML_MARIADB_USER" "root") 91 | ~pass:(env "OCAML_MARIADB_PASS" "") 92 | ~db:(env "OCAML_MARIADB_DB" "mysql") () 93 | 94 | let stream res = 95 | let build () = 96 | M.Res.fetch (module M.Row.Map) res 97 | >>| function 98 | | Ok (Some row) -> Some (row, ()) 99 | | Ok None | Error _ -> None in 100 | return (Pipe.unfold ~init:() ~f:build) 101 | 102 | let print_rows p = 103 | Pipe.iter p ~f:print_row 104 | 105 | let _main : unit Deferred.t = 106 | connect () >>= or_die "connect" >>= fun mariadb -> 107 | let query = env "OCAML_MARIADB_QUERY" 108 | "SELECT * FROM mysql.user WHERE User LIKE ?" in 109 | M.prepare mariadb query >>= or_die "prepare" >>= fun stmt -> 110 | M.Stmt.execute stmt [| `String "r%" |] >>= or_die "exec" >>= fun res -> 111 | assert (M.Res.affected_rows res = M.Res.num_rows res); 112 | printf "#rows: %d\n%!" (M.Res.num_rows res); 113 | stream res >>= fun p -> 114 | print_rows p >>= fun () -> 115 | M.Stmt.close stmt >>= or_die "stmt close" >>= fun () -> 116 | M.close mariadb >>= fun () -> 117 | M.library_end (); 118 | Shutdown.exit 0 119 | 120 | let () = never_returns (Scheduler.go ()) 121 | -------------------------------------------------------------------------------- /examples/blocking/blocking_example.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module M = Mariadb.Blocking 4 | 5 | let env var def = 6 | try Sys.getenv var 7 | with Not_found -> def 8 | 9 | let or_die where = function 10 | | Ok r -> r 11 | | Error (i, e) -> failwith @@ sprintf "%s: (%d) %s" where i e 12 | 13 | let print_row row = 14 | printf "---\n%!"; 15 | M.Row.StringMap.iter 16 | (fun name field -> 17 | printf "%20s " name; 18 | match M.Field.value field with 19 | | `Int i -> printf "%d\n%!" i 20 | | `Int64 i -> printf "%Ld\n%!" i 21 | | `UInt64 i -> printf "%s\n%!" (Unsigned.UInt64.to_string i) 22 | | `Float x -> printf "%f\n%!" x 23 | | `String s -> printf "%s\n%!" s 24 | | `Bytes b -> printf "%s\n%!" (Bytes.to_string b) 25 | | `Time t -> 26 | printf "%04d-%02d-%02d %02d:%02d:%02d\n%!" 27 | (M.Time.year t) 28 | (M.Time.month t) 29 | (M.Time.day t) 30 | (M.Time.hour t) 31 | (M.Time.minute t) 32 | (M.Time.second t) 33 | | `Null -> printf "NULL\n%!") 34 | row 35 | 36 | let connect () = 37 | M.connect 38 | ~host:(env "OCAML_MARIADB_HOST" "localhost") 39 | ~user:(env "OCAML_MARIADB_USER" "root") 40 | ~pass:(env "OCAML_MARIADB_PASS" "") 41 | ~db:(env "OCAML_MARIADB_DB" "mysql") () 42 | 43 | let stream res = 44 | let module F = struct exception E of M.error end in 45 | let rec next () = 46 | match M.Res.fetch (module M.Row.Map) res with 47 | | Ok (Some x) -> Seq.Cons (x, next) 48 | | Ok None -> Seq.Nil 49 | | Error e -> raise (F.E e) in 50 | next 51 | 52 | let main () = 53 | let mariadb = connect () |> or_die "connect" in 54 | let query = env "OCAML_MARIADB_QUERY" 55 | "SELECT * FROM mysql.user WHERE User LIKE ? AND ? < 0" in 56 | let stmt = M.prepare mariadb query |> or_die "prepare" in 57 | let res = M.Stmt.execute stmt [| `String "r%"; `Int (-1) |] |> or_die "exec" in 58 | assert (M.Res.affected_rows res = M.Res.num_rows res); 59 | printf "#rows: %d\n%!" (M.Res.num_rows res); 60 | let s = stream res in 61 | Seq.iter print_row s; 62 | M.Stmt.close stmt |> or_die "stmt close"; 63 | M.close mariadb; 64 | M.library_end (); 65 | printf "done\n%!" 66 | 67 | let () = main () 68 | -------------------------------------------------------------------------------- /examples/blocking/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name blocking_example) 3 | (libraries mariadb)) 4 | -------------------------------------------------------------------------------- /examples/lwt/.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt 2 | REC 3 | -------------------------------------------------------------------------------- /examples/lwt/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name nonblocking_lwt_example) 3 | (libraries mariadb lwt lwt.unix) 4 | (optional)) 5 | -------------------------------------------------------------------------------- /examples/lwt/nonblocking_lwt_example.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Printf 3 | 4 | module S = Mariadb.Nonblocking.Status 5 | module M = Mariadb.Nonblocking.Make(struct 6 | module IO = struct 7 | type 'a future = 'a Lwt.t 8 | let (>>=) = (>>=) 9 | let return = Lwt.return 10 | end 11 | 12 | let wait mariadb status = 13 | let fd = Lwt_unix.of_unix_file_descr @@ Mariadb.Nonblocking.fd mariadb in 14 | assert (S.read status || S.write status || S.timeout status); 15 | let idle, _ = Lwt.task () in 16 | let rt = 17 | if S.read status then Lwt_unix.wait_read fd 18 | else idle in 19 | let wt = 20 | if S.write status then Lwt_unix.wait_write fd 21 | else idle in 22 | let tt = 23 | match S.timeout status, Mariadb.Nonblocking.timeout mariadb with 24 | | true, 0 -> Lwt.return () 25 | | true, tmout -> Lwt_unix.timeout (float tmout) 26 | | false, _ -> idle in 27 | Lwt.catch 28 | (fun () -> 29 | Lwt.nchoose [rt; wt; tt] >>= fun _ -> 30 | Lwt.return @@ 31 | S.create 32 | ~read:(Lwt_unix.readable fd) 33 | ~write:(Lwt_unix.writable fd) 34 | ()) 35 | (function 36 | | Lwt_unix.Timeout -> Lwt.return @@ S.create ~timeout:true () 37 | | e -> Lwt.fail e) 38 | end) 39 | 40 | let env var def = 41 | try Sys.getenv var 42 | with Not_found -> def 43 | 44 | let or_die where = function 45 | | Ok r -> Lwt.return r 46 | | Error (i, e) -> Lwt.fail_with @@ sprintf "%s: (%d) %s" where i e 47 | 48 | let print_row row = 49 | Lwt_io.printf "---\n%!" >>= fun () -> 50 | M.Row.StringMap.fold 51 | (fun name field _ -> 52 | Lwt_io.printf "%20s " name >>= fun () -> 53 | match M.Field.value field with 54 | | `Int i -> Lwt_io.printf "%d\n%!" i 55 | | `Int64 i -> Lwt_io.printf "%Ld\n%!" i 56 | | `UInt64 i -> Lwt_io.printf "%s\n%!" (Unsigned.UInt64.to_string i) 57 | | `Float x -> Lwt_io.printf "%f\n%!" x 58 | | `String s -> Lwt_io.printf "%s\n%!" s 59 | | `Bytes b -> Lwt_io.printf "%s\n%!" (Bytes.to_string b) 60 | | `Time t -> 61 | Lwt_io.printf "%04d-%02d-%02d %02d:%02d:%02d\n%!" 62 | (M.Time.year t) 63 | (M.Time.month t) 64 | (M.Time.day t) 65 | (M.Time.hour t) 66 | (M.Time.minute t) 67 | (M.Time.second t) 68 | | `Null -> Lwt_io.printf "NULL\n%!") 69 | row 70 | Lwt.return_unit 71 | 72 | let connect () = 73 | M.connect 74 | ~host:(env "OCAML_MARIADB_HOST" "localhost") 75 | ~user:(env "OCAML_MARIADB_USER" "root") 76 | ~pass:(env "OCAML_MARIADB_PASS" "") 77 | ~db:(env "OCAML_MARIADB_DB" "mysql") () 78 | 79 | let stream res = 80 | let next _ = 81 | M.Res.fetch (module M.Row.Map) res 82 | >>= function 83 | | Ok (Some _ as row) -> Lwt.return row 84 | | Ok None -> Lwt.return_none 85 | | Error _ -> Lwt.return_none in 86 | Lwt.return (Lwt_stream.from next) 87 | 88 | let main () = 89 | connect () >>= or_die "connect" >>= fun mariadb -> 90 | let query = env "OCAML_MARIADB_QUERY" 91 | "SELECT * FROM mysql.user WHERE User LIKE ?" in 92 | M.prepare mariadb query >>= or_die "prepare" >>= fun stmt -> 93 | M.Stmt.execute stmt [| `String "r%" |] >>= or_die "exec" >>= fun res -> 94 | Lwt_io.printf ">>> %d\n%!" (M.Res.num_rows res) >>= fun () -> 95 | assert (M.Res.affected_rows res = M.Res.num_rows res); 96 | Lwt_io.printf "#rows: %d\n%!" (M.Res.num_rows res) >>= fun () -> 97 | stream res >>= fun s -> 98 | Lwt_stream.iter_s print_row s >>= fun () -> 99 | M.Stmt.close stmt >>= or_die "stmt close" >>= fun () -> 100 | M.close mariadb >>= fun () -> 101 | M.library_end (); 102 | Lwt.return_unit 103 | 104 | let () = 105 | Lwt_main.run @@ main () 106 | -------------------------------------------------------------------------------- /examples/select/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name nonblocking_select_example) 3 | (libraries mariadb unix)) 4 | -------------------------------------------------------------------------------- /examples/select/nonblocking_select_example.ml: -------------------------------------------------------------------------------- 1 | module IO = struct 2 | type 'a future = 'a 3 | let (>>=) x f = f x 4 | let return x = x 5 | end 6 | 7 | open IO 8 | 9 | module S = Mariadb.Nonblocking.Status 10 | module M = Mariadb.Nonblocking.Make(struct 11 | module IO = IO 12 | 13 | let wait mariadb status = 14 | let fd = Mariadb.Nonblocking.fd mariadb in 15 | let rfd = if S.read status then [fd] else [] in 16 | let wfd = if S.write status then [fd] else [] in 17 | let efd = if S.except status then [fd] else [] in 18 | let timeout = 19 | if S.timeout status 20 | then float @@ Mariadb.Nonblocking.timeout mariadb 21 | else -1.0 in 22 | try 23 | let rfd, wfd, efd = Unix.select rfd wfd efd timeout in 24 | return @@ 25 | S.create 26 | ~read:(rfd <> []) 27 | ~write:(wfd <> []) 28 | ~except:(efd <> []) 29 | () 30 | with Unix.Unix_error (_, _, _) -> 31 | return @@ S.create ~timeout: true () 32 | end) 33 | 34 | open Printf 35 | 36 | let env var def = 37 | try Sys.getenv var 38 | with Not_found -> def 39 | 40 | let or_die ?(info = "error") () = function 41 | | Ok r -> return r 42 | | Error (i, e) -> failwith @@ sprintf "%s: (%d) %s" info i e 43 | 44 | let connect () = 45 | M.connect 46 | ~host:(env "OCAML_MARIADB_HOST" "localhost") 47 | ~user:(env "OCAML_MARIADB_USER" "root") 48 | ~pass:(env "OCAML_MARIADB_PASS" "") 49 | ~db:(env "OCAML_MARIADB_DB" "mysql") () 50 | 51 | let print_row row = 52 | printf "---\n%!"; 53 | M.Row.StringMap.iter 54 | (fun name field -> 55 | printf "%20s " name; 56 | match M.Field.value field with 57 | | `Int i -> printf "%d\n%!" i 58 | | `Int64 i -> printf "%Ld\n%!" i 59 | | `UInt64 i -> printf "%s\n%!" (Unsigned.UInt64.to_string i) 60 | | `Float x -> printf "%f\n%!" x 61 | | `String s -> printf "%s\n%!" s 62 | | `Bytes b -> printf "%s\n%!" (Bytes.to_string b) 63 | | `Time t -> 64 | printf "%04d-%02d-%02d %02d:%02d:%02d\n%!" 65 | (M.Time.year t) 66 | (M.Time.month t) 67 | (M.Time.day t) 68 | (M.Time.hour t) 69 | (M.Time.minute t) 70 | (M.Time.second t) 71 | | `Null -> printf "NULL\n%!") 72 | row; 73 | return () 74 | 75 | let rec each_row res f = 76 | match M.Res.fetch (module M.Row.Map) res with 77 | | Ok (Some row) -> f row; each_row res f 78 | | Ok None -> return () 79 | | Error (_, s) -> failwith @@ "fetch: " ^ s 80 | 81 | let main () = 82 | let mariadb = connect () |> or_die ~info:"connect" () in 83 | let query = env "OCAML_MARIADB_QUERY" 84 | "SELECT * FROM mysql.user WHERE User LIKE ?" in 85 | let stmt = M.prepare mariadb query |> or_die ~info:"prepare" () in 86 | let res = M.Stmt.execute stmt [| `String "r%" |] |> or_die () in 87 | assert (M.Res.affected_rows res = M.Res.num_rows res); 88 | printf "#rows: %d\n%!" (M.Res.num_rows res); 89 | each_row res print_row; 90 | M.Stmt.close stmt |> or_die (); 91 | M.close mariadb; 92 | M.library_end () 93 | 94 | let () = main () 95 | -------------------------------------------------------------------------------- /lib/bind.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | module T = Ffi_generated.Types 4 | 5 | type t = 6 | { n : int 7 | ; bind : T.Bind.t ptr 8 | ; length : Unsigned.ulong ptr 9 | ; is_null : char ptr 10 | ; is_unsigned : char 11 | ; error : char ptr 12 | ; buffers : unit ptr array 13 | } 14 | 15 | type buffer_type = 16 | [ `Null 17 | | `Tiny 18 | | `Year 19 | | `Short 20 | | `Int24 21 | | `Json 22 | | `Long 23 | | `Float 24 | | `Long_long 25 | | `Double 26 | | `Decimal 27 | | `New_decimal 28 | | `String 29 | | `Var_string 30 | | `Tiny_blob 31 | | `Blob 32 | | `Medium_blob 33 | | `Long_blob 34 | | `Bit 35 | | `Time 36 | | `Date 37 | | `Datetime 38 | | `Timestamp 39 | ] 40 | 41 | let buffer_type_of_int i = 42 | let open T.Type in 43 | if i = null then `Null 44 | else if i = tiny then `Tiny 45 | else if i = year then `Year 46 | else if i = short then `Short 47 | else if i = int24 then `Int24 48 | else if i = long then `Long 49 | else if i = float then `Float 50 | else if i = long_long then `Long_long 51 | else if i = double then `Double 52 | else if i = decimal then `Decimal 53 | else if i = new_decimal then `New_decimal 54 | else if i = string then `String 55 | else if i = var_string then `Var_string 56 | else if i = tiny_blob then `Tiny_blob 57 | else if i = blob then `Blob 58 | else if i = medium_blob then `Medium_blob 59 | else if i = long_blob then `Long_blob 60 | else if i = bit then `Bit 61 | else if i = time then `Time 62 | else if i = date then `Date 63 | else if i = datetime then `Datetime 64 | else if i = timestamp then `Timestamp 65 | else if i = json then `Json 66 | else invalid_arg @@ "unknown buffer type " ^ (string_of_int i) 67 | 68 | let yes = '\001' 69 | let no = '\000' 70 | 71 | let alloc count = 72 | { n = count 73 | ; bind = allocate_n T.Bind.t ~count 74 | ; length = allocate_n ulong ~count 75 | ; is_null = allocate_n char ~count 76 | ; is_unsigned = no 77 | ; error = allocate_n char ~count 78 | ; buffers = Array.make count null 79 | } 80 | 81 | let bind b ~buffer ~size ~mysql_type ~unsigned ~at = 82 | assert (at >= 0 && at < b.n); 83 | let size = Unsigned.ULong.of_int size in 84 | let bp = b.bind +@ at in 85 | let lp = b.length +@ at in 86 | lp <-@ size; 87 | b.buffers.(at) <- buffer; 88 | setf (!@bp) T.Bind.length lp; 89 | setf (!@bp) T.Bind.is_unsigned unsigned; 90 | setf (!@bp) T.Bind.buffer_type mysql_type; 91 | setf (!@bp) T.Bind.buffer_length size; 92 | setf (!@bp) T.Bind.buffer buffer 93 | 94 | let null b ~at = 95 | bind b 96 | ~buffer:Ctypes.null 97 | ~size:0 98 | ~mysql_type:T.Type.null 99 | ~unsigned:yes 100 | ~at 101 | 102 | let tiny ?(unsigned = false) b param ~at = 103 | let p = allocate char (char_of_int param) in 104 | bind b 105 | ~buffer:(coerce (ptr char) (ptr void) p) 106 | ~size:(sizeof int) 107 | ~mysql_type:T.Type.tiny 108 | ~unsigned:(if unsigned then yes else no) 109 | ~at 110 | 111 | let short ?(unsigned = false) b param ~at = 112 | let p = allocate short param in 113 | bind b 114 | ~buffer:(coerce (ptr short) (ptr void) p) 115 | ~size:(sizeof int) 116 | ~mysql_type:T.Type.short 117 | ~unsigned:(if unsigned then yes else no) 118 | ~at 119 | 120 | let int ?(unsigned = false) b param ~at = 121 | let p = allocate llong (Signed.LLong.of_int param) in 122 | bind b 123 | ~buffer:(coerce (ptr llong) (ptr void) p) 124 | ~size:(sizeof llong) 125 | ~mysql_type:T.Type.long_long 126 | ~unsigned:(if unsigned then yes else no) 127 | ~at 128 | 129 | let int64 ?(unsigned = false) b param ~at = 130 | let p = allocate int64_t param in 131 | bind b 132 | ~buffer:(coerce (ptr int64_t) (ptr void) p) 133 | ~size:(sizeof int64_t) 134 | ~mysql_type:T.Type.long_long 135 | ~unsigned:(if unsigned then yes else no) 136 | ~at 137 | 138 | let float b param ~at = 139 | let p = allocate float param in 140 | bind b 141 | ~buffer:(coerce (ptr float) (ptr void) p) 142 | ~size:(sizeof float) 143 | ~mysql_type:T.Type.float 144 | ~unsigned:no 145 | ~at 146 | 147 | let double b param ~at = 148 | let p = allocate double param in 149 | bind b 150 | ~buffer:(coerce (ptr double) (ptr void) p) 151 | ~size:(sizeof double) 152 | ~mysql_type:T.Type.double 153 | ~unsigned:no 154 | ~at 155 | 156 | let string b param ~at = 157 | let len = String.length param in 158 | let p = allocate_n char ~count:len in 159 | String.iteri (fun i c -> (p +@ i) <-@ c) param; 160 | bind b 161 | ~buffer:(coerce (ptr char) (ptr void) p) 162 | ~size:len 163 | ~mysql_type:T.Type.string 164 | ~unsigned:no 165 | ~at 166 | 167 | let blob b param ~at = 168 | let len = Bytes.length param in 169 | let p = allocate_n char ~count:len in 170 | Bytes.iteri (fun i c -> (p +@ i) <-@ c) param; 171 | bind b 172 | ~buffer:(coerce (ptr char) (ptr void) p) 173 | ~size:len 174 | ~mysql_type:T.Type.blob 175 | ~unsigned:no 176 | ~at 177 | 178 | let type_of_time_kind = function 179 | | `Time -> T.Type.time 180 | | `Timestamp -> T.Type.timestamp 181 | | `Date -> T.Type.date 182 | | `Datetime -> T.Type.datetime 183 | 184 | let time b param ~at = 185 | let tp = allocate_n T.Time.t ~count:1 in 186 | let to_uint = Unsigned.UInt.of_int in 187 | let to_ulong = Unsigned.ULong.of_int in 188 | setf (!@tp) T.Time.year (to_uint param.Time.year); 189 | setf (!@tp) T.Time.month (to_uint param.Time.month); 190 | setf (!@tp) T.Time.day (to_uint param.Time.day); 191 | setf (!@tp) T.Time.hour (to_uint param.Time.hour); 192 | setf (!@tp) T.Time.minute (to_uint param.Time.minute); 193 | setf (!@tp) T.Time.second (to_uint param.Time.second); 194 | setf (!@tp) T.Time.second_part (to_ulong param.Time.microsecond); 195 | bind b 196 | ~buffer:(coerce (ptr T.Time.t) (ptr void) tp) 197 | ~size:(sizeof T.Time.t) 198 | ~mysql_type:(type_of_time_kind param.Time.kind) 199 | ~unsigned:no 200 | ~at 201 | -------------------------------------------------------------------------------- /lib/binding_wrappers.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | open Util 3 | 4 | module B = Ffi_generated.Functions 5 | module T = Ffi_generated.Types 6 | 7 | include B 8 | 9 | let handle (typ, z) f = 10 | let r = allocate typ z in 11 | let s = f r in 12 | (s, !@r) 13 | 14 | let handle_opt typ = handle (typ, None) 15 | let handle_int f = handle (int, 0) f 16 | let handle_char f = handle (char, '\000') f 17 | let handle_ret = handle_opt B.mysql_opt 18 | 19 | let mysql_init () = 20 | B.mysql_init None 21 | 22 | let mysql_options mysql opt value = 23 | B.mysql_options mysql opt value |> ignore 24 | 25 | let mysql_options4 mysql opt value1 value2 = 26 | B.mysql_options4 mysql opt value1 value2 |> ignore 27 | 28 | let mysql_stmt_attr_set_bool stmt attr value = 29 | let c = if value then '\001' else '\000' in 30 | let v = allocate B.my_bool c in 31 | B.mysql_stmt_attr_set stmt attr (to_voidp v) |> ignore 32 | 33 | let mysql_stmt_param_count stmt = 34 | Unsigned.ULong.to_int @@ B.mysql_stmt_param_count stmt 35 | 36 | let mysql_stmt_bind_param stmt bind = 37 | B.mysql_stmt_bind_param stmt (to_voidp bind) = '\000' 38 | 39 | let mysql_fetch_field_direct res i = 40 | B.mysql_fetch_field_direct res (Unsigned.UInt.of_int i) 41 | 42 | let mysql_stmt_bind_result stmt bind = 43 | B.mysql_stmt_bind_result stmt (to_voidp bind) = '\000' 44 | 45 | let mysql_stmt_num_rows stmt = 46 | Unsigned.ULLong.to_int @@ B.mysql_stmt_num_rows stmt 47 | 48 | let mysql_stmt_affected_rows stmt = 49 | Unsigned.ULLong.to_int @@ B.mysql_stmt_affected_rows stmt 50 | 51 | let mysql_stmt_insert_id stmt = 52 | Unsigned.ULLong.to_int @@ B.mysql_stmt_insert_id stmt 53 | 54 | (* Blocking API *) 55 | 56 | let mysql_real_connect mysql host user pass db port socket flags = 57 | let host = char_ptr_opt_buffer_of_string host in 58 | let user = char_ptr_opt_buffer_of_string user in 59 | let pass = char_ptr_opt_buffer_of_string pass in 60 | let db = char_ptr_opt_buffer_of_string db in 61 | let port = Unsigned.UInt.of_int port in 62 | let socket = char_ptr_opt_buffer_of_string socket in 63 | let flags = Unsigned.ULong.of_int64 (Int64.of_int32 flags) in 64 | B.mysql_real_connect mysql host user pass db port socket flags 65 | 66 | let mysql_commit mysql = 67 | B.mysql_commit mysql = '\000' 68 | 69 | let mysql_rollback mysql = 70 | B.mysql_rollback mysql = '\000' 71 | 72 | let mysql_autocommit mysql auto = 73 | let auto = if auto then '\001' else '\000' in 74 | B.mysql_autocommit mysql auto = '\000' 75 | 76 | let mysql_set_character_set mysql charset = 77 | B.mysql_set_character_set mysql charset = 0 78 | 79 | let mysql_select_db mysql db = 80 | B.mysql_select_db mysql db = 0 81 | 82 | let mysql_change_user mysql user pass db = 83 | B.mysql_change_user mysql user pass db = '\000' 84 | 85 | let mysql_set_server_option mysql opt = 86 | B.mysql_set_server_option mysql opt = 0 87 | 88 | let mysql_ping mysql = 89 | B.mysql_ping mysql = 0 90 | 91 | let mysql_stmt_prepare stmt query = 92 | let len = Unsigned.ULong.of_int (String.length query) in 93 | let query = char_ptr_buffer_of_string query in 94 | B.mysql_stmt_prepare stmt query len = 0 95 | 96 | let mysql_stmt_reset stmt = 97 | B.mysql_stmt_reset stmt = '\000' 98 | 99 | let mysql_stmt_execute stmt = 100 | B.mysql_stmt_execute stmt = 0 101 | 102 | let mysql_stmt_close stmt = 103 | B.mysql_stmt_close stmt = '\000' 104 | 105 | let mysql_stmt_store_result stmt = 106 | B.mysql_stmt_store_result stmt = 0 107 | 108 | let mysql_stmt_free_result stmt = 109 | B.mysql_stmt_free_result stmt = '\000' 110 | 111 | let mysql_real_query mysql query = 112 | let len = Unsigned.ULong.of_int (String.length query) in 113 | let query = char_ptr_buffer_of_string query in 114 | B.mysql_real_query mysql query len = 0 115 | 116 | (* Nonblocking API *) 117 | 118 | let mysql_real_connect_start mysql host user pass db port socket flags = 119 | let port = Unsigned.UInt.of_int port in 120 | let flags = Unsigned.ULong.of_int64 (Int64.of_int32 flags) in 121 | handle_ret 122 | (fun ret -> 123 | B.mysql_real_connect_start ret mysql host user pass db port socket flags) 124 | 125 | let mysql_real_connect_cont mysql status = 126 | handle_ret (fun ret -> B.mysql_real_connect_cont ret mysql status) 127 | 128 | let mysql_get_timeout_value mysql = 129 | Unsigned.UInt.to_int @@ B.mysql_get_timeout_value mysql 130 | 131 | let mysql_get_timeout_value_ms mysql = 132 | Unsigned.UInt.to_int @@ B.mysql_get_timeout_value_ms mysql 133 | 134 | let mysql_set_character_set_start mysql charset = 135 | handle_int (fun ret -> B.mysql_set_character_set_start ret mysql charset) 136 | 137 | let mysql_set_character_set_cont mysql status = 138 | handle_int (fun ret -> B.mysql_set_character_set_cont ret mysql status) 139 | 140 | let mysql_select_db_start mysql db = 141 | handle_int (fun ret -> B.mysql_select_db_start ret mysql db) 142 | 143 | let mysql_select_db_cont mysql status = 144 | handle_int (fun ret -> B.mysql_select_db_cont ret mysql status) 145 | 146 | let mysql_change_user_start mysql user pass db = 147 | handle_char (fun ret -> B.mysql_change_user_start ret mysql user pass db) 148 | 149 | let mysql_change_user_cont mysql status = 150 | handle_char (fun ret -> B.mysql_change_user_cont ret mysql status) 151 | 152 | let mysql_set_server_option_start mysql opt = 153 | handle_int (fun ret -> B.mysql_set_server_option_start ret mysql opt) 154 | 155 | let mysql_set_server_option_cont mysql status = 156 | handle_int (fun ret -> B.mysql_set_server_option_cont ret mysql status) 157 | 158 | let mysql_ping_start mysql = 159 | handle_int (fun ret -> B.mysql_ping_start ret mysql) 160 | 161 | let mysql_ping_cont mysql status = 162 | handle_int (fun ret -> B.mysql_ping_cont ret mysql status) 163 | 164 | let mysql_stmt_prepare_start stmt query len = 165 | let len = Unsigned.ULong.of_int len in 166 | handle_int (fun err -> B.mysql_stmt_prepare_start err stmt query len) 167 | 168 | let mysql_stmt_prepare_cont stmt status = 169 | handle_int (fun err -> B.mysql_stmt_prepare_cont err stmt status) 170 | 171 | let mysql_stmt_reset_start stmt = 172 | handle_char (fun err -> B.mysql_stmt_reset_start err stmt) 173 | 174 | let mysql_stmt_reset_cont stmt status = 175 | handle_char (fun err -> B.mysql_stmt_reset_cont err stmt status) 176 | 177 | let mysql_stmt_execute_start stmt = 178 | handle_int (fun err -> B.mysql_stmt_execute_start err stmt) 179 | 180 | let mysql_stmt_execute_cont stmt status = 181 | handle_int (fun err -> B.mysql_stmt_execute_cont err stmt status) 182 | 183 | let mysql_stmt_fetch_start stmt = 184 | handle_int (fun err -> B.mysql_stmt_fetch_start err stmt) 185 | 186 | let mysql_stmt_fetch_cont stmt status = 187 | handle_int (fun err -> B.mysql_stmt_fetch_cont err stmt status) 188 | 189 | let mysql_stmt_store_result_start stmt = 190 | handle_int (fun err -> B.mysql_stmt_store_result_start err stmt) 191 | 192 | let mysql_stmt_store_result_cont stmt status = 193 | handle_int (fun err -> B.mysql_stmt_store_result_cont err stmt status) 194 | 195 | let mysql_stmt_close_start stmt = 196 | handle_char (fun err -> B.mysql_stmt_close_start err stmt) 197 | 198 | let mysql_stmt_close_cont stmt status = 199 | handle_char (fun err -> B.mysql_stmt_close_cont err stmt status) 200 | 201 | let mysql_stmt_free_result_start stmt = 202 | handle_char (fun err -> B.mysql_stmt_free_result_start err stmt) 203 | 204 | let mysql_stmt_free_result_cont stmt status = 205 | handle_char (fun err -> B.mysql_stmt_free_result_cont err stmt status) 206 | 207 | let mysql_commit_start mysql = 208 | handle_char (fun err -> B.mysql_commit_start err mysql) 209 | 210 | let mysql_commit_cont mysql status = 211 | handle_char (fun err -> B.mysql_commit_cont err mysql status) 212 | 213 | let mysql_rollback_start mysql = 214 | handle_char (fun err -> B.mysql_rollback_start err mysql) 215 | 216 | let mysql_rollback_cont mysql status = 217 | handle_char (fun err -> B.mysql_rollback_cont err mysql status) 218 | 219 | let mysql_autocommit_start mysql auto = 220 | let auto = if auto then '\001' else '\000' in 221 | handle_char (fun err -> B.mysql_autocommit_start err mysql auto) 222 | 223 | let mysql_autocommit_cont mysql status = 224 | handle_char (fun err -> B.mysql_autocommit_cont err mysql status) 225 | 226 | let mysql_stmt_next_result_start stmt = 227 | handle_int (fun err -> B.mysql_stmt_next_result_start err stmt) 228 | 229 | let mysql_stmt_next_result_cont stmt status = 230 | handle_int (fun err -> B.mysql_stmt_next_result_cont err stmt status) 231 | 232 | let mysql_real_query_start mysql query = 233 | let len = Unsigned.ULong.of_int (String.length query) in 234 | let query = char_ptr_buffer_of_string query in 235 | handle_int (fun err -> B.mysql_real_query_start err mysql query len) 236 | 237 | let mysql_real_query_cont mysql status = 238 | handle_int (fun err -> B.mysql_real_query_cont err mysql status) 239 | -------------------------------------------------------------------------------- /lib/blocking.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module B = Binding_wrappers 4 | module T = Ffi_generated.Types 5 | 6 | module Time = Time 7 | module Field = Field 8 | module Row = Row 9 | 10 | type t = [`Blocking] Common.t 11 | type mariadb = t 12 | 13 | type error = Common.error 14 | type 'a result = ('a, error) Stdlib.result 15 | 16 | type flag = Common.flag = 17 | | Compress 18 | | Found_rows 19 | | Ignore_sigpipe 20 | | Ignore_space 21 | | Interactive 22 | | Local_files 23 | | Multi_results 24 | | Multi_statements 25 | | No_schema 26 | | Odbc 27 | | Ssl 28 | | Remember_options 29 | 30 | type protocol = Common.protocol = 31 | | Default 32 | | Tcp 33 | | Socket 34 | | Pipe 35 | | Memory 36 | 37 | type client_option = Common.client_option = 38 | | Connect_timeout of int 39 | | Compress 40 | | Named_pipe of string 41 | | Init_command of string 42 | | Read_default_file of string 43 | | Read_default_group of string 44 | | Set_charset_dir of string 45 | | Set_charset_name of string 46 | | Local_infile of bool 47 | | Protocol of protocol 48 | | Shared_memory_base_name of string 49 | | Read_timeout of int 50 | | Write_timeout of int 51 | | Secure_auth of bool 52 | | Report_data_truncation of bool 53 | | Reconnect of bool 54 | | Ssl_verify_server_cert of bool 55 | | Plugin_dir of string 56 | | Default_auth of string 57 | | Bind of string 58 | | Ssl_key of string 59 | | Ssl_cert of string 60 | | Ssl_ca of string 61 | | Ssl_capath of string 62 | | Ssl_cipher of string 63 | | Ssl_crl of string 64 | | Ssl_crlpath of string 65 | | Connect_attr_reset 66 | | Connect_attr_add of string * string 67 | | Connect_attr_delete of string 68 | | Server_public_key of string 69 | | Enable_cleartext_plugin of bool 70 | 71 | type server_option = Common.server_option = 72 | | Multi_statements of bool 73 | 74 | let close mariadb = 75 | B.mysql_close mariadb.Common.raw 76 | 77 | let library_end = Common.library_end 78 | 79 | let connect ?host ?user ?pass ?db ?(port=0) ?socket ?(flags=[]) ?(options=[]) () = 80 | let flags = Common.int_of_flags flags in 81 | let connect raw = 82 | let mariadb = Common. 83 | { raw 84 | ; host = char_ptr_opt_buffer_of_string host 85 | ; port = port 86 | ; user = char_ptr_opt_buffer_of_string user 87 | ; pass = char_ptr_opt_buffer_of_string pass 88 | ; db = char_ptr_opt_buffer_of_string db 89 | ; socket = char_ptr_opt_buffer_of_string socket 90 | ; flags = flags 91 | ; charset = None 92 | } in 93 | List.iter (Common.set_client_option mariadb) options; 94 | match B.mysql_real_connect raw host user pass db port socket flags with 95 | | Some _ -> Ok mariadb 96 | | None -> Error (2008, "out of memory") in 97 | match B.mysql_init () with 98 | | Some raw -> connect raw 99 | | None -> Error (2008, "out of memory") 100 | 101 | let wrap_unit mariadb = function 102 | | true -> Ok () 103 | | false -> Error (Common.error mariadb) 104 | 105 | let set_character_set mariadb charset = 106 | let charset = char_ptr_buffer_of_string charset in 107 | mariadb.Common.charset <- Some charset; 108 | wrap_unit mariadb (B.mysql_set_character_set mariadb.Common.raw charset) 109 | 110 | let select_db mariadb db = 111 | let db = char_ptr_buffer_of_string db in 112 | mariadb.Common.db <- Some db; 113 | wrap_unit mariadb (B.mysql_select_db mariadb.Common.raw db) 114 | 115 | let change_user mariadb user pass db = 116 | let user = char_ptr_buffer_of_string user in 117 | let pass = char_ptr_buffer_of_string pass in 118 | mariadb.Common.user <- Some user; 119 | mariadb.Common.pass <- Some pass; 120 | mariadb.Common.db <- char_ptr_opt_buffer_of_string db; 121 | wrap_unit mariadb 122 | (B.mysql_change_user mariadb.Common.raw user pass mariadb.Common.db) 123 | 124 | let get_server_info = Common.get_server_info 125 | let get_server_version = Common.get_server_version 126 | let get_host_info = Common.get_host_info 127 | let get_proto_info = Common.get_proto_info 128 | 129 | let set_client_option = 130 | Common.set_client_option 131 | 132 | let set_server_option mariadb opt = 133 | let opt = Common.int_of_server_option opt in 134 | wrap_unit mariadb (B.mysql_set_server_option mariadb.Common.raw opt) 135 | 136 | let ping mariadb = 137 | wrap_unit mariadb (B.mysql_ping mariadb.Common.raw) 138 | 139 | let autocommit mariadb auto = 140 | wrap_unit mariadb (B.mysql_autocommit mariadb.Common.raw auto) 141 | 142 | let commit mariadb = 143 | wrap_unit mariadb (B.mysql_commit mariadb.Common.raw) 144 | 145 | let rollback mariadb = 146 | wrap_unit mariadb (B.mysql_rollback mariadb.Common.raw) 147 | 148 | let prepare mariadb query = 149 | let build_stmt raw = 150 | if B.mysql_stmt_prepare raw query then 151 | Ok (Common.Stmt.init mariadb raw) 152 | else 153 | Error (Common.error mariadb) in 154 | match Common.stmt_init mariadb with 155 | | Some raw -> build_stmt raw 156 | | None -> Error (2008, "out of memory") 157 | 158 | let start_txn mariadb = 159 | wrap_unit mariadb (B.mysql_real_query mariadb.Common.raw "START TRANSACTION") 160 | 161 | module Res = struct 162 | type t = [`Blocking] Common.Res.t 163 | 164 | let fetch (type t) (module R : Row.S with type t = t) res = 165 | let stmt = res.Common.Res.stmt in 166 | match B.mysql_stmt_fetch stmt with 167 | | 0 -> Ok (Common.Res.build_row (module R) res) 168 | | r when r = T.Return_code.no_data -> Ok None 169 | | r when r = T.Return_code.data_truncated -> Error (2032, "truncated data") 170 | | _ -> Error (B.mysql_stmt_errno stmt, B.mysql_stmt_error stmt) 171 | 172 | let num_rows = 173 | Common.Res.num_rows 174 | 175 | let affected_rows = 176 | Common.Res.affected_rows 177 | 178 | let insert_id = 179 | Common.Res.insert_id 180 | end 181 | 182 | module Stmt = struct 183 | type t = [`Blocking] Common.Stmt.t 184 | 185 | let free_meta stmt = 186 | match stmt.Common.Stmt.meta with 187 | | None -> () 188 | | Some { res; _ } -> 189 | stmt.meta <- None; 190 | B.mysql_free_result res 191 | 192 | let free_meta_and_result stmt = 193 | match stmt.Common.Stmt.meta with 194 | | None -> true 195 | | Some { res; _ } -> 196 | stmt.meta <- None; 197 | B.mysql_free_result res; 198 | B.mysql_stmt_free_result stmt.Common.Stmt.raw 199 | 200 | let execute stmt params = 201 | free_meta stmt; 202 | let n = B.mysql_stmt_param_count stmt.Common.Stmt.raw in 203 | if n <> Array.length params then 204 | Error (0, "parameter count mismatch") 205 | else begin 206 | let exec stmt = 207 | let raw = stmt.Common.Stmt.raw in 208 | if B.mysql_stmt_execute raw && B.mysql_stmt_store_result raw then 209 | match Common.Stmt.bind_result stmt with 210 | | `Ok res_or_none -> Ok res_or_none 211 | | `Error e -> Error e 212 | else 213 | Error (Common.Stmt.error stmt) in 214 | match Common.Stmt.bind_params stmt params with 215 | | `Ok bound -> exec bound 216 | | `Error e -> Error e 217 | end 218 | 219 | let reset stmt = 220 | if free_meta_and_result stmt && B.mysql_stmt_reset stmt.Common.Stmt.raw then 221 | Ok () 222 | else 223 | Error (Common.Stmt.error stmt) 224 | 225 | let close stmt = 226 | if free_meta_and_result stmt && B.mysql_stmt_close stmt.Common.Stmt.raw then 227 | Ok () 228 | else 229 | Error (Common.Stmt.error stmt) 230 | end 231 | -------------------------------------------------------------------------------- /lib/common.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module B = Binding_wrappers 4 | module T = Ffi_generated.Types 5 | 6 | module Row = Row 7 | module Field = Field 8 | 9 | type mode = [`Blocking | `Nonblocking] 10 | type 'm t = 11 | { raw : B.mysql 12 | ; host : char Ctypes.ptr option 13 | ; port : int 14 | ; mutable user : char Ctypes.ptr option 15 | ; mutable pass : char Ctypes.ptr option 16 | ; mutable db : char Ctypes.ptr option 17 | ; socket : char Ctypes.ptr option 18 | ; flags : int32 19 | ; mutable charset : char Ctypes.ptr option 20 | } 21 | constraint 'm = [< mode] 22 | 23 | type 'm mariadb = 'm t 24 | 25 | type flag = 26 | | Compress 27 | | Found_rows 28 | | Ignore_sigpipe 29 | | Ignore_space 30 | | Interactive 31 | | Local_files 32 | | Multi_results 33 | | Multi_statements 34 | | No_schema 35 | | Odbc 36 | | Ssl 37 | | Remember_options 38 | 39 | type protocol = 40 | | Default 41 | | Tcp 42 | | Socket 43 | | Pipe 44 | | Memory 45 | 46 | type client_option = 47 | | Connect_timeout of int 48 | | Compress 49 | | Named_pipe of string 50 | | Init_command of string 51 | | Read_default_file of string 52 | | Read_default_group of string 53 | | Set_charset_dir of string 54 | | Set_charset_name of string 55 | | Local_infile of bool 56 | | Protocol of protocol 57 | | Shared_memory_base_name of string 58 | | Read_timeout of int 59 | | Write_timeout of int 60 | | Secure_auth of bool 61 | | Report_data_truncation of bool 62 | | Reconnect of bool 63 | | Ssl_verify_server_cert of bool 64 | | Plugin_dir of string 65 | | Default_auth of string 66 | | Bind of string 67 | | Ssl_key of string 68 | | Ssl_cert of string 69 | | Ssl_ca of string 70 | | Ssl_capath of string 71 | | Ssl_cipher of string 72 | | Ssl_crl of string 73 | | Ssl_crlpath of string 74 | | Connect_attr_reset 75 | | Connect_attr_add of string * string 76 | | Connect_attr_delete of string 77 | | Server_public_key of string 78 | | Enable_cleartext_plugin of bool 79 | 80 | type server_option = 81 | | Multi_statements of bool 82 | 83 | type error = int * string 84 | 85 | let error mariadb = 86 | (B.mysql_errno mariadb.raw, B.mysql_error mariadb.raw) 87 | 88 | let int_of_server_option = function 89 | | Multi_statements true -> T.Server_options.multi_statements_on 90 | | Multi_statements false -> T.Server_options.multi_statements_off 91 | 92 | let voidp_of_string s = 93 | let open Ctypes in 94 | let b = char_ptr_buffer_of_string s in 95 | coerce (ptr char) (ptr void) b 96 | 97 | let voidp_of_uint i = 98 | let open Ctypes in 99 | let b = allocate uint (Unsigned.UInt.of_int i) in 100 | coerce (ptr uint) (ptr void) b 101 | 102 | let voidp_of_bool b = 103 | let open Ctypes in 104 | let b = allocate char (if b then '\001' else '\000') in 105 | coerce (ptr char) (ptr void) b 106 | 107 | let int_of_protocol = function 108 | | Default -> T.Protocol.default 109 | | Tcp -> T.Protocol.tcp 110 | | Socket -> T.Protocol.socket 111 | | Pipe -> T.Protocol.pipe 112 | | Memory -> T.Protocol.memory 113 | 114 | let set_client_option mariadb opt = 115 | let opt = 116 | match opt with 117 | | Connect_timeout t -> 118 | `Opt (T.Options.connect_timeout, voidp_of_uint t) 119 | | Compress -> 120 | `Opt (T.Options.compress, Ctypes.null) 121 | | Named_pipe pipe -> 122 | `Opt (T.Options.named_pipe, voidp_of_string pipe) 123 | | Init_command cmd -> 124 | `Opt (T.Options.init_command, voidp_of_string cmd) 125 | | Read_default_file file -> 126 | `Opt (T.Options.read_default_file, voidp_of_string file) 127 | | Read_default_group group -> 128 | `Opt (T.Options.read_default_group, voidp_of_string group) 129 | | Set_charset_dir dir -> 130 | `Opt (T.Options.set_charset_dir, voidp_of_string dir) 131 | | Set_charset_name name -> 132 | `Opt (T.Options.set_charset_name, voidp_of_string name) 133 | | Local_infile b -> 134 | `Opt (T.Options.local_infile, voidp_of_uint (if b then 1 else 0)) 135 | | Protocol proto -> 136 | `Opt (T.Options.protocol, voidp_of_uint (int_of_protocol proto)) 137 | | Shared_memory_base_name name -> 138 | `Opt (T.Options.shared_memory_base_name, voidp_of_string name) 139 | | Read_timeout t -> 140 | `Opt (T.Options.read_timeout, voidp_of_uint t) 141 | | Write_timeout t -> 142 | `Opt (T.Options.write_timeout, voidp_of_uint t) 143 | | Secure_auth b -> 144 | `Opt (T.Options.secure_auth, voidp_of_bool b) 145 | | Report_data_truncation b -> 146 | `Opt (T.Options.report_data_truncation, voidp_of_bool b) 147 | | Reconnect b -> 148 | `Opt (T.Options.reconnect, voidp_of_bool b) 149 | | Ssl_verify_server_cert b -> 150 | `Opt (T.Options.ssl_verify_server_cert, voidp_of_bool b) 151 | | Plugin_dir dir -> 152 | `Opt (T.Options.plugin_dir, voidp_of_string dir) 153 | | Default_auth auth -> 154 | `Opt (T.Options.default_auth, voidp_of_string auth) 155 | | Bind addr -> 156 | `Opt (T.Options.bind, voidp_of_string addr) 157 | | Ssl_key key -> 158 | `Opt (T.Options.ssl_key, voidp_of_string key) 159 | | Ssl_cert cert -> 160 | `Opt (T.Options.ssl_cert, voidp_of_string cert) 161 | | Ssl_ca ca -> 162 | `Opt (T.Options.ssl_ca, voidp_of_string ca) 163 | | Ssl_capath path -> 164 | `Opt (T.Options.ssl_capath, voidp_of_string path) 165 | | Ssl_cipher cipher -> 166 | `Opt (T.Options.ssl_cipher, voidp_of_string cipher) 167 | | Ssl_crl crl -> 168 | `Opt (T.Options.ssl_crl, voidp_of_string crl) 169 | | Ssl_crlpath path -> 170 | `Opt (T.Options.ssl_crlpath, voidp_of_string path) 171 | | Connect_attr_reset -> 172 | `Opt (T.Options.connect_attr_reset, Ctypes.null) 173 | | Connect_attr_add (k, v) -> 174 | `Opt4 (T.Options.connect_attr_add, voidp_of_string k, voidp_of_string v) 175 | | Connect_attr_delete attr -> 176 | `Opt (T.Options.connect_attr_delete, voidp_of_string attr) 177 | | Server_public_key key -> 178 | `Opt (T.Options.server_public_key, voidp_of_string key) 179 | | Enable_cleartext_plugin b -> 180 | `Opt (T.Options.enable_cleartext_plugin, voidp_of_bool b) in 181 | match opt with 182 | | `Opt (opt, arg) -> B.mysql_options mariadb.raw opt arg 183 | | `Opt4 (opt, arg1, arg2) -> B.mysql_options4 mariadb.raw opt arg1 arg2 184 | 185 | let int_of_flag = function 186 | | Found_rows -> T.Flags.found_rows 187 | | Compress -> T.Flags.compress 188 | | Ignore_sigpipe -> T.Flags.ignore_sigpipe 189 | | Ignore_space -> T.Flags.ignore_space 190 | | Interactive -> T.Flags.interactive 191 | | Local_files -> T.Flags.local_files 192 | | Multi_results -> T.Flags.multi_results 193 | | Multi_statements -> T.Flags.multi_statements 194 | | No_schema -> T.Flags.no_schema 195 | | Odbc -> T.Flags.odbc 196 | | Ssl -> T.Flags.ssl 197 | | Remember_options -> T.Flags.remember_options 198 | 199 | let int_of_flags = 200 | List.fold_left (fun acc flag -> Int32.logor acc (int_of_flag flag)) 0l 201 | 202 | let get_server_info mariadb = 203 | B.mysql_get_server_info mariadb.raw 204 | 205 | let get_server_version mariadb = 206 | Unsigned.ULong.to_int (B.mysql_get_server_version mariadb.raw) 207 | 208 | let get_host_info mariadb = 209 | B.mysql_get_host_info mariadb.raw 210 | 211 | let get_proto_info mariadb = 212 | Unsigned.UInt.to_int (B.mysql_get_proto_info mariadb.raw) 213 | 214 | module Res = struct 215 | open Ctypes 216 | 217 | type meta = 218 | { result : Bind.t 219 | ; raw : B.res 220 | ; buffers : unit ptr array 221 | } 222 | 223 | type 'm u = 224 | { mariadb : 'm mariadb 225 | ; stmt : B.stmt 226 | ; meta : meta option 227 | } 228 | type 'm t = 'm u constraint 'm = [< mode] 229 | 230 | let meta result raw buffers = 231 | { result; raw; buffers } 232 | 233 | let create ~mariadb ~stmt ?meta () = 234 | { mariadb; stmt; meta } 235 | 236 | let num_rows res = 237 | B.mysql_stmt_num_rows res.stmt 238 | 239 | let affected_rows res = 240 | B.mysql_stmt_affected_rows res.stmt 241 | 242 | let insert_id res = 243 | B.mysql_stmt_insert_id res.stmt 244 | 245 | let fetch_field raw i = 246 | coerce (ptr void) (ptr T.Field.t) (B.mysql_fetch_field_direct raw i) 247 | 248 | let build_row (type t) (module R : Row.S with type t = t) res = 249 | Option.map 250 | (fun {result; raw; _} -> 251 | R.build result.Bind.n 252 | (fun i -> 253 | let fp = fetch_field raw i in 254 | Field.create result fp i)) 255 | res.meta 256 | end 257 | 258 | let stmt_init mariadb = 259 | match B.mysql_stmt_init mariadb.raw with 260 | | Some stmt -> 261 | B.mysql_stmt_attr_set_bool stmt T.Stmt_attr.update_max_length true; 262 | Some stmt 263 | | None -> 264 | None 265 | 266 | let library_end () = 267 | B.mysql_library_end () 268 | 269 | module Stmt = struct 270 | open Ctypes 271 | 272 | type meta = 273 | { res : B.res 274 | ; result : Bind.t 275 | } 276 | 277 | type 'm u = 278 | { raw : B.stmt 279 | ; mariadb : 'm mariadb 280 | ; num_params : int 281 | ; params : Bind.t 282 | ; mutable meta : meta option 283 | } 284 | type 'm t = 'm u constraint 'm = [< mode] 285 | 286 | type cursor_type 287 | = No_cursor 288 | | Read_only 289 | 290 | type attr 291 | = Update_max_length of bool 292 | | Cursor_type of cursor_type 293 | | Prefetch_rows of int 294 | 295 | let error stmt = 296 | (B.mysql_stmt_errno stmt.raw, B.mysql_stmt_error stmt.raw) 297 | 298 | let fetch_field res i = 299 | coerce (ptr void) (ptr T.Field.t) (B.mysql_fetch_field_direct res i) 300 | 301 | let test_unsigned flags = 302 | Unsigned.UInt.logand flags T.Field.Flags.unsigned <> Unsigned.UInt.zero 303 | 304 | let alloc_result res n = 305 | let r = Bind.alloc n in 306 | for i = 0 to n - 1 do 307 | let bp = r.Bind.bind +@ i in 308 | let fp = fetch_field res i in 309 | let flags = getf (!@fp) T.Field.flags in 310 | let is_unsigned = if test_unsigned flags then '\001' else '\000' in 311 | setf (!@bp) T.Bind.buffer_type (getf (!@fp) T.Field.typ); 312 | setf (!@bp) T.Bind.length (r.Bind.length +@ i); 313 | setf (!@bp) T.Bind.is_null (r.Bind.is_null +@ i); 314 | setf (!@bp) T.Bind.is_unsigned is_unsigned; 315 | setf (!@bp) T.Bind.error (r.Bind.error +@ i) 316 | done; 317 | r 318 | 319 | let init mariadb raw = 320 | let np = B.mysql_stmt_param_count raw in 321 | { raw 322 | ; mariadb 323 | ; num_params = np 324 | ; params = Bind.alloc np 325 | ; meta = None 326 | } 327 | 328 | let bind_params stmt params = 329 | match Array.length params with 330 | | 0 -> `Ok stmt 331 | | _ -> 332 | let b = stmt.params in 333 | Array.iteri 334 | (fun at arg -> 335 | match arg with 336 | | `Null -> Bind.null b ~at 337 | | `Int i -> Bind.int b i ~at 338 | | `Int64 i -> Bind.int64 b i ~at 339 | | `UInt64 i -> Bind.int64 ~unsigned:true b (Unsigned.UInt64.to_int64 i) ~at 340 | | `Float x -> Bind.float b x ~at 341 | | `String s -> Bind.string b s ~at 342 | | `Bytes s -> Bind.blob b s ~at 343 | | `Time t -> Bind.time b t ~at) 344 | params; 345 | if B.mysql_stmt_bind_param stmt.raw b.Bind.bind then 346 | `Ok stmt 347 | else 348 | `Error (error stmt) 349 | 350 | (* From http://dev.mysql.com/doc/refman/5.7/en/mysql-stmt-fetch.html *) 351 | let buffer_size typ = 352 | match Bind.buffer_type_of_int typ with 353 | | `Null -> 0 354 | | `Tiny | `Year -> 1 355 | | `Short -> 2 356 | | `Int24 | `Long | `Float -> 4 357 | | `Long_long | `Double -> 8 358 | | `Decimal | `New_decimal | `String | `Var_string 359 | | `Tiny_blob | `Blob | `Medium_blob | `Long_blob | `Bit | `Json -> -1 360 | | `Time | `Date | `Datetime | `Timestamp -> Ctypes.sizeof T.Time.t 361 | 362 | let malloc count = 363 | let p = allocate_n char ~count in 364 | coerce (ptr char) (ptr void) p 365 | 366 | let alloc_buffer b fp i = 367 | let bp = b.Bind.bind +@ i in 368 | let typ = getf (!@bp) T.Bind.buffer_type in 369 | match buffer_size typ with 370 | | -1 -> 371 | let n = getf (!@fp) T.Field.max_length in 372 | setf (!@bp) T.Bind.buffer_length n; 373 | b.Bind.buffers.(i) <- malloc (Unsigned.ULong.to_int n); 374 | setf (!@bp) T.Bind.buffer b.Bind.buffers.(i) 375 | | n -> 376 | setf (!@bp) T.Bind.buffer_length (Unsigned.ULong.of_int n); 377 | b.Bind.buffers.(i) <- malloc n; 378 | setf (!@bp) T.Bind.buffer b.Bind.buffers.(i) 379 | 380 | let update_meta stmt = 381 | assert (stmt.meta = None); 382 | stmt.meta <- ( 383 | match B.mysql_stmt_result_metadata stmt.raw with 384 | | Some res -> 385 | let nf = B.mysql_num_fields res in 386 | Some 387 | { res 388 | ; result = alloc_result res nf 389 | } 390 | | None -> None); 391 | stmt.meta 392 | 393 | let bind_result stmt = 394 | match update_meta stmt with 395 | | Some meta -> 396 | let b = meta.result in 397 | let n = b.Bind.n in 398 | for i = 0 to n - 1 do 399 | let fp = fetch_field meta.res i in 400 | alloc_buffer b fp i 401 | done; 402 | if B.mysql_stmt_bind_result stmt.raw meta.result.Bind.bind then 403 | let meta = Res.meta meta.result meta.res b.Bind.buffers in 404 | let res = 405 | Res.create 406 | ~mariadb:stmt.mariadb 407 | ~stmt:stmt.raw 408 | ~meta () in 409 | `Ok res 410 | else 411 | `Error (error stmt) 412 | | None -> 413 | `Ok (Res.create ~mariadb:stmt.mariadb ~stmt:stmt.raw ()) 414 | end 415 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name mariadb) 3 | (synopsis "OCaml bindings for MariaDB") 4 | (libraries ctypes ctypes.stubs mariadb.bindings unix) 5 | (ctypes 6 | (external_library_name mariadb_or_mysql_client) 7 | (build_flags_resolver 8 | (vendored 9 | (c_library_flags :standard (:include ../mariadb_link_flags.sexp)))) 10 | (headers (preamble "%{read:../mariadb_preamble.h}")) 11 | (type_description 12 | (instance Types) 13 | (functor Ffi_bindings)) 14 | (function_description 15 | (concurrency unlocked) 16 | (instance Functions) 17 | (functor Ffi_bindings)) 18 | (generated_types Ffi_generated_types) 19 | (generated_entry_point Ffi_generated))) 20 | -------------------------------------------------------------------------------- /lib/field.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | module T = Ffi_generated.Types 4 | 5 | type value = 6 | [ `Null 7 | | `Int of int 8 | | `Int64 of Int64.t 9 | | `UInt64 of Unsigned.UInt64.t 10 | | `Float of float 11 | | `String of string 12 | | `Bytes of bytes 13 | | `Time of Time.t 14 | ] 15 | 16 | type t = 17 | { result : Bind.t 18 | ; pointer : T.Field.t ptr 19 | ; at : int 20 | } 21 | 22 | let create result pointer at = 23 | { result; pointer; at } 24 | 25 | let name field = 26 | getf (!@(field.pointer)) T.Field.name 27 | 28 | let null_value field = 29 | !@(field.result.Bind.is_null +@ field.at) = '\001' 30 | 31 | let can_be_null field = 32 | let flags = getf (!@(field.pointer)) T.Field.flags in 33 | Unsigned.UInt.logand flags T.Field.Flags.not_null = Unsigned.UInt.zero 34 | 35 | let is_unsigned field = 36 | let bp = field.result.Bind.bind +@ field.at in 37 | getf (!@bp) T.Bind.is_unsigned = '\001' 38 | 39 | let buffer field = 40 | let bp = field.result.Bind.bind +@ field.at in 41 | getf (!@bp) T.Bind.buffer 42 | 43 | let cast_to typ field = 44 | !@(coerce (ptr void) (ptr typ) (buffer field)) 45 | 46 | let to_bytes field = 47 | let buf = buffer field in 48 | let r = field.result in 49 | let lp = r.Bind.length +@ field.at in 50 | let len = Unsigned.ULong.to_int !@lp in 51 | let p = coerce (ptr void) (ptr char) buf in 52 | Bytes.init len (fun i -> !@(p +@ i)) 53 | 54 | let to_time field kind = 55 | let buf = buffer field in 56 | let tp = coerce (ptr void) (ptr T.Time.t) buf in 57 | let member f = Unsigned.UInt.to_int @@ getf (!@tp) f in 58 | let member_long f = Unsigned.ULong.to_int @@ getf (!@tp) f in 59 | { Time. 60 | year = member T.Time.year 61 | ; month = member T.Time.month 62 | ; day = member T.Time.day 63 | ; hour = member T.Time.hour 64 | ; minute = member T.Time.minute 65 | ; second = member T.Time.second 66 | ; microsecond = member_long T.Time.second_part 67 | ; kind 68 | } 69 | 70 | type to_string = [`Decimal | `New_decimal | `String | `Var_string | `Bit] 71 | type to_blob = [`Tiny_blob | `Blob | `Medium_blob | `Long_blob | `Json] 72 | type to_time = [`Time | `Date | `Datetime | `Timestamp] 73 | (* MariaDB implements the JSON datatype as an alias for LONGTEXT. It's 74 | * therefore * included it in to_blob above, so that the representation is 75 | * consitent in the public API. *) 76 | 77 | let convert field typ unsigned = 78 | let open Signed in 79 | let open Unsigned in 80 | match typ, unsigned with 81 | | `Null, _ -> `Null 82 | | `Year, _ 83 | | `Tiny, true -> `Int (int_of_char (cast_to char field)) 84 | | `Tiny, false -> `Int (cast_to schar field) 85 | | `Short, true -> `Int (cast_to int field) 86 | | `Short, false -> `Int (UInt.to_int (cast_to uint field)) 87 | | (`Int24 | `Long), true -> `Int (UInt32.to_int (cast_to uint32_t field)) 88 | | (`Int24 | `Long), false -> `Int (Int32.to_int (cast_to int32_t field)) 89 | | `Long_long, true -> `UInt64 (cast_to uint64_t field) 90 | | `Long_long, false -> `Int64 (cast_to int64_t field) 91 | | `Float, _ -> `Float (cast_to float field) 92 | | `Double, _ -> `Float (cast_to double field) 93 | | #to_string, _ -> `String (Bytes.to_string (to_bytes field)) 94 | | #to_blob, _ -> `Bytes (to_bytes field) 95 | | #to_time as t, _ -> `Time (to_time field t) 96 | 97 | let value field = 98 | let bp = field.result.Bind.bind +@ field.at in 99 | if null_value field then `Null 100 | else 101 | let typ = Bind.buffer_type_of_int @@ getf (!@bp) T.Bind.buffer_type in 102 | convert field typ (is_unsigned field) 103 | 104 | let err field ~info = 105 | failwith @@ "field '" ^ name field ^ "' is not " ^ info 106 | 107 | let int field = 108 | match value field with 109 | | `Int i -> i 110 | | `Int64 i -> Int64.to_int i 111 | | `UInt64 i -> Unsigned.UInt64.to_int i 112 | | _ -> err field ~info:"an integer" 113 | 114 | let int64 field = 115 | match value field with 116 | | `Int i -> Int64.of_int i 117 | | `Int64 i -> i 118 | | _ -> err field ~info:"a 64-bit integer" 119 | 120 | let uint64 field = 121 | match value field with 122 | | `UInt64 i -> i 123 | | _ -> err field ~info:"a 64-bit unsigned integer" 124 | 125 | let float field = 126 | match value field with 127 | | `Float x -> x 128 | | _ -> err field ~info:"a float" 129 | 130 | let string field = 131 | match value field with 132 | | `String s -> s 133 | | _ -> err field ~info:"a string" 134 | 135 | let bytes field = 136 | match value field with 137 | | `Bytes b -> b 138 | | _ -> err field ~info:"a byte string" 139 | 140 | let time field = 141 | match value field with 142 | | `Time t -> t 143 | | _ -> err field ~info:"a time value" 144 | 145 | let int_opt field = 146 | match value field with 147 | | `Int i -> Some i 148 | | `Int64 i -> Some (Int64.to_int i) 149 | | `UInt64 i -> Some (Unsigned.UInt64.to_int i) 150 | | `Null -> None 151 | | _ -> err field ~info:"a nullable integer" 152 | 153 | let int64_opt field = 154 | match value field with 155 | | `Int i -> Some (Int64.of_int i) 156 | | `Int64 i -> Some i 157 | | `Null -> None 158 | | _ -> err field ~info:"a nullable 64-bit integer" 159 | 160 | let uint64_opt field = 161 | match value field with 162 | | `UInt64 i -> Some i 163 | | `Null -> None 164 | | _ -> err field ~info:"a nullable 64-bit unsigned integer" 165 | 166 | let float_opt field = 167 | match value field with 168 | | `Float x -> Some x 169 | | `Null -> None 170 | | _ -> err field ~info:"a nullable float" 171 | 172 | let string_opt field = 173 | match value field with 174 | | `String s -> Some s 175 | | `Null -> None 176 | | _ -> err field ~info:"a nullable string" 177 | 178 | let bytes_opt field = 179 | match value field with 180 | | `Bytes b -> Some b 181 | | `Null -> None 182 | | _ -> err field ~info:"a nullable byte string" 183 | 184 | let time_opt field = 185 | match value field with 186 | | `Time t -> Some t 187 | | `Null -> None 188 | | _ -> err field ~info:"a nullable time value" 189 | -------------------------------------------------------------------------------- /lib/mariadb.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type error = int * string 3 | type 'a result = ('a, error) Stdlib.result 4 | 5 | module Time : sig 6 | type t 7 | 8 | val year : t -> int 9 | val month : t -> int 10 | val day : t -> int 11 | val hour : t -> int 12 | val minute : t -> int 13 | val second : t -> int 14 | val microsecond : t -> int 15 | 16 | val time : hour:int -> minute:int -> second:int 17 | -> ?microsecond:int -> unit -> t 18 | val local_timestamp : float -> t 19 | val utc_timestamp : float -> t 20 | val date : year:int -> month:int -> day:int -> unit -> t 21 | val datetime : year:int -> month:int -> day:int 22 | -> hour:int -> minute:int -> second:int 23 | -> ?microsecond:int -> unit -> t 24 | end 25 | 26 | module Field : sig 27 | type t 28 | 29 | type value = 30 | [ `Null 31 | | `Int of int 32 | | `Int64 of Int64.t 33 | | `UInt64 of Unsigned.UInt64.t 34 | | `Float of float 35 | | `String of string 36 | | `Bytes of bytes 37 | | `Time of Time.t 38 | ] 39 | 40 | val name : t -> string 41 | val value : t -> value 42 | val null_value : t -> bool 43 | val can_be_null : t -> bool 44 | 45 | val int : t -> int 46 | val int64 : t -> Int64.t 47 | val uint64 : t -> Unsigned.UInt64.t 48 | val float : t -> float 49 | val string : t -> string 50 | val bytes : t -> bytes 51 | val time : t -> Time.t 52 | 53 | val int_opt : t -> int option 54 | val int64_opt : t -> Int64.t option 55 | val uint64_opt : t -> Unsigned.UInt64.t option 56 | val float_opt : t -> float option 57 | val string_opt : t -> string option 58 | val bytes_opt : t -> bytes option 59 | val time_opt : t -> Time.t option 60 | end 61 | 62 | module Row : sig 63 | module type S = sig 64 | type t 65 | val build : int -> (int -> Field.t) -> t 66 | end 67 | 68 | module StringMap : Map.S with type key = string 69 | 70 | module Array : (S with type t = Field.t array) 71 | module Map : (S with type t = Field.t StringMap.t) 72 | module Hashtbl : (S with type t = (string, Field.t) Hashtbl.t) 73 | end 74 | 75 | module Res : sig 76 | type t 77 | 78 | val num_rows : t -> int 79 | val affected_rows : t -> int 80 | val insert_id : t -> int 81 | val fetch : (module Row.S with type t = 'r) -> t -> 'r option result 82 | end 83 | 84 | module Stmt : sig 85 | type t 86 | 87 | val execute : t -> Field.value array -> Res.t result 88 | val reset : t -> unit result 89 | val close : t -> unit result 90 | end 91 | 92 | type t 93 | 94 | type flag = 95 | | Compress 96 | | Found_rows 97 | | Ignore_sigpipe 98 | | Ignore_space 99 | | Interactive 100 | | Local_files 101 | | Multi_results 102 | | Multi_statements 103 | | No_schema 104 | | Odbc 105 | | Ssl 106 | | Remember_options 107 | 108 | type protocol = 109 | | Default 110 | | Tcp 111 | | Socket 112 | | Pipe 113 | | Memory 114 | 115 | type client_option = 116 | | Connect_timeout of int 117 | | Compress 118 | | Named_pipe of string 119 | | Init_command of string 120 | | Read_default_file of string 121 | | Read_default_group of string 122 | | Set_charset_dir of string 123 | | Set_charset_name of string 124 | | Local_infile of bool 125 | | Protocol of protocol 126 | | Shared_memory_base_name of string 127 | | Read_timeout of int 128 | | Write_timeout of int 129 | | Secure_auth of bool 130 | | Report_data_truncation of bool 131 | | Reconnect of bool 132 | | Ssl_verify_server_cert of bool 133 | | Plugin_dir of string 134 | | Default_auth of string 135 | | Bind of string 136 | | Ssl_key of string 137 | | Ssl_cert of string 138 | | Ssl_ca of string 139 | | Ssl_capath of string 140 | | Ssl_cipher of string 141 | | Ssl_crl of string 142 | | Ssl_crlpath of string 143 | | Connect_attr_reset 144 | | Connect_attr_add of string * string 145 | | Connect_attr_delete of string 146 | | Server_public_key of string 147 | | Enable_cleartext_plugin of bool 148 | 149 | type server_option = 150 | | Multi_statements of bool 151 | 152 | val connect : ?host:string 153 | -> ?user:string 154 | -> ?pass:string 155 | -> ?db:string -> ?port:int -> ?socket:string 156 | -> ?flags:flag list 157 | -> ?options:client_option list -> unit 158 | -> t result 159 | 160 | val close : t -> unit 161 | val library_end : unit -> unit 162 | val set_character_set : t -> string -> unit result 163 | val select_db : t -> string -> unit result 164 | val change_user : t -> string -> string -> string option -> unit result 165 | val get_server_info : t -> string 166 | val get_server_version : t -> int 167 | val get_host_info : t -> string 168 | val get_proto_info : t -> int 169 | val set_client_option : t -> client_option -> unit 170 | val set_server_option : t -> server_option -> unit result 171 | val ping : t -> unit result 172 | val autocommit : t -> bool -> unit result 173 | val start_txn : t -> unit result 174 | val commit : t -> unit result 175 | val rollback : t -> unit result 176 | val prepare : t -> string -> Stmt.t result 177 | end 178 | 179 | module B = Binding_wrappers 180 | 181 | module Common = Common 182 | module Blocking = Blocking 183 | module Nonblocking = Nonblocking 184 | 185 | let () = B.mysql_library_init 0 None None |> ignore 186 | -------------------------------------------------------------------------------- /lib/mariadb.mli: -------------------------------------------------------------------------------- 1 | (** OCaml-MariaDB is a library with OCaml bindings for MariaDB's 2 | libmysqlclient, including support for its nonblocking API. While you 3 | need MariaDB's libmysqlclient to build OCaml-MariaDB, it should be 4 | possible to use it with the regular libmysqlclient from MySQL, 5 | as long as you don't try to use the nonblocking API. 6 | 7 | These bindings are restricted to MariaDB's prepared statement APIs, 8 | as they provide support for typed query parameters and results. 9 | *) 10 | 11 | (** The MariaDB blocking interface. *) 12 | module type S = sig 13 | type error = int * string 14 | (** The type of errors that can result from MariaDB API calls. *) 15 | 16 | type 'a result = ('a, error) Stdlib.result 17 | (** The result of MariaDB API calls. *) 18 | 19 | (** Module representing MariaDB date- and time-related values. *) 20 | module Time : sig 21 | type t 22 | (** The type of time values. *) 23 | 24 | (** {2 Retrieval of time components} *) 25 | 26 | val year : t -> int 27 | val month : t -> int 28 | val day : t -> int 29 | val hour : t -> int 30 | val minute : t -> int 31 | val second : t -> int 32 | val microsecond : t -> int 33 | 34 | (** {2 Creation of time values} *) 35 | 36 | val time : hour:int -> minute:int -> second:int 37 | -> ?microsecond:int -> unit -> t 38 | val local_timestamp : float -> t 39 | val utc_timestamp : float -> t 40 | val date : year:int -> month:int -> day:int -> unit -> t 41 | val datetime : year:int -> month:int -> day:int 42 | -> hour:int -> minute:int -> second:int 43 | -> ?microsecond:int -> unit -> t 44 | end 45 | 46 | (** This module defines a database field retrieved by a query. *) 47 | module Field : sig 48 | type t 49 | (** The type of fields. *) 50 | 51 | type value = 52 | [ `Null 53 | | `Int of int 54 | | `Int64 of Int64.t 55 | | `UInt64 of Unsigned.UInt64.t 56 | | `Float of float 57 | | `String of string 58 | | `Bytes of bytes 59 | | `Time of Time.t 60 | ] 61 | 62 | val name : t -> string 63 | (** [name field] returns the field name of [field]. *) 64 | 65 | val value : t -> value 66 | (** [value field] returns the value associated with [field]. *) 67 | 68 | val null_value : t -> bool 69 | (** [null_value field] returns [true] if the value associated with 70 | [field] is [NULL]. *) 71 | 72 | val can_be_null : t -> bool 73 | (** [can_be_null field] returns [true] if values of [field] can assume 74 | the [NULL] value (i.e. the table definition does not specify 75 | [NOT NULL] for this field. *) 76 | 77 | (** {2 Value retrieval functions} 78 | 79 | The functions below simplify the unwrapping of OCaml values from 80 | fields. They raise [Failure] if the field is not of the expected 81 | type, but this should not be a problem as the type of a field is 82 | in all likelyhood known in advance by database users. 83 | *) 84 | 85 | val int : t -> int 86 | val int64 : t -> Int64.t 87 | val uint64 : t -> Unsigned.UInt64.t 88 | val float : t -> float 89 | val string : t -> string 90 | val bytes : t -> bytes 91 | val time : t -> Time.t 92 | 93 | val int_opt : t -> int option 94 | val int64_opt : t -> Int64.t option 95 | val uint64_opt : t -> Unsigned.UInt64.t option 96 | val float_opt : t -> float option 97 | val string_opt : t -> string option 98 | val bytes_opt : t -> bytes option 99 | val time_opt : t -> Time.t option 100 | end 101 | 102 | (** A module representing database rows. Rows can be retrieved as different 103 | data structures, which as passed to the row retrieval functions from the 104 | [Res] module. There's built-in support for fetching rows as arrays and 105 | maps and hash tables of field name to field, but any module conforming 106 | to [Row.S] can be provided to those functions. *) 107 | module Row : sig 108 | module type S = sig 109 | type t 110 | (** The type of database rows. *) 111 | 112 | val build : int -> (int -> Field.t) -> t 113 | (** [build n f] creates a row of [n] fields built by the results of 114 | [f 0], [f 1], ..., [f (n-1)]. *) 115 | end 116 | 117 | module StringMap : Map.S with type key = string 118 | 119 | module Array : (S with type t = Field.t array) 120 | (** Rows as field arrays. *) 121 | 122 | module Map : (S with type t = Field.t StringMap.t) 123 | (** Rows as field name to [Field.t] maps. *) 124 | 125 | module Hashtbl : (S with type t = (string, Field.t) Hashtbl.t) 126 | (** Rows as field name to [Field.t] hash tables. *) 127 | end 128 | 129 | (** The module containing operations on MariaDB query results. *) 130 | module Res : sig 131 | type t 132 | (** The type of query results. *) 133 | 134 | val num_rows : t -> int 135 | (** [num_rows res] returns the number of rows in result [res] after 136 | the execution of a [SELECT]-type query. *) 137 | 138 | val affected_rows : t -> int 139 | (** [affected_rows res] returns the number of affected rows in result [res] 140 | after the execution of an [INSERT] or [UPDATE]-type query. *) 141 | 142 | val insert_id : t -> int 143 | (** [insert_id res] returns the ID generated by a prepared statement on a table 144 | with a column having the [AUTO_INCREMENT] attribute. If the last query wasn't 145 | an [INSERT] or [UPDATE] statement or if the modified table does not have a column 146 | with the [AUTO_INCREMENT] attribute, this function will return zero. *) 147 | 148 | val fetch : (module Row.S with type t = 'r) -> t -> 'r option result 149 | (** [fetch (module M : Row.S) res] fetches the next available row 150 | from [res], returning it in as the data structure specified by 151 | module [M]. Returns [None] when no more rows are available. *) 152 | end 153 | 154 | (** The module contains operations on MariaDB prepared statements. *) 155 | module Stmt : sig 156 | type t 157 | (** The type of prepared statement. *) 158 | 159 | val execute : t -> Field.value array -> Res.t result 160 | (** [execute stmt params] executes the prepared statement [stmt] 161 | binding to it the query parameters [params] and returns a [Res.t], 162 | the query result. *) 163 | 164 | val reset : t -> unit result 165 | (** [reset stmt] reset the client and server state of [stmt] to what they 166 | were after [stmt] was prepared, and frees up any {!Res.t} produced by 167 | [stmt]. *) 168 | 169 | val close : t -> unit result 170 | (** [close stmt] closes the prepapred statement [stmt] and frees any 171 | allocated memory associated with it and its result. *) 172 | end 173 | 174 | type t 175 | (** The type of database handles. *) 176 | 177 | type flag = 178 | | Compress 179 | | Found_rows 180 | | Ignore_sigpipe 181 | | Ignore_space 182 | | Interactive 183 | | Local_files 184 | | Multi_results 185 | | Multi_statements 186 | | No_schema 187 | | Odbc 188 | | Ssl 189 | | Remember_options 190 | 191 | type protocol = 192 | | Default 193 | | Tcp 194 | | Socket 195 | | Pipe 196 | | Memory 197 | 198 | type client_option = 199 | | Connect_timeout of int 200 | | Compress 201 | | Named_pipe of string 202 | | Init_command of string 203 | | Read_default_file of string 204 | | Read_default_group of string 205 | | Set_charset_dir of string 206 | | Set_charset_name of string 207 | | Local_infile of bool 208 | | Protocol of protocol 209 | | Shared_memory_base_name of string 210 | | Read_timeout of int 211 | | Write_timeout of int 212 | | Secure_auth of bool 213 | | Report_data_truncation of bool 214 | | Reconnect of bool 215 | | Ssl_verify_server_cert of bool 216 | | Plugin_dir of string 217 | | Default_auth of string 218 | | Bind of string 219 | | Ssl_key of string 220 | | Ssl_cert of string 221 | | Ssl_ca of string 222 | | Ssl_capath of string 223 | | Ssl_cipher of string 224 | | Ssl_crl of string 225 | | Ssl_crlpath of string 226 | | Connect_attr_reset 227 | | Connect_attr_add of string * string 228 | | Connect_attr_delete of string 229 | | Server_public_key of string 230 | | Enable_cleartext_plugin of bool 231 | 232 | type server_option = 233 | | Multi_statements of bool 234 | 235 | val connect : ?host:string 236 | -> ?user:string 237 | -> ?pass:string 238 | -> ?db:string -> ?port:int -> ?socket:string 239 | -> ?flags:flag list 240 | -> ?options:client_option list -> unit 241 | -> t result 242 | (** Connect to a MariaDB server at the specified location with the specified 243 | flags and optionally select a database [db]. *) 244 | 245 | val close : t -> unit 246 | (** Close a database handle. *) 247 | 248 | val library_end : unit -> unit 249 | (** [library_end ()] should be called when you're done using the library. 250 | For maximum portability across MariaDB C client libraries, call this 251 | function only once, after you've [close]d all database handles. *) 252 | 253 | val set_character_set : t -> string -> unit result 254 | (** Sets the connection character set to the given parameter. *) 255 | 256 | val select_db : t -> string -> unit result 257 | (** [select_db mariadb db] changes the current database to [db]. *) 258 | 259 | val change_user : t -> string -> string -> string option -> unit result 260 | (** [change_user mariadb user pass db] changes the connection user to 261 | [user] with password [password] and optionally change to database 262 | [db]. *) 263 | 264 | val get_server_info : t -> string 265 | (** The version version as a string. *) 266 | 267 | val get_server_version : t -> int 268 | (** The server version encoded as [major * 10000 + minor * 100 + patch]. *) 269 | 270 | val get_host_info : t -> string 271 | (** A string representing the server host name and the connection type. *) 272 | 273 | val get_proto_info : t -> int 274 | (** The protocol version used for the connection. *) 275 | 276 | val set_client_option : t -> client_option -> unit 277 | (** Sets the given client option on the connection. *) 278 | 279 | val set_server_option : t -> server_option -> unit result 280 | (** Sets the given server option on the connection. *) 281 | 282 | val ping : t -> unit result 283 | (** Checks if the connection to the MariaDB server is working. If the 284 | [Reconnect] option is set and the connection is down, a reconnect 285 | attempt will be made. *) 286 | 287 | val autocommit : t -> bool -> unit result 288 | (** Sets autocommit mode on or off. *) 289 | 290 | val start_txn : t -> unit result 291 | 292 | val commit : t -> unit result 293 | (** Commits the current transaction. *) 294 | 295 | val rollback : t -> unit result 296 | (** Rolls back the current transaction. Does not work if autocommit is 297 | enabled. *) 298 | 299 | val prepare : t -> string -> Stmt.t result 300 | (** [prepare mariadb query] creates a prepared statement for [query]. The 301 | query may contain [?] as placeholders for parameters that can be bound 302 | by calling [Stmt.execute]. *) 303 | end 304 | 305 | (** The module for blocking MariaDB API calls. It should be possible to call 306 | functions from this module when using MySQL's or an older version of 307 | MariaDB's libmysqlclient. *) 308 | module Blocking : S 309 | 310 | (** This is the nonblocking MariaDB API. The interface contains a functor 311 | [Make] which, given a way to wait for a connection socket to be ready 312 | for reading or writing, returns a module with the same signature [S] 313 | as the traditional blocking API. *) 314 | module Nonblocking : sig 315 | module Status : sig 316 | type t 317 | (** The type of a nonblocking operation status. *) 318 | 319 | val create : ?read:bool 320 | -> ?write:bool 321 | -> ?except:bool 322 | -> ?timeout:bool 323 | -> unit -> t 324 | (** Create a new status indicating which events have occured on the 325 | MariaDB connection socket. *) 326 | 327 | val read : t -> bool 328 | (** Indicates if a read event has occurred. *) 329 | 330 | val write : t -> bool 331 | (** Indicates if a write event has occurred. *) 332 | 333 | val except : t -> bool 334 | (** Indicates if an exceptional condition event has occurred. *) 335 | 336 | val timeout : t -> bool 337 | (** Indicates if a timeout has occurred. *) 338 | end 339 | 340 | type t 341 | (** The type of nonblocking database handles. *) 342 | 343 | val fd : t -> Unix.file_descr 344 | (** The underlying file descriptor of the database connection. *) 345 | 346 | val timeout : t -> int 347 | (** If a nonblocking operation returns a [Status.t] indicating a timeout 348 | event, this function can be used to obtain the value, in seconds, 349 | after which the timeout has occured. *) 350 | 351 | val timeout_ms : t -> int 352 | (** Same as [timeout] but with millisecond resolution. *) 353 | 354 | (** Input module signature for the functor that generates a nonblocking 355 | connection module. *) 356 | module type Wait = sig 357 | (** A module defining a nonblocking I/O monadic interface. *) 358 | module IO : sig 359 | type 'a future 360 | 361 | val (>>=) : 'a future -> ('a -> 'b future) -> 'b future 362 | val return : 'a -> 'a future 363 | end 364 | 365 | val wait : t -> Status.t -> Status.t IO.future 366 | (** [wait mariadb status] must wait for the events set in [status] to 367 | occur in the [mariadb] connection and return a [Status.t] indicating 368 | which events have actually occured. *) 369 | end 370 | 371 | (* The MariaDB nonblocking interface. The exact same functions in the 372 | blocking interface are available here, but operations that could 373 | otherwise block there return a [future] value here. *) 374 | module type S = sig 375 | type error = int * string 376 | type 'a future 377 | type 'a result = ('a, error) Stdlib.result 378 | 379 | module Time : sig 380 | type t 381 | 382 | val year : t -> int 383 | val month : t -> int 384 | val day : t -> int 385 | val hour : t -> int 386 | val minute : t -> int 387 | val second : t -> int 388 | val microsecond : t -> int 389 | 390 | val time : hour:int -> minute:int -> second:int 391 | -> ?microsecond:int -> unit -> t 392 | val local_timestamp : float -> t 393 | val utc_timestamp : float -> t 394 | val date : year:int -> month:int -> day:int -> unit -> t 395 | val datetime : year:int -> month:int -> day:int 396 | -> hour:int -> minute:int -> second:int 397 | -> ?microsecond:int -> unit -> t 398 | end 399 | 400 | module Field : sig 401 | type t 402 | 403 | type value = 404 | [ `Null 405 | | `Int of int 406 | | `Int64 of Int64.t 407 | | `UInt64 of Unsigned.UInt64.t 408 | | `Float of float 409 | | `String of string 410 | | `Bytes of bytes 411 | | `Time of Time.t 412 | ] 413 | 414 | val name : t -> string 415 | val value : t -> value 416 | val null_value : t -> bool 417 | val can_be_null : t -> bool 418 | 419 | val int : t -> int 420 | val int64 : t -> Int64.t 421 | val uint64 : t -> Unsigned.UInt64.t 422 | val float : t -> float 423 | val string : t -> string 424 | val bytes : t -> bytes 425 | val time : t -> Time.t 426 | 427 | val int_opt : t -> int option 428 | val int64_opt : t -> Int64.t option 429 | val uint64_opt : t -> Unsigned.UInt64.t option 430 | val float_opt : t -> float option 431 | val string_opt : t -> string option 432 | val bytes_opt : t -> bytes option 433 | val time_opt : t -> Time.t option 434 | end 435 | 436 | module Row : sig 437 | module type S = sig 438 | type t 439 | val build : int -> (int -> Field.t) -> t 440 | end 441 | 442 | module StringMap : Map.S with type key = string 443 | 444 | module Array : (S with type t = Field.t array) 445 | module Map : (S with type t = Field.t StringMap.t) 446 | module Hashtbl : (S with type t = (string, Field.t) Hashtbl.t) 447 | end 448 | 449 | module Res : sig 450 | type t 451 | 452 | val num_rows : t -> int 453 | val affected_rows : t -> int 454 | val insert_id : t -> int 455 | val fetch : (module Row.S with type t = 'r) -> t 456 | -> 'r option result future 457 | end 458 | 459 | module Stmt : sig 460 | type t 461 | 462 | val execute : t -> Field.value array -> Res.t result future 463 | val reset : t -> unit result future 464 | val close : t -> unit result future 465 | end 466 | 467 | type t 468 | 469 | type flag = 470 | | Compress 471 | | Found_rows 472 | | Ignore_sigpipe 473 | | Ignore_space 474 | | Interactive 475 | | Local_files 476 | | Multi_results 477 | | Multi_statements 478 | | No_schema 479 | | Odbc 480 | | Ssl 481 | | Remember_options 482 | 483 | type protocol = 484 | | Default 485 | | Tcp 486 | | Socket 487 | | Pipe 488 | | Memory 489 | 490 | type client_option = 491 | | Connect_timeout of int 492 | | Compress 493 | | Named_pipe of string 494 | | Init_command of string 495 | | Read_default_file of string 496 | | Read_default_group of string 497 | | Set_charset_dir of string 498 | | Set_charset_name of string 499 | | Local_infile of bool 500 | | Protocol of protocol 501 | | Shared_memory_base_name of string 502 | | Read_timeout of int 503 | | Write_timeout of int 504 | | Secure_auth of bool 505 | | Report_data_truncation of bool 506 | | Reconnect of bool 507 | | Ssl_verify_server_cert of bool 508 | | Plugin_dir of string 509 | | Default_auth of string 510 | | Bind of string 511 | | Ssl_key of string 512 | | Ssl_cert of string 513 | | Ssl_ca of string 514 | | Ssl_capath of string 515 | | Ssl_cipher of string 516 | | Ssl_crl of string 517 | | Ssl_crlpath of string 518 | | Connect_attr_reset 519 | | Connect_attr_add of string * string 520 | | Connect_attr_delete of string 521 | | Server_public_key of string 522 | | Enable_cleartext_plugin of bool 523 | 524 | type server_option = 525 | | Multi_statements of bool 526 | 527 | val connect : ?host:string 528 | -> ?user:string 529 | -> ?pass:string 530 | -> ?db:string -> ?port:int -> ?socket:string 531 | -> ?flags:flag list 532 | -> ?options:client_option list -> unit 533 | -> t result future 534 | 535 | val close : t -> unit future 536 | val library_end : unit -> unit 537 | val set_character_set : t -> string -> unit result future 538 | val select_db : t -> string -> unit result future 539 | val change_user : t -> string -> string -> string option 540 | -> unit result future 541 | val get_server_info : t -> string 542 | val get_server_version : t -> int 543 | val get_host_info : t -> string 544 | val get_proto_info : t -> int 545 | val set_client_option : t -> client_option -> unit 546 | val set_server_option : t -> server_option -> unit result future 547 | val ping : t -> unit result future 548 | val autocommit : t -> bool -> unit result future 549 | val start_txn : t -> unit result future 550 | val commit : t -> unit result future 551 | val rollback : t -> unit result future 552 | val prepare : t -> string -> Stmt.t result future 553 | end 554 | 555 | (** Functor that generates a nonblocking database interface, given a 556 | nonblocking IO monad and a way to wait for connection socket events. *) 557 | module Make (W : Wait) : S with type 'a future := 'a W.IO.future 558 | end 559 | -------------------------------------------------------------------------------- /lib/nonblocking.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Util 3 | 4 | module B = Binding_wrappers 5 | module T = Ffi_generated.Types 6 | 7 | module Time = Time 8 | module Field = Field 9 | module Row = Row 10 | module Status = Wait_status 11 | 12 | type t = [`Nonblocking] Common.t 13 | type mariadb = t 14 | 15 | type error = Common.error 16 | type 'a result = [`Ok of 'a | `Wait of Status.t | `Error of error] 17 | 18 | type server_option = Common.server_option 19 | 20 | type 'a start = unit -> 'a result 21 | type 'a cont = Status.t -> 'a result 22 | type 'a nonblocking = 'a start * 'a cont 23 | 24 | let map_result f = function 25 | | `Ok x -> `Ok (f x) 26 | | `Wait _ as w -> w 27 | | `Error _ as e -> e 28 | 29 | type options = 30 | | Nonblocking 31 | 32 | let options raw = function 33 | | Nonblocking -> 34 | B.mysql_options raw T.Options.nonblock Ctypes.null 35 | 36 | let init () = 37 | match B.mysql_init () with 38 | | Some raw -> 39 | options raw Nonblocking; 40 | Some raw 41 | | None -> 42 | None 43 | 44 | let handle_void = function 45 | | 0 -> `Ok 46 | | s -> `Wait (Status.of_int s) 47 | 48 | let handle_opt mariadb = function 49 | | 0, Some _ -> `Ok mariadb 50 | | 0, None -> `Error (Common.error mariadb) 51 | | s, _ -> `Wait (Status.of_int s) 52 | 53 | let handle_int mariadb = function 54 | | 0, 0 -> `Ok () 55 | | 0, _ -> `Error (Common.error mariadb) 56 | | s, _ -> `Wait (Status.of_int s) 57 | 58 | let handle_char mariadb = function 59 | | 0, '\000' -> `Ok () 60 | | 0, _ -> `Error (Common.error mariadb) 61 | | s, _ -> `Wait (Status.of_int s) 62 | 63 | let connect_start mariadb = 64 | let open Common in 65 | handle_opt mariadb 66 | (B.mysql_real_connect_start 67 | mariadb.raw 68 | mariadb.host 69 | mariadb.user 70 | mariadb.pass 71 | mariadb.db 72 | mariadb.port 73 | mariadb.socket 74 | mariadb.flags) 75 | 76 | let connect_cont mariadb status = 77 | handle_opt mariadb 78 | (B.mysql_real_connect_cont mariadb.Common.raw (Status.to_int status)) 79 | 80 | let connect mariadb = 81 | (connect_start mariadb, connect_cont mariadb) 82 | 83 | let close_start mariadb = 84 | handle_void (B.mysql_close_start mariadb.Common.raw) 85 | 86 | let close_cont mariadb status = 87 | handle_void (B.mysql_close_cont mariadb.Common.raw status) 88 | 89 | let close mariadb = 90 | (close_start mariadb, close_cont mariadb) 91 | 92 | let fd mariadb = 93 | Obj.magic @@ B.mysql_get_socket mariadb.Common.raw 94 | 95 | let timeout mariadb = 96 | B.mysql_get_timeout_value mariadb.Common.raw 97 | 98 | let timeout_ms mariadb = 99 | B.mysql_get_timeout_value_ms mariadb.Common.raw 100 | 101 | let set_character_set_start mariadb = 102 | let charset = Option.some mariadb.Common.charset in 103 | handle_int mariadb 104 | (B.mysql_set_character_set_start mariadb.Common.raw charset) 105 | 106 | let set_character_set_cont mariadb status = 107 | handle_int mariadb (B.mysql_set_character_set_cont mariadb.Common.raw status) 108 | 109 | let set_character_set mariadb = 110 | (set_character_set_start mariadb, set_character_set_cont mariadb) 111 | 112 | let select_db_start mariadb = 113 | let db = Option.some mariadb.Common.db in 114 | handle_int mariadb (B.mysql_select_db_start mariadb.Common.raw db) 115 | 116 | let select_db_cont mariadb status = 117 | handle_int mariadb (B.mysql_select_db_cont mariadb.Common.raw status) 118 | 119 | let select_db mariadb = 120 | (select_db_start mariadb, select_db_cont mariadb) 121 | 122 | let change_user_start mariadb = 123 | let user = Option.some mariadb.Common.user in 124 | let pass = Option.some mariadb.Common.pass in 125 | handle_char mariadb 126 | (B.mysql_change_user_start mariadb.Common.raw user pass mariadb.Common.db) 127 | 128 | let change_user_cont mariadb status = 129 | handle_char mariadb (B.mysql_change_user_cont mariadb.Common.raw status) 130 | 131 | let change_user mariadb = 132 | (change_user_start mariadb, change_user_cont mariadb) 133 | 134 | let set_server_option_start mariadb opt = 135 | let opt = Common.int_of_server_option opt in 136 | handle_int mariadb (B.mysql_set_server_option_start mariadb.Common.raw opt) 137 | 138 | let set_server_option_cont mariadb status = 139 | handle_int mariadb (B.mysql_set_server_option_cont mariadb.Common.raw status) 140 | 141 | let set_server_option mariadb opt = 142 | (set_server_option_start mariadb opt, set_server_option_cont mariadb) 143 | 144 | let ping_start mariadb = 145 | handle_int mariadb (B.mysql_ping_start mariadb.Common.raw) 146 | 147 | let ping_cont mariadb status = 148 | handle_int mariadb (B.mysql_ping_cont mariadb.Common.raw status) 149 | 150 | let ping mariadb = 151 | (ping_start mariadb, ping_cont mariadb) 152 | 153 | let autocommit_start mariadb auto = 154 | handle_char mariadb (B.mysql_autocommit_start mariadb.Common.raw auto) 155 | 156 | let autocommit_cont mariadb status = 157 | handle_char mariadb (B.mysql_autocommit_cont mariadb.Common.raw status) 158 | 159 | let autocommit mariadb auto = 160 | (autocommit_start mariadb auto, autocommit_cont mariadb) 161 | 162 | let commit_start mariadb = 163 | handle_char mariadb (B.mysql_commit_start mariadb.Common.raw) 164 | 165 | let commit_cont mariadb status = 166 | handle_char mariadb (B.mysql_commit_cont mariadb.Common.raw status) 167 | 168 | let commit mariadb = 169 | (commit_start mariadb, commit_cont mariadb) 170 | 171 | let rollback_start mariadb = 172 | handle_char mariadb (B.mysql_rollback_start mariadb.Common.raw) 173 | 174 | let rollback_cont mariadb status = 175 | handle_char mariadb (B.mysql_rollback_cont mariadb.Common.raw status) 176 | 177 | let rollback mariadb = 178 | (rollback_start mariadb, rollback_cont mariadb) 179 | 180 | let start_txn_start mariadb = 181 | handle_int mariadb (B.mysql_real_query_start mariadb.Common.raw "START TRANSACTION") 182 | 183 | let start_txn_cont mariadb status = 184 | handle_int mariadb (B.mysql_real_query_cont mariadb.Common.raw status) 185 | 186 | let start_txn mariadb = 187 | (start_txn_start mariadb, start_txn_cont mariadb) 188 | 189 | let build_stmt mariadb raw = 190 | `Ok (Common.Stmt.init mariadb raw) 191 | 192 | type prep_stmt = 193 | { raw : B.stmt 194 | ; query : char Ctypes.ptr 195 | ; len : int 196 | } 197 | 198 | let handle_prepare mariadb stmt = function 199 | | 0, 0 -> build_stmt mariadb stmt.raw 200 | | 0, _ -> `Error (Common.error mariadb) 201 | | s, _ -> `Wait (Status.of_int s) 202 | 203 | let prepare_start mariadb stmt = 204 | handle_prepare mariadb stmt 205 | (B.mysql_stmt_prepare_start stmt.raw stmt.query stmt.len) 206 | 207 | let prepare_cont mariadb stmt status = 208 | handle_prepare mariadb stmt (B.mysql_stmt_prepare_cont stmt.raw status) 209 | 210 | let prepare mariadb query = 211 | match Common.stmt_init mariadb with 212 | | Some raw -> 213 | let stmt = 214 | { raw 215 | ; query = char_ptr_buffer_of_string query 216 | ; len = String.length query 217 | } in 218 | `Ok (prepare_start mariadb stmt, prepare_cont mariadb stmt) 219 | | None -> `Error (Common.error mariadb) 220 | 221 | module Res = struct 222 | type t = [`Nonblocking] Common.Res.t 223 | 224 | let num_rows = 225 | Common.Res.num_rows 226 | 227 | let affected_rows = 228 | Common.Res.affected_rows 229 | 230 | let insert_id = 231 | Common.Res.insert_id 232 | 233 | let handle_fetch (type t) (module R : Row.S with type t = t) res = function 234 | | 0, 0 -> 235 | `Ok (Common.Res.build_row (module R) res) 236 | | 0, 1 -> 237 | let stmt = res.Common.Res.stmt in 238 | `Error (B.mysql_stmt_errno stmt, B.mysql_stmt_error stmt) 239 | | 0, r when r = T.Return_code.no_data -> 240 | `Ok None 241 | | 0, r when r = T.Return_code.data_truncated -> 242 | `Error (2032, "truncated data") 243 | | s, _ -> 244 | `Wait (Status.of_int s) 245 | 246 | let fetch_start (type t) (module R : Row.S with type t = t) res = 247 | handle_fetch (module R) res (B.mysql_stmt_fetch_start res.Common.Res.stmt) 248 | 249 | let fetch_cont (type t) (module R : Row.S with type t = t) res status = 250 | handle_fetch (module R) res 251 | (B.mysql_stmt_fetch_cont res.Common.Res.stmt status) 252 | 253 | let fetch (type t) (module R : Row.S with type t = t) res = 254 | (fetch_start (module R) res, fetch_cont (module R) res) 255 | 256 | let handle_free = function 257 | | 0 -> `Ok 258 | | s -> `Wait (Status.of_int s) 259 | 260 | let free_start res = 261 | handle_free (B.mysql_free_result_start res) 262 | 263 | let free_cont res status = 264 | handle_free (B.mysql_free_result_cont res status) 265 | 266 | let free res = 267 | (free_start res, free_cont res) 268 | end 269 | 270 | module Stmt = struct 271 | type t = [`Nonblocking] Common.Stmt.t 272 | type 'a result = [`Ok of 'a | `Wait of Status.t | `Error of error] 273 | 274 | let init = 275 | Common.Stmt.init 276 | 277 | let handle_execute stmt = function 278 | | 0, 0 -> `Ok stmt 279 | | 0, _ -> `Error (Common.Stmt.error stmt) 280 | | s, _ -> `Wait (Status.of_int s) 281 | 282 | let execute_start stmt = 283 | handle_execute stmt (B.mysql_stmt_execute_start stmt.Common.Stmt.raw) 284 | 285 | let execute_cont stmt status = 286 | handle_execute stmt (B.mysql_stmt_execute_cont stmt.Common.Stmt.raw status) 287 | 288 | let execute stmt params = 289 | let n = B.mysql_stmt_param_count stmt.Common.Stmt.raw in 290 | let len = Array.length params in 291 | if n <> len then 292 | let err = sprintf "parameter count mismatch: %d (expected %d)" len n in 293 | `Error (2034, err) 294 | else 295 | match Common.Stmt.bind_params stmt params with 296 | | `Ok bound -> `Ok (execute_start bound, execute_cont bound) 297 | | `Error _ as err -> err 298 | 299 | let handle_store_result stmt = function 300 | | 0, 0 -> Common.Stmt.bind_result stmt 301 | | 0, _ -> `Error (Common.Stmt.error stmt) 302 | | s, _ -> `Wait (Status.of_int s) 303 | 304 | let store_result_start stmt = 305 | handle_store_result stmt 306 | (B.mysql_stmt_store_result_start stmt.Common.Stmt.raw) 307 | 308 | let store_result_cont stmt status = 309 | handle_store_result stmt 310 | (B.mysql_stmt_store_result_cont stmt.Common.Stmt.raw status) 311 | 312 | let store_result stmt = 313 | (store_result_start stmt, store_result_cont stmt) 314 | 315 | let handle_free_result stmt = function 316 | | 0, '\000' -> `Ok () 317 | | 0, _ -> `Error (Common.Stmt.error stmt) 318 | | s, _ -> `Wait (Status.of_int s) 319 | 320 | let free_result_start stmt = 321 | handle_free_result stmt (B.mysql_stmt_free_result_start stmt.Common.Stmt.raw) 322 | 323 | let free_result_cont stmt status = 324 | handle_free_result stmt (B.mysql_stmt_free_result_cont stmt.Common.Stmt.raw status) 325 | 326 | let free_result stmt = 327 | (free_result_start stmt, free_result_cont stmt) 328 | 329 | let handle_char_unit stmt = function 330 | | 0, '\000' -> `Ok () 331 | | 0, _ -> `Error (Common.Stmt.error stmt) 332 | | s, _ -> `Wait (Status.of_int s) 333 | 334 | let close_start stmt = 335 | handle_char_unit stmt (B.mysql_stmt_close_start stmt.Common.Stmt.raw) 336 | 337 | let close_cont stmt status = 338 | handle_char_unit stmt (B.mysql_stmt_close_cont stmt.Common.Stmt.raw status) 339 | 340 | let close stmt = 341 | (close_start stmt, close_cont stmt) 342 | 343 | let handle_reset stmt = function 344 | | 0, '\000' -> `Ok () 345 | | 0, _ -> `Error (Common.Stmt.error stmt) 346 | | s, _ -> `Wait (Status.of_int s) 347 | 348 | let reset_start stmt = 349 | handle_reset stmt (B.mysql_stmt_reset_start stmt.Common.Stmt.raw) 350 | 351 | let reset_cont stmt status = 352 | handle_reset stmt (B.mysql_stmt_reset_cont stmt.Common.Stmt.raw status) 353 | 354 | let reset stmt = 355 | (reset_start stmt, reset_cont stmt) 356 | 357 | let handle_next stmt = function 358 | | 0, 0 -> `Ok true 359 | | 0, -1 -> `Ok false 360 | | 0, _ -> `Error (Common.Stmt.error stmt) 361 | | s, _ -> `Wait (Status.of_int s) 362 | 363 | let next_result_start stmt = 364 | handle_next stmt (B.mysql_stmt_next_result_start stmt.Common.Stmt.raw) 365 | 366 | let next_result_cont stmt status = 367 | handle_next stmt (B.mysql_stmt_next_result_cont stmt.Common.Stmt.raw status) 368 | end 369 | 370 | module type Wait = sig 371 | module IO : sig 372 | type 'a future 373 | val (>>=) : 'a future -> ('a -> 'b future) -> 'b future 374 | val return : 'a -> 'a future 375 | end 376 | 377 | val wait : t -> Status.t -> Status.t IO.future 378 | end 379 | 380 | module type S = sig 381 | type error = int * string 382 | type 'a future 383 | type 'a result = ('a, error) Stdlib.result 384 | 385 | module Time : sig 386 | type t 387 | 388 | val year : t -> int 389 | val month : t -> int 390 | val day : t -> int 391 | val hour : t -> int 392 | val minute : t -> int 393 | val second : t -> int 394 | val microsecond : t -> int 395 | 396 | val time : hour:int -> minute:int -> second:int 397 | -> ?microsecond:int -> unit -> t 398 | val local_timestamp : float -> t 399 | val utc_timestamp : float -> t 400 | val date : year:int -> month:int -> day:int -> unit -> t 401 | val datetime : year:int -> month:int -> day:int 402 | -> hour:int -> minute:int -> second:int 403 | -> ?microsecond:int -> unit -> t 404 | end 405 | 406 | module Field : sig 407 | type t 408 | 409 | type value = 410 | [ `Null 411 | | `Int of int 412 | | `Int64 of Int64.t 413 | | `UInt64 of Unsigned.UInt64.t 414 | | `Float of float 415 | | `String of string 416 | | `Bytes of bytes 417 | | `Time of Time.t 418 | ] 419 | 420 | val name : t -> string 421 | val value : t -> value 422 | val null_value : t -> bool 423 | val can_be_null : t -> bool 424 | 425 | val int : t -> int 426 | val int64 : t -> Int64.t 427 | val uint64 : t -> Unsigned.UInt64.t 428 | val float : t -> float 429 | val string : t -> string 430 | val bytes : t -> bytes 431 | val time : t -> Time.t 432 | 433 | val int_opt : t -> int option 434 | val int64_opt : t -> Int64.t option 435 | val uint64_opt : t -> Unsigned.UInt64.t option 436 | val float_opt : t -> float option 437 | val string_opt : t -> string option 438 | val bytes_opt : t -> bytes option 439 | val time_opt : t -> Time.t option 440 | end 441 | 442 | module Row : sig 443 | module type S = sig 444 | type t 445 | val build : int -> (int -> Field.t) -> t 446 | end 447 | 448 | module StringMap : Map.S with type key = string 449 | 450 | module Array : (S with type t = Field.t array) 451 | module Map : (S with type t = Field.t StringMap.t) 452 | module Hashtbl : (S with type t = (string, Field.t) Hashtbl.t) 453 | end 454 | 455 | module Res : sig 456 | type t 457 | 458 | val num_rows : t -> int 459 | val affected_rows : t -> int 460 | val insert_id : t -> int 461 | val fetch : (module Row.S with type t = 'r) -> t -> 'r option result future 462 | end 463 | 464 | module Stmt : sig 465 | type t 466 | 467 | val execute : t -> Field.value array -> Res.t result future 468 | val reset : t -> unit result future 469 | val close : t -> unit result future 470 | end 471 | 472 | type t 473 | 474 | type flag = 475 | | Compress 476 | | Found_rows 477 | | Ignore_sigpipe 478 | | Ignore_space 479 | | Interactive 480 | | Local_files 481 | | Multi_results 482 | | Multi_statements 483 | | No_schema 484 | | Odbc 485 | | Ssl 486 | | Remember_options 487 | 488 | type protocol = 489 | | Default 490 | | Tcp 491 | | Socket 492 | | Pipe 493 | | Memory 494 | 495 | type client_option = 496 | | Connect_timeout of int 497 | | Compress 498 | | Named_pipe of string 499 | | Init_command of string 500 | | Read_default_file of string 501 | | Read_default_group of string 502 | | Set_charset_dir of string 503 | | Set_charset_name of string 504 | | Local_infile of bool 505 | | Protocol of protocol 506 | | Shared_memory_base_name of string 507 | | Read_timeout of int 508 | | Write_timeout of int 509 | | Secure_auth of bool 510 | | Report_data_truncation of bool 511 | | Reconnect of bool 512 | | Ssl_verify_server_cert of bool 513 | | Plugin_dir of string 514 | | Default_auth of string 515 | | Bind of string 516 | | Ssl_key of string 517 | | Ssl_cert of string 518 | | Ssl_ca of string 519 | | Ssl_capath of string 520 | | Ssl_cipher of string 521 | | Ssl_crl of string 522 | | Ssl_crlpath of string 523 | | Connect_attr_reset 524 | | Connect_attr_add of string * string 525 | | Connect_attr_delete of string 526 | | Server_public_key of string 527 | | Enable_cleartext_plugin of bool 528 | 529 | type server_option = 530 | | Multi_statements of bool 531 | 532 | val connect : ?host:string 533 | -> ?user:string 534 | -> ?pass:string 535 | -> ?db:string -> ?port:int -> ?socket:string 536 | -> ?flags:flag list 537 | -> ?options:client_option list -> unit 538 | -> t result future 539 | 540 | val close : t -> unit future 541 | val library_end : unit -> unit 542 | val set_character_set : t -> string -> unit result future 543 | val select_db : t -> string -> unit result future 544 | val change_user : t -> string -> string -> string option -> unit result future 545 | val get_server_info : t -> string 546 | val get_server_version : t -> int 547 | val get_host_info : t -> string 548 | val get_proto_info : t -> int 549 | val set_client_option : t -> client_option -> unit 550 | val set_server_option : t -> server_option -> unit result future 551 | val ping : t -> unit result future 552 | val autocommit : t -> bool -> unit result future 553 | val start_txn : t -> unit result future 554 | val commit : t -> unit result future 555 | val rollback : t -> unit result future 556 | val prepare : t -> string -> Stmt.t result future 557 | end 558 | 559 | module Make (W : Wait) : S with type 'a future = 'a W.IO.future = struct 560 | type t = mariadb 561 | 562 | type 'a future = 'a W.IO.future 563 | type error = int * string 564 | type 'a result = ('a, error) Stdlib.result 565 | 566 | let (>>=) = W.IO.(>>=) 567 | let return = W.IO.return 568 | let return_unit = return () 569 | 570 | type flag = Common.flag = 571 | | Compress 572 | | Found_rows 573 | | Ignore_sigpipe 574 | | Ignore_space 575 | | Interactive 576 | | Local_files 577 | | Multi_results 578 | | Multi_statements 579 | | No_schema 580 | | Odbc 581 | | Ssl 582 | | Remember_options 583 | 584 | type protocol = Common.protocol = 585 | | Default 586 | | Tcp 587 | | Socket 588 | | Pipe 589 | | Memory 590 | 591 | type client_option = Common.client_option = 592 | | Connect_timeout of int 593 | | Compress 594 | | Named_pipe of string 595 | | Init_command of string 596 | | Read_default_file of string 597 | | Read_default_group of string 598 | | Set_charset_dir of string 599 | | Set_charset_name of string 600 | | Local_infile of bool 601 | | Protocol of protocol 602 | | Shared_memory_base_name of string 603 | | Read_timeout of int 604 | | Write_timeout of int 605 | | Secure_auth of bool 606 | | Report_data_truncation of bool 607 | | Reconnect of bool 608 | | Ssl_verify_server_cert of bool 609 | | Plugin_dir of string 610 | | Default_auth of string 611 | | Bind of string 612 | | Ssl_key of string 613 | | Ssl_cert of string 614 | | Ssl_ca of string 615 | | Ssl_capath of string 616 | | Ssl_cipher of string 617 | | Ssl_crl of string 618 | | Ssl_crlpath of string 619 | | Connect_attr_reset 620 | | Connect_attr_add of string * string 621 | | Connect_attr_delete of string 622 | | Server_public_key of string 623 | | Enable_cleartext_plugin of bool 624 | 625 | type server_option = Common.server_option = 626 | | Multi_statements of bool 627 | 628 | let rec nonblocking m (r, k) = 629 | match r with 630 | | `Ok v -> return (Ok v) 631 | | `Wait s -> W.wait m s >>= fun s -> nonblocking m (k s, k) 632 | | `Error e -> return (Error e) 633 | 634 | let rec nonblocking' m (r, k) = 635 | match r with 636 | | `Ok -> return_unit 637 | | `Wait s -> W.wait m s >>= fun s -> nonblocking' m (k s, k) 638 | 639 | module Time = Time 640 | module Field = Field 641 | module Row = Row 642 | 643 | module Res = struct 644 | type t = Res.t 645 | 646 | let fetch (type t) (module R : Row.S with type t = t) res = 647 | nonblocking res.Common.Res.mariadb (Res.fetch (module R) res) 648 | 649 | let num_rows = 650 | Res.num_rows 651 | 652 | let affected_rows = 653 | Res.affected_rows 654 | 655 | let insert_id = 656 | Res.insert_id 657 | 658 | let free = (* not public, but to avoid shadowing *) 659 | Res.free 660 | end 661 | 662 | module Stmt = struct 663 | type t = Stmt.t 664 | 665 | let free_meta stmt = 666 | match stmt.Common.Stmt.meta with 667 | | None -> return () 668 | | Some { res; _ } -> 669 | stmt.Common.Stmt.meta <- None; 670 | nonblocking' stmt.Common.Stmt.mariadb (Res.free res) 671 | 672 | let free_meta_and_result stmt = 673 | match stmt.Common.Stmt.meta with 674 | | None -> return (Ok ()) 675 | | Some { res; _ } -> 676 | stmt.Common.Stmt.meta <- None; 677 | nonblocking' stmt.Common.Stmt.mariadb (Res.free res) >>= fun () -> 678 | nonblocking stmt.Common.Stmt.mariadb (Stmt.free_result stmt) 679 | 680 | let handle_execute = function 681 | | Ok stmt -> nonblocking stmt.Common.Stmt.mariadb (Stmt.store_result stmt) 682 | | Error _ as e -> return e 683 | 684 | let execute stmt ps = 685 | free_meta stmt >>= fun () -> 686 | match Stmt.execute stmt ps with 687 | | `Ok nb -> nonblocking stmt.Common.Stmt.mariadb nb >>= handle_execute 688 | | `Error e -> return (Error e) 689 | 690 | let reset stmt = 691 | free_meta_and_result stmt 692 | >>= function 693 | | Ok () -> nonblocking stmt.Common.Stmt.mariadb (Stmt.reset stmt) 694 | | Error _ as e -> return e 695 | 696 | let close stmt = 697 | free_meta_and_result stmt 698 | >>= function 699 | | Ok () -> nonblocking stmt.Common.Stmt.mariadb (Stmt.close stmt) 700 | | Error _ as e -> return e 701 | end 702 | 703 | let connect ?host ?user ?pass ?db ?(port=0) ?socket ?(flags=[]) ?(options=[]) () = 704 | match init () with 705 | | Some raw -> 706 | let mariadb = Common. 707 | { raw 708 | ; host = char_ptr_opt_buffer_of_string host 709 | ; port = port 710 | ; user = char_ptr_opt_buffer_of_string user 711 | ; pass = char_ptr_opt_buffer_of_string pass 712 | ; db = char_ptr_opt_buffer_of_string db 713 | ; socket = char_ptr_opt_buffer_of_string socket 714 | ; flags = Common.int_of_flags flags 715 | ; charset = None 716 | } in 717 | List.iter (Common.set_client_option mariadb) options; 718 | nonblocking mariadb (connect mariadb) 719 | | None -> 720 | return (Error (2008, "out of memory")) 721 | 722 | let close m = nonblocking' m (close m) 723 | 724 | let library_end = Common.library_end 725 | 726 | let set_character_set m c = 727 | let c = Some (char_ptr_buffer_of_string c) in 728 | m.Common.charset <- c; 729 | nonblocking m (set_character_set m) 730 | 731 | let select_db m db = 732 | m.Common.db <- Some (char_ptr_buffer_of_string db); 733 | nonblocking m (select_db m) 734 | 735 | let change_user m user pass db = 736 | m.Common.user <- Some (char_ptr_buffer_of_string user); 737 | m.Common.pass <- Some (char_ptr_buffer_of_string pass); 738 | m.Common.db <- char_ptr_opt_buffer_of_string db; 739 | nonblocking m (change_user m) 740 | 741 | let get_server_info = Common.get_server_info 742 | 743 | let get_server_version = Common.get_server_version 744 | 745 | let get_host_info = Common.get_host_info 746 | 747 | let get_proto_info = Common.get_proto_info 748 | 749 | let set_client_option = Common.set_client_option 750 | 751 | let set_server_option m opt = nonblocking m (set_server_option m opt) 752 | 753 | let ping m = nonblocking m (ping m) 754 | 755 | let autocommit m b = nonblocking m (autocommit m b) 756 | 757 | let start_txn m = nonblocking m (start_txn m) 758 | 759 | let commit m = nonblocking m (commit m) 760 | 761 | let rollback m = nonblocking m (rollback m) 762 | 763 | let prepare m q = 764 | match prepare m q with 765 | | `Ok nb -> nonblocking m nb 766 | | `Error e -> return (Error e) 767 | end 768 | -------------------------------------------------------------------------------- /lib/row.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | val build : int -> (int -> Field.t) -> t 4 | end 5 | 6 | module Array = struct 7 | type t = Field.t array 8 | let build n f = Array.init n f 9 | end 10 | 11 | module StringMap = Map.Make(struct 12 | type t = string 13 | let compare = compare 14 | end) 15 | 16 | module Map = struct 17 | type t = Field.t StringMap.t 18 | 19 | let build n f = 20 | let m = ref StringMap.empty in 21 | for i = 0 to n - 1 do 22 | let field = f i in 23 | m := StringMap.add (Field.name field) field !m 24 | done; 25 | !m 26 | end 27 | 28 | module Hashtbl = struct 29 | type t = (string, Field.t) Hashtbl.t 30 | 31 | let build n f = 32 | let h = Hashtbl.create n in 33 | for i = 0 to n - 1 do 34 | let field = f i in 35 | Hashtbl.replace h (Field.name field) field 36 | done; 37 | h 38 | end 39 | -------------------------------------------------------------------------------- /lib/time.ml: -------------------------------------------------------------------------------- 1 | type kind = [`Time | `Timestamp | `Date | `Datetime] 2 | 3 | type t = 4 | { year : int 5 | ; month : int 6 | ; day : int 7 | ; hour : int 8 | ; minute : int 9 | ; second : int 10 | ; microsecond : int 11 | ; kind : kind 12 | } 13 | 14 | let year t = t.year 15 | let month t = t.month 16 | let day t = t.day 17 | let hour t = t.hour 18 | let minute t = t.minute 19 | let second t = t.second 20 | let microsecond t = t.microsecond 21 | 22 | let time ~hour ~minute ~second ?(microsecond = 0) () = 23 | { year = 0 24 | ; month = 0 25 | ; day = 0 26 | ; hour 27 | ; minute 28 | ; second 29 | ; microsecond 30 | ; kind = `Time 31 | } 32 | 33 | let timestamp f t = 34 | let tf, ti = modf t in 35 | let tm = f ti in 36 | { year = tm.Unix.tm_year + 1900 37 | ; month = tm.Unix.tm_mon + 1 38 | ; day = tm.Unix.tm_mday 39 | ; hour = tm.Unix.tm_hour 40 | ; minute = tm.Unix.tm_min 41 | ; second = tm.Unix.tm_sec 42 | ; microsecond = int_of_float (1_000_000. *. tf) 43 | ; kind = `Timestamp 44 | } 45 | 46 | let local_timestamp t = 47 | timestamp Unix.localtime t 48 | 49 | let utc_timestamp t = 50 | timestamp Unix.gmtime t 51 | 52 | let date ~year ~month ~day () = 53 | { year 54 | ; month 55 | ; day 56 | ; hour = 0 57 | ; minute = 0 58 | ; second = 0 59 | ; microsecond = 0 60 | ; kind = `Date 61 | } 62 | 63 | let datetime ~year ~month ~day ~hour ~minute ~second ?(microsecond = 0) () = 64 | { year 65 | ; month 66 | ; day 67 | ; hour 68 | ; minute 69 | ; second 70 | ; microsecond 71 | ; kind = `Datetime 72 | } 73 | -------------------------------------------------------------------------------- /lib/util.ml: -------------------------------------------------------------------------------- 1 | let flip f = fun x y -> f y x 2 | 3 | let char_ptr_buffer_of_string s = 4 | let open Ctypes in 5 | let len = String.length s in 6 | let buf = allocate_n char ~count:(len + 1) in 7 | for i = 0 to len - 1 do 8 | let p = buf +@ i in 9 | p <-@ s.[i] 10 | done; 11 | (buf +@ len) <-@ '\000'; 12 | buf 13 | 14 | let char_ptr_opt_buffer_of_string = function 15 | | None -> None 16 | | Some s -> Some (char_ptr_buffer_of_string s) 17 | 18 | module Option = struct 19 | let map f = function 20 | | Some x -> Some (f x) 21 | | None -> None 22 | 23 | let some = function 24 | | Some x -> x 25 | | None -> failwith "Option.some: None" 26 | end 27 | -------------------------------------------------------------------------------- /lib/wait_status.ml: -------------------------------------------------------------------------------- 1 | module T = Ffi_generated.Types 2 | 3 | type t = int 4 | 5 | let create ?(read = false) ?(write = false) ?(except = false) 6 | ?(timeout = false) () = 7 | let w = ref 0 in 8 | if read then w := !w lor T.Wait_status.read; 9 | if write then w := !w lor T.Wait_status.write; 10 | if except then w := !w lor T.Wait_status.except; 11 | if timeout then w := !w lor T.Wait_status.timeout; 12 | !w 13 | 14 | let of_int w = w 15 | let to_int w = w 16 | 17 | let read w = w land T.Wait_status.read > 0 18 | let write w = w land T.Wait_status.write > 0 19 | let except w = w land T.Wait_status.except > 0 20 | let timeout w = w land T.Wait_status.timeout > 0 21 | -------------------------------------------------------------------------------- /mariadb.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "mariadb" 3 | maintainer: "Petter A. Urkedal " 4 | authors: "Andre Nathan " 5 | homepage: "https://github.com/ocaml-community/ocaml-mariadb" 6 | bug-reports: "https://github.com/ocaml-community/ocaml-mariadb/issues" 7 | license: "MIT" 8 | dev-repo: "git+https://github.com/ocaml-community/ocaml-mariadb.git" 9 | synopsis: "OCaml bindings for MariaDB" 10 | description: "OCaml-MariaDB provides Ctypes-based bindings for MariaDB, including its nonblocking API." 11 | 12 | build: [ 13 | ["dune" "subst"] {dev} 14 | ["dune" "build" "-p" name "-j" jobs 15 | "@install" 16 | "@runtest" {with-test} 17 | "@doc" {with-doc} 18 | ] 19 | ] 20 | depends: [ 21 | "ocaml" {>= "4.07.0"} 22 | "ctypes" {>= "0.13.0"} 23 | "conf-mariadb" 24 | "conf-gcc" 25 | "conf-pkg-config" 26 | "dune" {>= "3.15.0"} 27 | "dune-configurator" 28 | "async" {with-test} 29 | "lwt" {with-test} 30 | ] 31 | conflicts: [ "ocaml-option-bytecode-only" ] 32 | -------------------------------------------------------------------------------- /tests/README.md: -------------------------------------------------------------------------------- 1 | This directory contains the test suite. The main code split up according to 2 | whether the tests are using the blocking or non-blocking API, and for the 3 | latter there are instances depending on the concurrency library: 4 | 5 | | Directory | Description 6 | | --------- | ----------- 7 | | nonblocking | Abstract tests suite implementation. 8 | | blocking | Tests the blocking and nonblocking APIs without concurrency. 9 | | nonblocking-async | Tests the nonblocking API using async. 10 | | nonblocking-lwt | Tests the nonblocking API using Lwt. 11 | 12 | Tests require access to a MariaDB or MySQL database, which must be declared 13 | by setting the following environment variables: 14 | 15 | | Environment variable | Description 16 | | -------------------- | ----------- 17 | | `OCAML_MARIADB_HOST` | Host name or IP address to connect to. 18 | | `OCAML_MARIADB_PORT` | Port number to connect to. 19 | | `OCAML_MARIADB_USER` | Authenticate as the given user. 20 | | `OCAML_MARIADB_PASS` | Authenticate with the given password. 21 | | `OCAML_MARIADB_DB` | Connect to the given database. 22 | 23 | These tests will only run if `OCAML_MARIADB_DB` has been set, but the 24 | executable will still be built. The remaining variables are optional. 25 | -------------------------------------------------------------------------------- /tests/blocking/blocking_testsuite.ml: -------------------------------------------------------------------------------- 1 | module S = Mariadb.Nonblocking.Status 2 | 3 | module Wait = struct 4 | 5 | module IO = struct 6 | type 'a future = 'a 7 | let (>>=) x f = f x 8 | let return x = x 9 | end 10 | 11 | let return = IO.return 12 | 13 | let wait mariadb status = 14 | let fd = Mariadb.Nonblocking.fd mariadb in 15 | let rfd = if S.read status then [fd] else [] in 16 | let wfd = if S.write status then [fd] else [] in 17 | let efd = if S.except status then [fd] else [] in 18 | let timeout = 19 | if S.timeout status 20 | then float @@ Mariadb.Nonblocking.timeout mariadb 21 | else -1.0 in 22 | try 23 | let rfd, wfd, efd = Unix.select rfd wfd efd timeout in 24 | return @@ 25 | S.create 26 | ~read:(rfd <> []) 27 | ~write:(wfd <> []) 28 | ~except:(efd <> []) 29 | () 30 | with Unix.Unix_error (_, _, _) -> 31 | return @@ S.create ~timeout: true () 32 | 33 | end 34 | 35 | (* Test for the blocking API. *) 36 | module Test_blocking = 37 | Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Blocking) 38 | 39 | (* Test for the non-blocking API without concurrency. *) 40 | module Test_nonblocking = 41 | Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Nonblocking.Make (Wait)) 42 | 43 | let () = 44 | Test_blocking.main (); 45 | Test_nonblocking.main () 46 | -------------------------------------------------------------------------------- /tests/blocking/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name blocking_testsuite) 3 | (enabled_if (<> %{env:OCAML_MARIADB_DB=__none__} __none__)) 4 | (deps 5 | (env_var OCAML_MARIADB_HOST) 6 | (env_var OCAML_MARIADB_PORT) 7 | (env_var OCAML_MARIADB_USER) 8 | (env_var OCAML_MARIADB_PASS) 9 | (env_var OCAML_MARIADB_DB)) 10 | (libraries mariadb nonblocking_testsuite unix)) 11 | -------------------------------------------------------------------------------- /tests/nonblocking-async/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name nonblocking_testsuite_async) 3 | (build_if %{lib-available:async}) 4 | (enabled_if (<> %{env:OCAML_MARIADB_DB=__none__} __none__)) 5 | (deps 6 | (env_var OCAML_MARIADB_HOST) 7 | (env_var OCAML_MARIADB_PORT) 8 | (env_var OCAML_MARIADB_USER) 9 | (env_var OCAML_MARIADB_PASS) 10 | (env_var OCAML_MARIADB_DB)) 11 | (libraries async mariadb nonblocking_testsuite threads)) 12 | -------------------------------------------------------------------------------- /tests/nonblocking-async/nonblocking_testsuite_async.ml: -------------------------------------------------------------------------------- 1 | module Caml_bytes = Bytes 2 | open Core 3 | open Async 4 | 5 | module S = Mariadb.Nonblocking.Status 6 | 7 | module Wait = struct 8 | 9 | module IO = struct 10 | type 'a future = 'a Deferred.t 11 | let (>>=) = (>>=) 12 | let return = Deferred.return 13 | end 14 | 15 | let is_ready = function 16 | | `Ready -> true 17 | | `Bad_fd | `Closed -> false 18 | 19 | let ready (rt, wt, tt) = 20 | let r = ref false in 21 | let w = ref false in 22 | let t = ref false in 23 | let rc = Deferred.choice rt (fun x -> r := is_ready x) in 24 | let wc = Deferred.choice wt (fun x -> w := is_ready x) in 25 | let tc = Deferred.choice tt (fun _ -> t := true) in 26 | Deferred.enabled [rc; wc; tc] >>= fun f -> 27 | ignore (f ()); 28 | Deferred.return (!r, !w, !t) 29 | 30 | let wait mariadb status = 31 | let fd = 32 | Fd.create 33 | (Fd.Kind.Socket `Active) 34 | (Mariadb.Nonblocking.fd mariadb) 35 | (Info.of_string "") in 36 | assert (S.read status || S.write status || S.timeout status); 37 | let idle = Deferred.never () in 38 | let rt = if S.read status then Fd.ready_to fd `Read else idle in 39 | let wt = if S.write status then Fd.ready_to fd `Write else idle in 40 | let tt = 41 | let tmout = float (Mariadb.Nonblocking.timeout mariadb) in 42 | if S.timeout status then Clock.after (Time_float.Span.of_sec tmout) 43 | else idle in 44 | ready (rt, wt, tt) >>= fun (read, write, timeout) -> 45 | Fd.close ~file_descriptor_handling:Fd.Do_not_close_file_descriptor fd 46 | >>= fun () -> 47 | Deferred.return @@ S.create ~read ~write ~timeout () 48 | end 49 | 50 | module Test = 51 | Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Nonblocking.Make (Wait)) 52 | 53 | let _main : unit Deferred.t = Test.main () >>= fun () -> Shutdown.exit 0 54 | 55 | let () = never_returns (Scheduler.go ()) 56 | -------------------------------------------------------------------------------- /tests/nonblocking-lwt/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name nonblocking_testsuite_lwt) 3 | (build_if %{lib-available:lwt}) 4 | (enabled_if (<> %{env:OCAML_MARIADB_DB=__none__} __none__)) 5 | (deps 6 | (env_var OCAML_MARIADB_HOST) 7 | (env_var OCAML_MARIADB_PORT) 8 | (env_var OCAML_MARIADB_USER) 9 | (env_var OCAML_MARIADB_PASS) 10 | (env_var OCAML_MARIADB_DB)) 11 | (libraries mariadb lwt lwt.unix nonblocking_testsuite)) 12 | -------------------------------------------------------------------------------- /tests/nonblocking-lwt/nonblocking_testsuite_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module S = Mariadb.Nonblocking.Status 4 | 5 | module Wait = struct 6 | 7 | module IO = struct 8 | type 'a future = 'a Lwt.t 9 | let (>>=) = (>>=) 10 | let return = Lwt.return 11 | end 12 | 13 | let wait mariadb status = 14 | let fd = Lwt_unix.of_unix_file_descr @@ Mariadb.Nonblocking.fd mariadb in 15 | assert (S.read status || S.write status || S.timeout status); 16 | let idle, _ = Lwt.task () in 17 | let rt = if S.read status then Lwt_unix.wait_read fd else idle in 18 | let wt = if S.write status then Lwt_unix.wait_write fd else idle in 19 | let tt = 20 | match S.timeout status, Mariadb.Nonblocking.timeout mariadb with 21 | | true, 0 -> Lwt.return () 22 | | true, tmout -> Lwt_unix.timeout (float tmout) 23 | | false, _ -> idle in 24 | Lwt.catch 25 | (fun () -> 26 | Lwt.nchoose [rt; wt; tt] >>= fun _ -> 27 | Lwt.return @@ 28 | S.create 29 | ~read:(Lwt_unix.readable fd) 30 | ~write:(Lwt_unix.writable fd) 31 | ()) 32 | (function 33 | | Lwt_unix.Timeout -> Lwt.return @@ S.create ~timeout:true () 34 | | e -> Lwt.fail e) 35 | 36 | end 37 | 38 | module Test = 39 | Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Nonblocking.Make (Wait)) 40 | 41 | let () = Lwt_main.run (Test.main ()) 42 | -------------------------------------------------------------------------------- /tests/nonblocking/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name nonblocking_testsuite) 3 | (libraries mariadb)) 4 | -------------------------------------------------------------------------------- /tests/nonblocking/nonblocking_testsuite.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module type IO = sig 4 | type 'a future 5 | val (>>=) : 'a future -> ('a -> 'b future) -> 'b future 6 | val return : 'a -> 'a future 7 | end 8 | 9 | module Make 10 | (IO : IO) 11 | (M : Mariadb.Nonblocking.S with type 'a future := 'a IO.future) = 12 | struct 13 | open IO 14 | 15 | let (>|=) m f = m >>= fun x -> return (f x) 16 | 17 | let env var def = try Sys.getenv var with Not_found -> def 18 | 19 | let die_f ppf = ksprintf (fun msg -> eprintf "%s\n%!" msg; exit 2) ppf 20 | 21 | let or_die where = function 22 | | Ok r -> return r 23 | | Error (i, e) -> eprintf "%s: (%d) %s\n%!" where i e; exit 2 24 | 25 | let rec iter_s_list f = function 26 | | [] -> return () 27 | | x :: xs -> f x >>= fun () -> iter_s_list f xs 28 | 29 | let rec map_s_list f = function 30 | | [] -> return [] 31 | | x :: xs -> f x >>= fun y -> map_s_list f xs >|= fun ys -> y :: ys 32 | 33 | let connect () = 34 | M.connect 35 | ~host:(env "OCAML_MARIADB_HOST" "localhost") 36 | ~user:(env "OCAML_MARIADB_USER" "root") 37 | ~pass:(env "OCAML_MARIADB_PASS" "") 38 | ~db:(env "OCAML_MARIADB_DB" "mysql") 39 | ~port:(int_of_string (env "OCAML_MARIADB_PORT" "0")) () 40 | 41 | let rec repeat n f = 42 | if n = 0 then return () else f () >>= fun () -> repeat (n - 1) f 43 | 44 | let string_of_param_type = function 45 | | `Int -> "integer" 46 | | `Float -> "double" 47 | | `String | `Bytes -> "char" 48 | | `Time -> "datetime" 49 | 50 | let random_string () = 51 | let n = Random.int (1 lsl Random.int 8) in 52 | String.init n (fun _ -> "ACGT".[Random.int 4]) 53 | 54 | let random_param_type _ = 55 | match Random.int 5 with 56 | | 0 -> `Int 57 | | 1 -> `Float 58 | | 2 -> `String 59 | | 3 -> `Bytes 60 | | 4 -> `Time 61 | | _ -> assert false 62 | 63 | let random_param param_type = 64 | if Random.int 6 = 0 then `Null else 65 | match param_type with 66 | | `Int -> `Int (Random.bits ()) 67 | | `Float -> `Float (ldexp (Random.float 2.0 -. 1.0) (Random.int 16)) 68 | | `String -> `String (random_string ()) 69 | | `Bytes -> `Bytes (Bytes.of_string (random_string ())) 70 | | `Time -> `Time (M.Time.utc_timestamp (Random.float 1577833200.0)) 71 | 72 | let make_nary_select_stmt dbh param_types = 73 | let buf = Buffer.create 64 in 74 | Buffer.add_string buf "SELECT "; 75 | for i = 0 to Array.length param_types - 1 do 76 | if i > 0 then Buffer.add_string buf ", "; 77 | bprintf buf "CAST(? AS %s)" (string_of_param_type param_types.(i)) 78 | (* CAST is only used as a type annotation to prevent the parameters from 79 | * being cast. *) 80 | done; 81 | M.prepare dbh (Buffer.contents buf) >>= or_die "prepare" 82 | 83 | let string_of_timestamp t = 84 | let y, mon, day = M.Time.(year t, month t, day t) in 85 | let h, m, s, us = M.Time.(hour t, minute t, second t, microsecond t) in 86 | sprintf "%04d-%02d-%02dT%02d:%02d:%02d.%06d" y mon day h m s us 87 | 88 | let string_of_value = function 89 | | `Null -> "NULL" 90 | | `Int i -> sprintf "(%d : int)" i 91 | | `Int64 i -> sprintf "(%Ld : int64)" i 92 | | `UInt64 i -> sprintf "(%s : uint64)" (Unsigned.UInt64.to_string i) 93 | | `Float x -> sprintf "(%.8g : float)" x 94 | | `String s -> sprintf "(%S : string)" s 95 | | `Bytes s -> sprintf "(%S : bytes)" (Bytes.to_string s) 96 | | `Time t -> string_of_timestamp t 97 | 98 | let equal_float x x' = 99 | abs_float (x -. x') /. (abs_float (x +. x') +. epsilon_float) < 1e-6 100 | 101 | let equal_time t t' = 102 | let open M.Time in let open Stdlib in 103 | (* Treat `Datetime and `Timestamp as equal. *) 104 | year t = year t' && month t = month t' && day t = day t' && 105 | hour t = hour t' && minute t = minute t' && second t = second t' 106 | 107 | let equal_field v v' = 108 | match v, v' with 109 | | `Null, `Null -> true 110 | | `Null, _ | _, `Null -> false 111 | | `Int i, `Int i' -> i = i' 112 | | `Int i, `Float x | `Float x, `Int i -> float_of_int i = x 113 | | `Int64 i, `Int64 i' -> Int64.equal i i' 114 | | `Int64 i, `Int x | `Int x, `Int64 i -> Int64.(equal i (of_int x)) 115 | | `Int64 i, `Float x | `Float x, `Int64 i -> Int64.to_float i = x 116 | | `UInt64 i, `UInt64 i' -> Unsigned.UInt64.equal i i' 117 | | `UInt64 i, `Int x | `Int x, `UInt64 i -> Unsigned.UInt64.(equal i (of_int x)) 118 | | `UInt64 i, `Float x | `Float x, `UInt64 i -> Int64.to_float (Unsigned.UInt64.to_int64 i) = x 119 | | `UInt64 i, `Int64 x | `Int64 x, `UInt64 i -> Int64.equal (Unsigned.UInt64.to_int64 i) x 120 | | `Int _, _ | _, `Int _ -> false 121 | | `Int64 _, _ | _, `Int64 _ -> false 122 | | `UInt64 _, _ | _, `UInt64 _ -> false 123 | | `Float x, `Float x' -> equal_float x x' 124 | | `Float _, _ | _, `Float _ -> false 125 | | `String s, `String s' -> s = s' 126 | | `String s, `Bytes s' | `Bytes s', `String s -> s = Bytes.to_string s' 127 | | `String _, _ | _, `String _ -> false 128 | | `Bytes s, `Bytes s' -> s = s' 129 | | `Bytes _, _ | _, `Bytes _ -> false 130 | | `Time t, `Time t' -> equal_time t t' 131 | 132 | let assert_field_equal v v' = 133 | if not (equal_field v v') then begin 134 | eprintf "Parameter %s came back as %s.\n%!" 135 | (string_of_value v) (string_of_value v'); 136 | exit 2 137 | end 138 | 139 | let execute_no_data stmt = 140 | M.Stmt.execute stmt [||] >>= or_die "execute" >|= fun res -> 141 | assert (M.Res.num_rows res = 0) 142 | 143 | let fetch_single_row res = 144 | assert (M.Res.num_rows res = 1); 145 | M.Res.fetch (module M.Row.Array) res >>= or_die "fetch" >|= fun row -> 146 | (match row with 147 | | None -> failwith "expecting one row, no rows returned" 148 | | Some a -> a) 149 | 150 | let test_server_properties () = 151 | connect () >>= or_die "connect" >>= fun dbh -> 152 | let v = M.get_server_version dbh in 153 | assert (v >= 10000 && v < 10000000); (* 1 <= major_version < 1000 *) 154 | let info = M.get_server_info dbh in 155 | let info' = sprintf "%d.%d.%d" (v / 10000) (v / 100 mod 100) (v mod 100) in 156 | assert (List.hd (String.split_on_char '-' info) = info'); 157 | let host = M.get_host_info dbh in 158 | assert (String.length host < 1024); 159 | for i = 0 to String.length host - 1 do 160 | match host.[i] with 161 | | '\x20'..'\x7f' -> () 162 | | _ -> die_f "result from get_host_info looks suspicious: %S" host 163 | done; 164 | let proto = M.get_proto_info dbh in 165 | assert (proto >= 0 && proto < 10000); (* it's 10 for MariaDB 10.11.8 *) 166 | return () 167 | 168 | let test_insert_id () = 169 | connect () >>= or_die "connect" >>= fun dbh -> 170 | M.prepare dbh 171 | "CREATE TEMPORARY TABLE ocaml_mariadb_test \ 172 | (id integer PRIMARY KEY AUTO_INCREMENT)" 173 | >>= or_die "prepare" 174 | >>= fun create_table_stmt -> 175 | execute_no_data create_table_stmt >>= fun () -> 176 | M.prepare dbh "INSERT INTO ocaml_mariadb_test VALUES (DEFAULT)" 177 | >>= or_die "prepare" 178 | >>= fun insert_stmt -> 179 | let rec check_inserts_from expected_id = 180 | if expected_id > 5 then return () else 181 | M.Stmt.execute insert_stmt [||] >>= or_die "insert" >>= fun res -> 182 | assert (M.Res.num_rows res = 0); 183 | assert (M.Res.insert_id res = expected_id); 184 | check_inserts_from (expected_id + 1) 185 | in 186 | check_inserts_from 1 >>= fun () -> 187 | M.close dbh 188 | 189 | let test_txn () = 190 | connect () >>= or_die "connect" >>= fun dbh -> 191 | 192 | M.prepare dbh 193 | "CREATE TEMPORARY TABLE ocaml_mariadb_test (i integer PRIMARY KEY)" 194 | >>= or_die "prepare create_table_stmt" 195 | >>= fun create_table_stmt -> 196 | execute_no_data create_table_stmt >>= fun () -> 197 | 198 | map_s_list (fun s -> M.prepare dbh s >>= or_die "prepare") 199 | ["INSERT INTO ocaml_mariadb_test VALUES (1), (2)"; 200 | "INSERT INTO ocaml_mariadb_test SELECT i + 10 FROM ocaml_mariadb_test"] 201 | >>= fun insert_stmts -> 202 | M.prepare dbh "SELECT CAST(sum(i) AS integer) FROM ocaml_mariadb_test" 203 | >>= or_die "prepare sum" 204 | >>= fun sum_stmt -> 205 | 206 | M.start_txn dbh >>= or_die "start_txn" >>= fun () -> 207 | iter_s_list execute_no_data insert_stmts >>= fun () -> 208 | M.rollback dbh >>= or_die "rollback" >>= fun () -> 209 | M.Stmt.execute sum_stmt [||] >>= or_die "execute" >>= fun res -> 210 | fetch_single_row res >>= fun row -> 211 | assert (Array.length row = 1 && M.Field.null_value row.(0)); 212 | 213 | M.start_txn dbh >>= or_die "start_txn" >>= fun () -> 214 | iter_s_list execute_no_data insert_stmts >>= fun () -> 215 | M.commit dbh >>= or_die "rollback" >>= fun () -> 216 | M.Stmt.execute sum_stmt [||] >>= or_die "execute" >>= fun res -> 217 | fetch_single_row res >>= fun row -> 218 | assert (Array.length row = 1 && M.Field.int row.(0) = 26); 219 | 220 | M.close dbh 221 | 222 | (* Make sure the conversion between timestamps and strings are consistent 223 | * between MariaDB and OCaml. By sending timestamps to be compared as binary 224 | * and as string, this also verifies the MYSQL_TIME encoding. *) 225 | let test_datetime_and_string_conv dbh = 226 | let t = M.Time.utc_timestamp (Random.float 1577833200.0) in 227 | let s = string_of_timestamp t in 228 | M.prepare dbh "SELECT CAST(? AS DATETIME), DATE_FORMAT(?, '%Y-%m-%dT%T.%f')" 229 | >>= or_die "prepare" >>= fun stmt -> 230 | let params = [|`String s; `Time t|] in 231 | M.Stmt.execute stmt params >>= or_die "Stmt.execute" >>= fun res -> 232 | assert (M.Res.num_rows res = 1); 233 | M.Res.fetch (module M.Row.Array) res >>= or_die "Res.fetch" >>= fun row -> 234 | M.Stmt.close stmt 235 | >>= or_die "Stmt.close in test_datetime_and_string_conv" 236 | >|= fun () -> 237 | (match row with 238 | | Some [|t'; s'|] -> 239 | assert (equal_time t M.Field.(time t')); 240 | assert (s = M.Field.(string s')) 241 | | _ -> assert false) 242 | 243 | let test_random_select () = 244 | let stmt_cache = Hashtbl.create 7 in 245 | connect () >>= or_die "connect" >>= fun dbh -> 246 | test_datetime_and_string_conv dbh >>= fun () -> 247 | repeat 100 begin fun () -> 248 | let n = Random.int (1 lsl Random.int 8) + 1 in 249 | let param_types = Array.init n random_param_type in 250 | let params = Array.map random_param param_types in 251 | begin 252 | try 253 | return (Hashtbl.find stmt_cache param_types) 254 | with Not_found -> 255 | make_nary_select_stmt dbh param_types 256 | end >>= fun stmt -> 257 | M.Stmt.execute stmt params >>= or_die "Stmt.execute" >>= fun res -> 258 | assert (M.Res.num_rows res = 1); 259 | M.Res.fetch (module M.Row.Array) res >>= or_die "Res.fetch" >>= 260 | (function 261 | | None -> assert false 262 | | Some row -> 263 | assert (Array.length row = Array.length params); 264 | for i = 0 to n - 1 do 265 | assert_field_equal params.(i) (M.Field.value row.(i)) 266 | done; 267 | return ()) >>= fun () -> 268 | if Random.bool () then 269 | M.Stmt.close stmt >>= or_die "Stmt.close" >|= fun () -> 270 | Hashtbl.remove stmt_cache param_types 271 | else 272 | M.Stmt.reset stmt >>= or_die "Stmt.reset" >|= fun () -> 273 | Hashtbl.replace stmt_cache param_types stmt 274 | end >>= fun () -> 275 | Hashtbl.fold 276 | (fun _ stmt prologue -> 277 | prologue >>= fun () -> 278 | M.Stmt.close stmt >>= or_die "Stmt.close") 279 | stmt_cache (return ()) >>= fun () -> 280 | M.close dbh 281 | 282 | let test_many_select () = repeat 500 test_random_select 283 | 284 | let test_integer, test_bigint = 285 | let make_check type_ = 286 | connect () >>= or_die "connect" >>= fun dbh -> 287 | M.prepare dbh 288 | (Printf.sprintf 289 | "CREATE TEMPORARY TABLE ocaml_mariadb_test (id integer PRIMARY KEY \ 290 | AUTO_INCREMENT, value %s, value_unsigned %s unsigned)" 291 | type_ type_) 292 | >>= or_die "prepare create" 293 | >>= fun create_table_stmt -> 294 | execute_no_data create_table_stmt >>= fun () -> 295 | let check (value : [ `Signed of int | `Unsigned of int ]) = 296 | let column = 297 | match value with 298 | | `Signed _ -> "value" 299 | | `Unsigned _ -> "value_unsigned" 300 | in 301 | M.prepare dbh 302 | (Printf.sprintf "INSERT INTO ocaml_mariadb_test (%s) VALUES (?)" 303 | column) 304 | >>= or_die "prepare insert" 305 | >>= fun insert_stmt -> 306 | let value_to_insert = 307 | match value with `Signed n -> n | `Unsigned n -> n 308 | in 309 | M.Stmt.execute insert_stmt [| `Int value_to_insert |] 310 | >>= or_die "insert" 311 | >>= fun res -> 312 | M.prepare dbh 313 | (Printf.sprintf "SELECT %s FROM ocaml_mariadb_test WHERE id = (?)" 314 | column) 315 | >>= or_die "prepare select" 316 | >>= fun select_stmt -> 317 | M.Stmt.execute select_stmt [| `Int (M.Res.insert_id res) |] 318 | >>= or_die "Stmt.execute" 319 | >>= M.Res.fetch (module M.Row.Array) 320 | >>= or_die "Res.fetch" 321 | >|= function 322 | | Some [| inserted_value |] -> 323 | assert_field_equal (`Int value_to_insert) 324 | (`Int (M.Field.int inserted_value)) 325 | | _ -> assert false 326 | in 327 | return (dbh, check) 328 | in 329 | let test_integer () = 330 | make_check "integer" >>= fun (dbh, check) -> 331 | let input = 332 | [ 333 | `Signed 334 | (Int32.max_int |> Int32.to_int (* max value for integer column *)); 335 | `Signed 336 | (Int32.min_int |> Int32.to_int (* min value for integer column *)); 337 | `Unsigned (Unsigned.UInt32.max_int |> Unsigned.UInt32.to_int) 338 | (* max value for unsgined integer column. 339 | Produces the following error: insert: (1264) Out of range value for column 'value_unsigned' at row 1 *); 340 | ] 341 | in 342 | iter_s_list check input >>= fun () -> M.close dbh 343 | in 344 | let test_bigint () = 345 | make_check "bigint" >>= fun (dbh, check) -> 346 | let input = 347 | [ 348 | `Signed max_int 349 | (* [max_int] is below the max value for bigint column (which is equivalent to [Int64.max_int]) 350 | Produces the following error: Parameter (4611686018427387903 : int) came back as (-1 : int) *); 351 | `Unsigned max_int 352 | (* insert: (1264) Out of range value for column 'value_unsigned' at row 1 *); 353 | ] 354 | in 355 | iter_s_list check input >>= fun () -> M.close dbh 356 | in 357 | (test_integer, test_bigint) 358 | 359 | let test_json () = 360 | connect () >>= or_die "connect" >>= fun dbh -> 361 | 362 | (* Create a test table with JSON column *) 363 | M.prepare dbh 364 | "CREATE TEMPORARY TABLE ocaml_mariadb_json_test (id integer PRIMARY KEY AUTO_INCREMENT, data JSON)" 365 | >>= or_die "prepare create json table" 366 | >>= fun create_table_stmt -> 367 | execute_no_data create_table_stmt >>= fun () -> 368 | 369 | (* Test inserting JSON data *) 370 | M.prepare dbh "INSERT INTO ocaml_mariadb_json_test (data) VALUES (?)" 371 | >>= or_die "prepare insert json" 372 | >>= fun insert_stmt -> 373 | 374 | (* Test various JSON types *) 375 | let test_cases = [ 376 | {|{"name": "John", "age": 30}|}; 377 | {|[1, 2, 3, "four"]|}; 378 | {|"simple string"|}; 379 | {|42|}; 380 | {|true|}; 381 | {|null|} 382 | ] in 383 | 384 | (* Insert all test cases *) 385 | iter_s_list (fun json_data -> 386 | M.Stmt.execute insert_stmt [| `String json_data |] >>= or_die "insert json" 387 | >|= fun _ -> () 388 | ) test_cases >>= fun () -> 389 | 390 | (* Select and verify we can retrieve JSON data *) 391 | M.prepare dbh "SELECT id, data FROM ocaml_mariadb_json_test ORDER BY id" 392 | >>= or_die "prepare select json" 393 | >>= fun select_stmt -> 394 | M.Stmt.execute select_stmt [||] >>= or_die "execute select json" >>= fun res -> 395 | 396 | (* Verify we can fetch and access JSON fields *) 397 | let rec verify_rows count = 398 | M.Res.fetch (module M.Row.Array) res >>= or_die "fetch json row" >>= function 399 | | Some row -> 400 | assert (Array.length row = 2); 401 | (* Test that we can access the JSON field using different methods *) 402 | let json_value = match M.Field.value row.(1) with 403 | | `Bytes b -> Bytes.to_string b 404 | | _ -> failwith "Expected JSON field as Bytes" 405 | in 406 | (* Verify we got some data back *) 407 | assert (String.length json_value > 0); 408 | 409 | (* Test accessor functions *) 410 | let json_direct = M.Field.bytes row.(1) in 411 | let json_opt = M.Field.bytes_opt row.(1) in 412 | assert (json_opt = Some json_direct); 413 | assert (Bytes.length json_direct > 0); 414 | 415 | verify_rows (count + 1) 416 | | None -> 417 | (* We should have retrieved all our test cases *) 418 | assert (count = List.length test_cases); 419 | return () 420 | in 421 | 422 | verify_rows 0 >>= fun () -> 423 | 424 | (* Test JSON functions if supported (optional) *) 425 | (try 426 | M.prepare dbh "SELECT JSON_TYPE(data) FROM ocaml_mariadb_json_test LIMIT 1" 427 | >>= or_die "prepare json type" 428 | >>= fun json_func_stmt -> 429 | M.Stmt.execute json_func_stmt [||] >>= or_die "execute json type" >>= fun res -> 430 | M.Res.fetch (module M.Row.Array) res >>= or_die "fetch json type" >>= function 431 | | Some row -> 432 | let json_type = match M.Field.value row.(0) with 433 | | `String s -> s 434 | | _ -> failwith "Expected String from JSON_TYPE" 435 | in 436 | (* JSON_TYPE should return something like "OBJECT", "ARRAY", etc. *) 437 | assert (String.length json_type > 0); 438 | M.Stmt.close json_func_stmt >>= or_die "close json func stmt" 439 | | None -> return () 440 | with 441 | | _ -> return () (* JSON functions might not be supported in all versions *) 442 | ) >>= fun () -> 443 | 444 | M.Stmt.close select_stmt >>= or_die "close select stmt" >>= fun () -> 445 | M.Stmt.close insert_stmt >>= or_die "close insert stmt" >>= fun () -> 446 | M.close dbh 447 | 448 | let main () = 449 | test_server_properties () >>= fun () -> 450 | test_insert_id () >>= fun () -> 451 | test_txn () >>= fun () -> 452 | test_json () >>= fun () -> 453 | test_many_select () >>= fun () -> 454 | test_integer () >>= fun () -> test_bigint () 455 | end 456 | --------------------------------------------------------------------------------