├── src ├── cli │ ├── rel_cli.mllib │ ├── rel_cli.mli │ └── rel_cli.ml ├── pool │ ├── rel_pool.mllib │ ├── rel_pool.mli │ └── rel_pool.ml ├── sqlite3 │ ├── rel_sqlite3.mllib │ ├── librel_sqlite3_stubs.clib │ ├── rel_sqlite3_stubs.c │ └── rel_sqlite3.mli ├── rel.mllib ├── rel_list.mli ├── rel_kit.ml ├── rel_kit.mli ├── rel_list.ml ├── rel_sql.ml ├── tool │ └── rel_tool.ml ├── rel_sql.mli └── rel_query.mli ├── BRZO ├── doc ├── query_tutorial.mld ├── query_howto.mld ├── query_quickstart.mld ├── schema_quickstart.mld ├── tutorial.mld ├── sqlite3_howto.mld ├── sqlite3_quickstart.mld ├── sql_stmt_manual.mld ├── index.mld └── schema_howto.mld ├── .gitignore ├── .merlin ├── CHANGES.md ├── test ├── dynload.ml ├── test_rel.ml ├── test_sqlite3_stub.ml ├── test_issue_4.ml ├── test_query.ml ├── examples.ml ├── test_sqlite3_chinook.ml ├── test_sql.ml ├── schemas.ml └── chinook.ml ├── _tags ├── DEVEL.md ├── LICENSE.md ├── pkg ├── pkg.ml └── META ├── opam ├── README.md ├── myocamlbuild.ml └── B0.ml /src/cli/rel_cli.mllib: -------------------------------------------------------------------------------- 1 | Rel_cli -------------------------------------------------------------------------------- /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x test B0.ml attic pkg) -------------------------------------------------------------------------------- /src/pool/rel_pool.mllib: -------------------------------------------------------------------------------- 1 | Rel_pool -------------------------------------------------------------------------------- /doc/query_tutorial.mld: -------------------------------------------------------------------------------- 1 | {0 Query tutorial} -------------------------------------------------------------------------------- /src/sqlite3/rel_sqlite3.mllib: -------------------------------------------------------------------------------- 1 | Rel_sqlite3 -------------------------------------------------------------------------------- /src/sqlite3/librel_sqlite3_stubs.clib: -------------------------------------------------------------------------------- 1 | rel_sqlite3_stubs.o -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _b0 3 | tmp 4 | *.install 5 | test/Chinook_* -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG ocamlbuild threads.posix b0.kit 2 | B _b0/** 3 | S src -------------------------------------------------------------------------------- /src/rel.mllib: -------------------------------------------------------------------------------- 1 | Rel 2 | Rel_sql 3 | Rel_query 4 | Rel_list 5 | Rel_kit -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.0.1 YYYY-MM-DD Location 2 | -------------------------- 3 | 4 | First release. 5 | -------------------------------------------------------------------------------- /doc/query_howto.mld: -------------------------------------------------------------------------------- 1 | {0 Query how-to} 2 | 3 | - Show how paradigmatic queries are expressed in {!Rel_query} 4 | -------------------------------------------------------------------------------- /doc/query_quickstart.mld: -------------------------------------------------------------------------------- 1 | {0 Query quick start} 2 | 3 | This assumes you have the definitions of the {{!schema_quickstart}schema 4 | quick start}. 5 | 6 | - Show how to query a single table. 7 | - Show how to join 8 | -------------------------------------------------------------------------------- /doc/schema_quickstart.mld: -------------------------------------------------------------------------------- 1 | {0 Schema quickstart} 2 | 3 | Show. 4 | 5 | - How to define a {!Rel.Schema.t} value. 6 | - How to derive it from a db. 7 | - How to print a diagram of it. 8 | 9 | Now move to the {{!page-query_quickstart}query quick start}. -------------------------------------------------------------------------------- /test/dynload.ml: -------------------------------------------------------------------------------- 1 | (* compile with ocamlopt -linkall dynlink.cmxa dynload.ml *) 2 | 3 | let () = 4 | let load cmxs = Dynlink.loadfile cmxs in 5 | Dynlink.allow_unsafe_modules true; 6 | try 7 | List.iter load (List.tl (Array.to_list Sys.argv)); 8 | print_endline "Okay!"; 9 | exit 0 10 | with 11 | | Dynlink.Error e -> print_endline (Dynlink.error_message e); exit 2 12 | -------------------------------------------------------------------------------- /test/test_rel.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_testing 7 | 8 | let test = 9 | Test.test "Rel definitions" @@ fun () -> 10 | assert true; 11 | () 12 | 13 | let main () = Test.main @@ fun () -> Test.autorun () 14 | let () = if !Sys.interactive then () else exit (main ()) 15 | -------------------------------------------------------------------------------- /doc/tutorial.mld: -------------------------------------------------------------------------------- 1 | {0:tutorial Tutorial} 2 | 3 | This tutorial shows you simple steps to define a database in OCaml 4 | 5 | {1:old Old stuff} 6 | 7 | Having your database schema as a first class value in OCaml kills a 8 | few unchecked stringly dependencies and allows to devise generic code 9 | to process them. For example to derive boilerpate queries or generate 10 | {{!Rel.Schema.pp_dot}diagrams}. 11 | 12 | OCaml values that represent approximations of existing database 13 | schemas can be output using the [rel] command line tool. 14 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | <_b0> : -traverse 3 | : include 4 | : include 5 | : include 6 | : include 7 | : include 8 | 9 | : use_sqlite3 10 | : record_rel_sqlite3_stubs 11 | : link_rel_sqlite3_stubs_archive 12 | : use_sqlite3 13 | 14 | : thread, package(threads.posix) 15 | : package(cmdliner) 16 | 17 | : package(cmdliner), use_rel_sqlite3 -------------------------------------------------------------------------------- /test/test_sqlite3_stub.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_testing 7 | 8 | let test_version = 9 | Test.test "Rel_sqlite3.version" @@ fun () -> 10 | Test.log "SQLite version: %s" (Rel_sqlite3.version ()); 11 | () 12 | 13 | let main () = Test.main @@ fun () -> Test.autorun () 14 | let () = if !Sys.interactive then () else (exit (main ())) 15 | -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | This project uses (perhaps the development version of) [`b0`] for 2 | development. Consult [b0 occasionally] for quick hints on how to 3 | perform common development tasks. 4 | 5 | [`b0`]: https://erratique.ch/software/b0 6 | [b0 occasionally]: https://erratique.ch/software/b0/doc/occasionally.html 7 | 8 | # Testing 9 | 10 | The test suite needs the Chinook database in `test`. Download it with: 11 | 12 | b0 -- download-chinook 13 | b0 test 14 | 15 | If you need a refresh on Chinook's schema use: 16 | 17 | b0 -- rel schema -f dot test/Chinook_Sqlite.sqlite | dot -Tsvg | \ 18 | show-url -t chinook.svg 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 The rel programmers 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let sqlite3 = Conf.with_pkg "conf-sqlite3" 7 | let () = 8 | Pkg.describe "rel" @@ fun c -> 9 | let sqlite3 = Conf.value c sqlite3 in 10 | let doc file = Pkg.doc ("doc/" ^ file) ~dst:("odoc-pages/" ^ file) in 11 | Ok [ 12 | Pkg.mllib "src/rel.mllib"; 13 | Pkg.mllib "src/cli/rel_cli.mllib" ~dst_dir:"cli"; 14 | Pkg.mllib "src/pool/rel_pool.mllib" ~dst_dir:"pool"; 15 | Pkg.mllib ~cond:sqlite3 "src/sqlite3/rel_sqlite3.mllib" ~dst_dir:"sqlite3"; 16 | Pkg.clib 17 | ~cond:sqlite3 "src/sqlite3/librel_sqlite3_stubs.clib" 18 | ~lib_dst_dir:"sqlite3"; 19 | Pkg.bin ~cond:sqlite3 "src/tool/rel_tool" ~dst:"rel"; 20 | doc "index.mld"; 21 | doc "tutorial.mld"; 22 | doc "query_tutorial.mld"; 23 | doc "query_quickstart.mld"; 24 | doc "query_howto.mld"; 25 | doc "schema_quickstart.mld"; 26 | doc "schema_howto.mld"; 27 | doc "sqlite3_quickstart.mld"; 28 | doc "sqlite3_howto.mld"; 29 | doc "sql_stmt_manual.mld"; 30 | ] 31 | -------------------------------------------------------------------------------- /src/cli/rel_cli.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Cmdliner fragments. *) 7 | 8 | open Rel 9 | 10 | type schema_format = 11 | [ `Dot of Schema.dot_rankdir 12 | | `Sqlite3 13 | | `Ocaml of [`Intf | `Impl | `Both]] 14 | (** The type for schema output formats. *) 15 | 16 | val schema_format : 17 | ?docs:string -> ?opts:string list -> default:schema_format -> unit -> 18 | schema_format Cmdliner.Term.t 19 | (** [schema_format ~default ()] is a command line option named by [opts] 20 | (defaults to ["format"]) to specify a schema output format. 21 | [default] is the default if unspecified. [docs] is the documentation 22 | section in which it gets documented. *) 23 | 24 | val renames : 25 | ?docs:string -> ?opts:string list -> unit -> 26 | (Schema.col_renames list * Schema.rename list) Cmdliner.Term.t 27 | (** [name_change_maps ()] is a repeatable command line option named by [opts] 28 | (defaults to ["r"; "rename"]) to specify column and table renames. [docs] 29 | is the documentation section in which it gets documented. *) 30 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Relational database programming for OCaml" 2 | version = "%%VERSION_NUM%%" 3 | requires = "" 4 | archive(byte) = "rel.cma" 5 | archive(native) = "rel.cmxa" 6 | plugin(byte) = "rel.cma" 7 | plugin(native) = "rel.cmxs" 8 | exists_if = "rel.cma rel.cmxa" 9 | 10 | package "cli" ( 11 | directory = "cli" 12 | description = "The rel.cli library" 13 | version = "%%VERSION_NUM%%" 14 | requires = "rel cmdliner" 15 | archive(byte) = "rel_cli.cma" 16 | archive(native) = "rel_cli.cmxa" 17 | plugin(byte) = "rel_cli.cma" 18 | plugin(native) = "rel_cli.cmxs" 19 | exists_if = "rel_cli.cma rel_cli.cmxa" 20 | ) 21 | 22 | package "pool" ( 23 | directory = "pool" 24 | description = "The rel.pool library" 25 | version = "%%VERSION_NUM%%" 26 | requires = "threads.posix" 27 | archive(byte) = "rel_pool.cma" 28 | archive(native) = "rel_pool.cmxa" 29 | plugin(byte) = "rel_pool.cma" 30 | plugin(native) = "rel_pool.cmxs" 31 | exists_if = "rel_pool.cma rel_pool.cmxa" 32 | ) 33 | 34 | package "sqlite3" ( 35 | directory = "sqlite3" 36 | description = "The rel.sqlite3 library" 37 | version = "%%VERSION_NUM%%" 38 | requires = "rel" 39 | archive(byte) = "rel_sqlite3.cma" 40 | archive(native) = "rel_sqlite3.cmxa" 41 | plugin(byte) = "rel_sqlite3.cma" 42 | plugin(native) = "rel_sqlite3.cmxs" 43 | exists_if = "rel_sqlite3.cma rel_sqlite3.cmxa" 44 | ) 45 | -------------------------------------------------------------------------------- /src/rel_list.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Query OCaml lists of rows. 7 | 8 | Given a suitable map from table to their content as lists of values, this 9 | module (slowly) runs queries in memory. *) 10 | 11 | open Rel 12 | 13 | (** Table environments. *) 14 | module Table_env : sig 15 | 16 | type t 17 | (** The type for table environments. Maps tables to their content. *) 18 | 19 | val empty : t 20 | (** [empty] has no tables. *) 21 | 22 | val add : 'a Table.t -> 'a list -> t -> t 23 | (** [add t l env] binds table [t] to [l] in [env]. *) 24 | 25 | val find : 'a Table.t -> t -> 'a list option 26 | (** [find t env] finds table [t] in [env]. .*) 27 | end 28 | 29 | type error = 30 | [ `Undefined_table of Table.def 31 | | `Unknown_extension of string 32 | | `Unexpected_variable of string ] 33 | (** The type for query errors. *) 34 | 35 | val error_to_string : error -> string 36 | (** [error_to_string e] is [e] as a human readable string. *) 37 | 38 | val of_bag : Table_env.t -> ('a, 'e) Rel_query.Bag.t -> ('a list, error) result 39 | (** [of_bag env b] is the result of [b] given tables the table environment 40 | [env]. *) 41 | -------------------------------------------------------------------------------- /test/test_issue_4.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2025 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_std 7 | open B0_testing 8 | open Rel 9 | 10 | (* TODO eventually move that to a proper test suite *) 11 | 12 | let get r = r |> Rel_sqlite3.string_error |> Result.get_ok' 13 | let snap_stmt st = Snap.string (Fmt.str "%a" Rel_sql.Stmt.pp_src st) 14 | 15 | let xxx = Col.make "xxx" (Type.int) Fun.id 16 | let row x = x 17 | let row = Row.(unit row * xxx) 18 | let table = Table.make "rest" row 19 | let schema = Rel.Schema.make ~tables:[ Def table ] () 20 | 21 | let create_schema db = 22 | let stmts = Rel_sql.create_schema Rel_sqlite3.dialect schema in 23 | List.iter_stop_on_error (Rel_sqlite3.exec db) stmts 24 | 25 | let insert v = 26 | let stmt = Rel_sql.insert_into Rel_sqlite3.dialect table v in 27 | snap_stmt stmt @@ __POS_OF__ 28 | "INSERT INTO \"rest\" (\"xxx\")\n\ 29 | VALUES (?1)"; 30 | stmt 31 | 32 | let rest_table = 33 | let stmt = Rel_query.(Sql.of_bag' table (Bag.table table)) in 34 | snap_stmt stmt @@ __POS_OF__ 35 | "SELECT rest.*\n\ 36 | FROM \"rest\""; 37 | stmt 38 | 39 | let test_bug = 40 | Test.test "Testing issue 4" @@ fun () -> 41 | Test.noraise @@ fun () -> 42 | let db = Rel_sqlite3.open' ~mode:Memory "" |> get in 43 | let () = create_schema db |> get in 44 | let v = 10_000_000_000 in 45 | let () = Rel_sqlite3.exec db (insert v) |> get in 46 | let vs = Rel_sqlite3.fold db rest_table List.cons [] |> get in 47 | Test.(list T.int) vs [v]; 48 | () 49 | 50 | let main () = Test.main @@ fun () -> Test.autorun () 51 | let () = if !Sys.interactive then () else exit (main ()) 52 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "rel" 3 | synopsis: "Relational database programming for OCaml" 4 | description: """\ 5 | Rel is a library for programming with relational databases in OCaml. 6 | It provides: 7 | 8 | - Typed combinators to describe database rows and their representation 9 | as custom OCaml values. 10 | - Typed combinators to describe database schemas. Schemas can be translated 11 | to SQL data definitions or, conversly, generated for existing databases 12 | (external schema definition). 13 | - Automated schema changes via schema diffing. 14 | - Raw SQL statements typing and SQL generation helpers (parametric on SQL 15 | dialect). 16 | - Query language embedded in *plain* OCaml. Queries are typed, 17 | composable and compile to a single, flat, SQL query (experimental). 18 | - Support for using SQLite3 databases. 19 | 20 | Rel is distributed under the ISC license. The base library has no 21 | dependencies. The `Rel_cli` library depends on `cmdliner`. The 22 | `Rel_sqlite3` library depends on the C SQLite3 library (at least 23 | v3.38.5). 24 | 25 | Homepage: https://erratique.ch/software/rel""" 26 | maintainer: "Daniel Bünzli " 27 | authors: "The rel programmers" 28 | license: "ISC" 29 | tags: ["database" "query" "SQL" "org:erratique"] 30 | homepage: "https://erratique.ch/software/rel" 31 | doc: "https://erratique.ch/software/rel/doc" 32 | bug-reports: "https://github.com/dbuenzli/rel/issues" 33 | depends: [ 34 | "ocaml" {>= "4.14.0"} 35 | "ocamlfind" {build} 36 | "ocamlbuild" {build} 37 | "topkg" {build & >= "1.1.0"} 38 | "cmdliner" {>= "1.3.0"} 39 | ] 40 | depopts: ["conf-sqlite3"] 41 | build: [ 42 | "ocaml" 43 | "pkg/pkg.ml" 44 | "build" 45 | "--dev-pkg" 46 | "%{dev}%" 47 | "--with-conf-sqlite3" 48 | "%{conf-sqlite3:installed}%" 49 | ] 50 | dev-repo: "git+https://erratique.ch/repos/rel.git" 51 | -------------------------------------------------------------------------------- /src/pool/rel_pool.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Pools of reusable resources. 7 | 8 | This can be used for pooling database connections in multithreaded 9 | programs. *) 10 | 11 | (** {1:pool Pools} *) 12 | 13 | type ('a, 'b) t 14 | (** The type for pools of reusable resources of type ['a] whose 15 | life-cycle management returns errors of type ['b]. *) 16 | 17 | val create : 18 | create:(unit -> ('a, 'b) result) -> dispose:('a -> (unit, 'b) result) -> 19 | int -> ('a, 'b) t 20 | (** [create ~create ~dispose limit] is a pool with at most [limit] 21 | reusable ressources created with [create]. [dispose] is only 22 | called when {!dispose} is; in particular it is {e not} called when 23 | the pool is garbage collected. *) 24 | 25 | val with' : ('a, 'b) t -> ('a -> 'c) -> ('c, 'b) result 26 | (** [with' p f] blocks the calling thread until a resource [r] can be 27 | reused or created in the limit given to {!create}. Returns [Ok (f 28 | r)] and releases the ressource [r] back to the pool for reuse 29 | (even if [f] raises). [Error _] is returned in case the resource 30 | [r] had to be created and it errored. *) 31 | 32 | val try_with : ('a, 'b) t -> ('a -> 'c) -> ('c, 'b) result option 33 | (** [try_with] is like {!with'} but if no ressource can be reused or 34 | created in the limit given to {!create} the function returns 35 | immediately with [None]. *) 36 | 37 | val dispose : ('a, 'b) t -> (unit, 'b list) result 38 | (** [dispose p] disposes the ressources of [p] that are not currently 39 | used. Ressources that are currently held by {!with'} or 40 | {!try_with} calls are not disposed. [p] can still be used 41 | afterwards new ressources will be created as needed in the limits 42 | given to {!create}. *) 43 | -------------------------------------------------------------------------------- /test/test_query.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2025 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_testing 7 | open Rel 8 | 9 | module Person = struct 10 | module Role = struct 11 | type t = Author | Editor 12 | let to_string = function Author -> "author" | Editor -> "editor" 13 | let pp ppf r = Format.pp_print_string ppf (to_string r) 14 | 15 | let relt = 16 | let enc = function Author -> 0 | Editor -> 1 in 17 | let dec = function 18 | | 0 -> Author 19 | | 1 -> Editor 20 | | n -> failwith (Printf.sprintf "Unknown role code %d" n) 21 | in 22 | Type.coded (Type.Coded.make ~name:"Person.Role.t" Type.int ~enc ~dec ~pp) 23 | end 24 | 25 | type person = { name : string option; role : Role.t } 26 | let make name role = { name; role } 27 | let name p = p.name 28 | let role p = p.role 29 | let name' = Col.make "name" Type.(option text) name 30 | let role' = Col.make "role" Role.relt role 31 | let table = Table.make "person" Row.(unit make * name' * role') 32 | 33 | open Rel_query.Syntax 34 | 35 | let find_name name = 36 | let* p = Bag.table table in 37 | let is_name = 38 | Option.(equal ~eq:Text.equal (p #. name') (some Type.text name)) 39 | in 40 | Bag.where is_name (Bag.yield p) 41 | 42 | let find_role role = 43 | let* p = Bag.table table in 44 | let role = Coded.v Role.relt role in 45 | let is_role = Coded.equal Role.relt (p #. role') role in 46 | Bag.where is_role (Bag.yield p) 47 | end 48 | 49 | let test = 50 | Test.test "Rel_query" @@ fun () -> 51 | let find_name_sql = 52 | Rel_query.Sql.of_bag' 53 | Person.table (Person.find_name (Rel_query.Text.v "bla")) 54 | in 55 | let find_role_sql = 56 | Rel_query.Sql.of_bag' Person.table (Person.find_role Editor) 57 | in 58 | Test.log "%a" Rel_sql.Stmt.pp find_name_sql; 59 | Test.log "%a" Rel_sql.Stmt.pp find_role_sql; 60 | assert true; 61 | () 62 | 63 | let main () = Test.main @@ fun () -> Test.autorun () 64 | let () = if !Sys.interactive then () else exit (main ()) 65 | -------------------------------------------------------------------------------- /src/pool/rel_pool.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | type ('a, 'b) t = 7 | { create : unit -> ('a, 'b) result; 8 | dispose : 'a -> (unit, 'b) result; 9 | m : Mutex.t; 10 | free_non_zero : Condition.t; 11 | mutable free : int; 12 | mutable reusable : 'a list; } 13 | 14 | let create ~create ~dispose n = 15 | if n < 0 then invalid_arg (Printf.sprintf "negative pool size (%d)" n) else 16 | let m = Mutex.create () and free_non_zero = Condition.create () in 17 | { create; dispose; m; free_non_zero; free = n; reusable = []; } 18 | 19 | let get_ressource p = 20 | p.free <- p.free - 1; 21 | match p.reusable with 22 | | r :: rs -> p.reusable <- rs; Ok r 23 | | [] -> 24 | match p.create () with 25 | | Ok _ as r -> r 26 | | Error _ as e -> p.free <- p.free + 1; e 27 | | exception exn -> 28 | let bt = Printexc.get_raw_backtrace () in 29 | p.free <- p.free + 1; 30 | Printexc.raise_with_backtrace exn bt 31 | 32 | let with_mutex p f = 33 | let finally () = Mutex.unlock p.m in 34 | Mutex.lock p.m; Fun.protect ~finally f 35 | 36 | let acquire p = 37 | with_mutex p @@ fun () -> 38 | while p.free = 0 do Condition.wait p.free_non_zero p.m done; 39 | get_ressource p 40 | 41 | let try_acquire p = 42 | with_mutex p @@ fun () -> 43 | if p.free = 0 then None else Some (get_ressource p) 44 | 45 | let release p r = 46 | with_mutex p @@ fun () -> 47 | p.reusable <- r :: p.reusable; 48 | p.free <- p.free + 1; 49 | Condition.signal p.free_non_zero 50 | 51 | let exec_and_release p r f = 52 | let finally () = release p r in 53 | Fun.protect ~finally (fun () -> Ok (f r)) 54 | 55 | let with' p f = match acquire p with 56 | | Error _ as e -> e 57 | | Ok r -> exec_and_release p r f 58 | 59 | let try_with p f = match try_acquire p with 60 | | None | Some (Error _) as v -> v 61 | | Some (Ok r) -> Some (exec_and_release p r f) 62 | 63 | let dispose p = 64 | let dispose acc r = match p.dispose r with 65 | | Ok () -> acc | Error e -> (e :: acc) 66 | in 67 | with_mutex p @@ fun () -> 68 | let errs = List.fold_left dispose [] p.reusable in 69 | if errs = [] then Ok () else Error errs 70 | -------------------------------------------------------------------------------- /doc/sqlite3_howto.mld: -------------------------------------------------------------------------------- 1 | {0 Sqlite3 how-to} 2 | 3 | {1:schema Schema} 4 | 5 | See also Rel's general {{!page-schema_howto}how-to}. 6 | 7 | {2:diagram How can I get the schema diagram of a database ?} 8 | 9 | {[ 10 | rel schema -f dot db.sqlite3 > db.dot 11 | rel schema -f dot db.sqlite3 | dot -Tsvg | show-url -t db.svg 12 | ]} 13 | 14 | {2:gen How can I generate the OCaml schema definition of a database ?} 15 | 16 | {[ 17 | rel schema -f ocaml-mli db.sqlite3 > db.mli 18 | rel schema -f ocaml-ml db.sqlite3 > db.ml 19 | ]} 20 | 21 | {2:how How can I define my own database schema ?} 22 | 23 | See Rel's general {{!page-schema_howto}schema how-to}. 24 | 25 | {1:db Database configuration} 26 | 27 | {2:webapp How do I setup SQLite for a web application ?} 28 | 29 | SQLite3 is perfectly fine for medium scale web applications. However you need: 30 | 31 | {ol 32 | {- Set your database in {{:https://sqlite.org/wal.html}WAL} mode.} 33 | {- Set a {{:https://www.sqlite.org/c3ref/busy_timeout.html}busy timeout}.} 34 | {- Make your {{!Rel_sqlite3.with_transaction}transactions} with [`Immediate].}} 35 | 36 | This snippet peforms the two first steps for you when the connection 37 | is open to the database: 38 | 39 | {[ 40 | open Result.Syntax 41 | 42 | let open' ?foreign_keys ?stmt_cache_size ?(read_only = false) file = 43 | let set_wal_mode db = Rel_sqlite3.exec_sql db "PRAGMA journal_mode=WAL;" in 44 | let mode = Rel_sqlite3.(if read_only then Read else Read_write_create) in 45 | let mutex = Rel_sqlite3.No and f = Fpath.to_string file in 46 | let* db = Rel_sqlite3.open' ?foreign_keys ?stmt_cache_size ~mutex ~mode f in 47 | let* () = Rel_sqlite3.busy_timeout_ms db 5000 in 48 | let* () = if read_only then Ok () else set_wal_mode db in 49 | Ok db 50 | ]} 51 | 52 | This should be enough for rarely hitting the busy time errors. In case 53 | you still do and need to respond to an HTTP client, it's a good idea 54 | to let it now to try again later. For example (using {!Webs}): 55 | 56 | {[ 57 | let http_response_error ?(retry_after_s = 2) e = 58 | let explain = Rel_sqlite3.Error.message e in 59 | match Rel_sqlite3.Error.code e with 60 | | e when e = Rel_sqlite3.Error.busy_timeout -> 61 | let dur = string_of_int retry_after_s in 62 | let headers = Http.Headers.empty |> Http.Headers.(def retry_after dur) in 63 | Http.Response.empty ~headers ~explain Http.Status.service_unavailable_503 64 | | _ -> 65 | Http.Response.empty ~explain Http.Status.server_error_500 66 | ]} 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | rel — Relational database programming for OCaml 2 | =============================================== 3 | %%VERSION%% 4 | 5 | Rel is a library for programming with relational databases in OCaml. 6 | It provides: 7 | 8 | - Typed combinators to describe database rows and their representation 9 | as custom OCaml values. 10 | - Typed combinators to describe database schemas. Schemas can be translated 11 | to SQL data definitions or, conversly, generated for existing databases 12 | (external schema definition). 13 | - Automatic schema change computation via schema diffing. 14 | - Raw SQL statements typing and SQL generation helpers (parametric on SQL 15 | dialect). 16 | - Query language embedded in *plain* OCaml. Queries are typed, 17 | composable and compile to a single, flat, SQL query (experimental). 18 | - Support for using SQLite3 databases. 19 | 20 | Rel is distributed under the ISC license. The base library has no 21 | dependencies. The `Rel_cli` library depends on `cmdliner`. The 22 | `Rel_sqlite3` library depends on the C SQLite3 library (at least 23 | v3.38.5). 24 | 25 | Homepage: https://erratique.ch/software/rel 26 | 27 | # Installation 28 | 29 | rel can be installed with `opam`: 30 | 31 | opam install rel 32 | opam install rel conf-sqlite3 # with SQLite support 33 | 34 | If you don't use `opam` consult the [`opam`](opam) file for build 35 | instructions. 36 | 37 | # Documentation 38 | 39 | The documentation can be consulted [online][doc] or via `odig doc rel`. 40 | 41 | Questions are welcome but better reled on the [OCaml forum][ocaml-forum] 42 | than on the issue tracker. 43 | 44 | [doc]: https://erratique.ch/software/rel/doc 45 | [ocaml-forum]: https://discuss.ocaml.org/ 46 | 47 | # Acknowledgements 48 | 49 | The query language of Rel is based on the following line of papers. 50 | 51 | * Ezra Cooper. The Script-Writer’s Dream: How to Write Great SQL in Your 52 | Own Language, and Be Sure It Will Succeed. 2009. 53 | [Full text](https://doi.org/10.1007/978-3-642-03793-1_3) 54 | 55 | * James Cheney et al. A practical theory of language-integrated query. 2013. 56 | [Full text](https://doi.org/10.1145/2544174.2500586) 57 | 58 | * Suzuki et al. Finally, safely-extensible and efficient language-integrated 59 | query. 2016. 60 | [Full text](https://doi.org/10.1145/2847538.2847542) 61 | 62 | * Oleg Kiselyov et al. Sound and Efficient Language-Integrated Query -- 63 | Maintaining the ORDER. 2017. 64 | [Full text](https://doi.org/10.1007/978-3-319-71237-6_18) 65 | -------------------------------------------------------------------------------- /test/examples.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: CC0-1.0 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Rel.Type.Coded *) 7 | 8 | open Rel 9 | 10 | type status = [ `Ok | `Failed ] 11 | 12 | let pp_status ppf v = 13 | Format.pp_print_string ppf (match v with `Ok -> "ok" | `Failed -> "failed") 14 | 15 | let status : status Type.t = 16 | let enc = function `Ok -> true | `Failed -> false in 17 | let dec = function true -> `Ok | false -> `Failed in 18 | Type.coded (Type.Coded.make ~name:"status" Type.bool ~enc ~dec ~pp:pp_status) 19 | 20 | 21 | (** Persons. *) 22 | module Person : sig 23 | 24 | type id = int 25 | (** The type for person identifiers. *) 26 | 27 | type t 28 | (** The type for persons. *) 29 | 30 | val v : id:id -> first_name:string -> last_name:string -> t 31 | (** [v ~id ~first_name ~last_name] is a person with given attributes. 32 | See accessors for semantics. *) 33 | 34 | val row : id -> string -> string -> t 35 | (** [row] is unlabelled {!v}. *) 36 | 37 | val id : t -> id 38 | (** [id p] is the unique identifier of [p]. *) 39 | 40 | val first_name : t -> string 41 | (** [first_name p] is the first name of [p]. *) 42 | 43 | val last_name : t -> string 44 | (** [last_name p] is the last name of [p]. *) 45 | 46 | (** {1:table Table} *) 47 | 48 | open Rel 49 | 50 | val id' : (t, id) Col.t 51 | (** [id'] is the {!id} column. *) 52 | 53 | val first_name' : (t, string) Col.t 54 | (** [first_name'] is the {!first_name} column. *) 55 | 56 | val last_name' : (t, string) Col.t 57 | (** [last_name'] is the {!last_name} column. *) 58 | 59 | val table : t Table.t 60 | (** [table] is the person table. *) 61 | end = struct 62 | 63 | type id = int 64 | type t = { id : id; first_name : string; last_name : string } 65 | 66 | let v ~id ~first_name ~last_name = { id; first_name; last_name } 67 | let row id first_name last_name = { id; first_name; last_name } 68 | 69 | let id r = r.id 70 | let first_name r = r.first_name 71 | let last_name r = r.last_name 72 | 73 | open Rel 74 | 75 | let id' = Col.make "id" Type.int id 76 | let first_name' = Col.make "first_name" Type.text first_name 77 | let last_name' = Col.make "last_name" Type.text last_name 78 | 79 | let table = 80 | let primary_key = Table.Primary_key.make [Def id'] in 81 | Table.make "person" ~primary_key @@ 82 | Row.(unit row * id' * first_name' * last_name') 83 | end 84 | -------------------------------------------------------------------------------- /doc/sqlite3_quickstart.mld: -------------------------------------------------------------------------------- 1 | {0 Rel SQLite3 quick start} 2 | 3 | A few steps to get you started if you need extract data from an 4 | SQLite3 database. 5 | 6 | {1:sample_data Get the data} 7 | 8 | We use the Chinook sample database which represents a digital media 9 | store. First download the latest 10 | {{:https://github.com/lerocha/chinook-database/releases/latest/download/Chinook_Sqlite.sqlite}[Chinook_Sqlite.sqlite]} file. 11 | 12 | {1:schema Get a feel of the schema} 13 | 14 | You can to this with the [Rel] library itself but for now the simplest 15 | is to use the [rel] tool distributed with the library and 16 | {{:https://graphviz.org/}graphviz}'s [dot] tool in your [PATH]. 17 | 18 | {[ 19 | rel schema -f dot Chinook_Sqlite.sqlite | dot -Tsvg | show-url -t ch.svg 20 | ]} 21 | 22 | Note the few columns where [option] types show up where you might not 23 | expect them. These columns lack a [NOT NULL] directive so they might 24 | be [NULL] which [Rel] represents by option types. 25 | 26 | If you don't have [dot] you can simply look 27 | {{:https://github.com/lerocha/chinook-database?tab=readme-ov-file#data-model} 28 | here}. Or simply read the SQL data definitions: 29 | 30 | {[ 31 | rel schema -f sqlite3 Chinook_Sqlite.sqlite 32 | sqlite3 Chinook_Sqlite.sqlite -- .schema 33 | ]} 34 | 35 | {1:quick_extraction Quick extraction} 36 | 37 | These steps can be invoked an [ocaml] REPL in which the 38 | [rel.sqlite3] library is loaded and with the [Chinook_Sqlite.sqlite] 39 | file in the current working directory. 40 | 41 | First let's make a bracket for using the database with a function 42 | and printing out errors. 43 | 44 | {[ 45 | let ( let* ) = Result.bind 46 | let with_db ?(mode = Rel_sqlite3.Read ) f = 47 | Result.fold ~ok:Fun.id ~error:prerr_endline @@ 48 | Rel_sqlite3.string_error @@ Result.join @@ 49 | let* db = Rel_sqlite3.open' ~mode "Chinook_Sqlite.sqlite" in 50 | let finally () = ignore (Rel_sqlite3.close db) in 51 | Ok (Fun.protect ~finally @@ fun () -> f db) 52 | ]} 53 | 54 | Then we devise this query that selects the identifier and title column 55 | of the [Album] table 56 | 57 | {b TODO.} it would be nice to avoid the raw sql 58 | while not getting directly into formal schema modelling. 59 | 60 | {b TODO.} Also add a parameter to the query. 61 | 62 | {[ 63 | let print_albums db = 64 | let row = Rel.Row.(t2 (int "id") (text "title")) in 65 | let sql = "select AlbumId, Title from Album" in 66 | let st = Rel_sql.Stmt.(func sql @@ ret row) in 67 | let* ps = Rel_sqlite3.fold db st List.cons [] in 68 | Format.printf "%a@." (Rel.Row.value_pp_list ~header:true row) (List.rev ps); 69 | Ok () 70 | ]} 71 | 72 | Here they are: 73 | 74 | {[ 75 | let () = with_db print_albums 76 | ]} 77 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin 2 | open Command 3 | 4 | (* Generic pkg-config(1) support. *) 5 | 6 | let pkg_config_exists package = 7 | Sys.command ("pkg-config --exists " ^ package) = 0 8 | 9 | let lib_with_clib ~lib ~clib ~has_lib ~src_dir ~stublib = 10 | let strf = Printf.sprintf in 11 | let pkg_config flags package = 12 | let cmd tmp = 13 | Command.execute ~quiet:true & 14 | Cmd( S [ A "pkg-config"; A ("--" ^ flags); A package; Sh ">"; A tmp]); 15 | List.map (fun arg -> A arg) (string_list_of_file tmp) 16 | in 17 | with_temp_file "pkgconfig" "pkg-config" cmd 18 | in 19 | let ar s = match !Ocamlbuild_plugin.Options.ext_lib with 20 | | "" -> s ^ ".a" | x -> s ^ "." ^ x 21 | in 22 | let make_opt o arg = S [ A o; arg ] in 23 | let ccopts = List.map (make_opt "-ccopt") in 24 | let cclibs = List.map (make_opt "-cclib") in 25 | let dllibs = List.map (make_opt "-dllib") in 26 | let use_lib = strf "use_%s" lib in 27 | let use_clib = strf "use_%s" clib in 28 | let record_stub_lib = strf "record_%s" stublib in 29 | let link_stub_archive = strf "link_%s_archive" stublib in 30 | let stub_ar = ar (strf "%s/lib%s" src_dir stublib) in 31 | let static_stub_l = match !Ocamlbuild_plugin.Options.ext_lib with 32 | | "lib" (* Windows *) -> A (strf "lib%s.lib" stublib) 33 | | _ -> A (strf "-l%s" stublib) 34 | in 35 | let dynamic_stub_l = match !Ocamlbuild_plugin.Options.ext_lib with 36 | | "lib" (* Windows *) -> A (strf "dll%s.dll" stublib) 37 | | _ -> static_stub_l 38 | in 39 | let clib_l = pkg_config "libs-only-l" clib in 40 | let clib_L = pkg_config "libs-only-L" clib in 41 | let clib_cflags = ccopts @@ (A has_lib) :: pkg_config "cflags" clib in 42 | let clib_cclibs = cclibs @@ static_stub_l :: clib_l in 43 | let clib_ccopts = ccopts @@ clib_L in 44 | begin 45 | dep [record_stub_lib] [stub_ar]; 46 | 47 | flag ["c"; "compile"; use_clib] (S clib_cflags); 48 | 49 | flag ["c"; "ocamlmklib"; use_clib] (S (clib_L @ clib_l)); 50 | 51 | flag ["link"; "ocaml"; "library"; "byte"; record_stub_lib] 52 | (S (dllibs [dynamic_stub_l] @ clib_ccopts @ clib_cclibs)); 53 | 54 | flag ["link"; "ocaml"; "library"; "native"; record_stub_lib] 55 | (S (clib_ccopts @ clib_cclibs)); 56 | 57 | flag_and_dep ["link"; "ocaml"; link_stub_archive] (P stub_ar); 58 | 59 | flag ["link"; "ocaml"; "library"; "shared"; link_stub_archive] 60 | (S (clib_ccopts @ clib_cclibs)); 61 | 62 | ocaml_lib ~tag_name:use_lib ~dir:src_dir (strf "%s/%s" src_dir lib) 63 | end 64 | 65 | let () = 66 | dispatch begin function 67 | | After_rules -> 68 | if pkg_config_exists "sqlite3" then 69 | lib_with_clib 70 | ~lib:"rel_sqlite3" ~clib:"sqlite3" ~has_lib:"-DHAS_SQLITE3" 71 | ~src_dir:"src/sqlite3" ~stublib:"rel_sqlite3_stubs"; 72 | | _ -> () 73 | end 74 | -------------------------------------------------------------------------------- /doc/sql_stmt_manual.mld: -------------------------------------------------------------------------------- 1 | {0 SQL statement typing manual} 2 | 3 | The mecanism described here uses raw SQL strings. 4 | 5 | This means it is low-level: the SQL depends on the SQL dialect of your 6 | DBMS and will likely have unchecked dependencies with your {!Rel} 7 | descriptions. Whenever possible you should prefer the higher level 8 | functions of {!Rel_sql} or the embedded query language {!Rel_query}. 9 | 10 | Nevertheless this provides a good escape hatch would you find yourself 11 | stuck with the expressiveness of the higher-level support. 12 | 13 | {1:basics Basics} 14 | 15 | The {!Rel_sql.Stmt} module provides a low-level mecanism to type the 16 | parameters and results of SQL 17 | {{:https://en.wikipedia.org/wiki/Prepared_statement}prepared statements}. 18 | 19 | Using this mecanism results in a {e binding function} that binds OCaml 20 | values to SQL parameters and returns a value of type ['a Stmt.t] that 21 | specifies the type of rows ['a] returned by executing the statement. The type 22 | [unit] is used for the {{!Rel.Row.empty}empty row}. 23 | 24 | For example if you have this SQL statement: 25 | 26 | {@sql[ SELECT name FROM person WHERE age = ? OR surname = ? v]} 27 | 28 | Assuming [age] is an integer and [name] and [surname] are text, 29 | a binding function for that statement would have type 30 | [int -> string -> string Rel_sql.Stmt.t]. It can be typed as follows: 31 | {[ 32 | let names_with_age_or_surname : int -> string -> string Rel_sql.Stmt.t = 33 | let sql = "SELECT name FROM person WHERE id = ? OR surname = ?" in 34 | let name = Row.Quick.(t1 @@ text "name") in 35 | let type' = Rel_sql.Stmt.(int @-> text @-> ret name) in 36 | Rel_sql.Stmt.func sql type' 37 | ]} 38 | 39 | Note that the binding function is only positional in nature it always 40 | binds arguments from left to right. This means you need to be careful 41 | if you later reorder parameters either in your binding function 42 | description or in your SQL. 43 | 44 | {1:binding_projection Binding projections} 45 | 46 | If SQL parameters values are defined by projecting components of an 47 | OCaml values, you want to avoid having to repeat that value in the 48 | binding function. 49 | 50 | For example if we have the statement: 51 | 52 | {@sql[UPDATE person SET age = ? WHERE name = ?]} 53 | 54 | which we update by projecting values from an OCaml value of type 55 | [person] we do not want the type: 56 | 57 | {[ person -> person -> unit Rel_sql.Stmt.t ]} 58 | 59 | we want the type [person -> unit Rel_sql.Stmt.t]. 60 | 61 | This can be achieved with {{!Rel_sql.Stmt.projs}these combinators} 62 | as follows: 63 | 64 | {[ 65 | type person = string * int 66 | let set_age : person -> unit Rel_sql.Stmt.t = 67 | let sql = "UPDATE person SET age = ? WHERE name = ?" in 68 | let typ = Rel_sql.Stmt.(proj snd int @@ proj fst text @@ nop @@ unit) in 69 | Rel_sql.Stmt.func sql typ 70 | ]} -------------------------------------------------------------------------------- /test/test_sqlite3_chinook.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* N.B. assumes Chinook_Sqlite.sqlite in the cwd. *) 7 | 8 | open B0_testing 9 | open Rel 10 | 11 | let ( let* ) = Result.bind 12 | 13 | let with_db f = 14 | B0_std.Result.get_ok' @@ Rel_sqlite3.string_error @@ 15 | let* db = Rel_sqlite3.open' ~mode:Read "Chinook_Sqlite.sqlite" in 16 | let finally () = match Rel_sqlite3.close db with 17 | | Ok () -> () | Error e -> Test.log_fail "%s" (Rel_sqlite3.Error.message e) 18 | in 19 | Fun.protect ~finally @@ fun () -> f db 20 | 21 | module Ad_hoc_schema = struct 22 | module Playlist = struct 23 | type t = { id : int; name : string; } 24 | let v id name = { id; name } 25 | let id p = p.id 26 | let name p = p.name 27 | 28 | let id' = Col.make "PlaylistId" Type.int id 29 | let name' = Col.make "Name" Type.text name 30 | 31 | let table = Table.make "Playlist" Row.(unit v * id' * name') 32 | let pp = Row.value_pp (Table.row table) 33 | end 34 | 35 | let playlists db = 36 | let row = Table.row Playlist.table in 37 | let sql = "select * from Playlist" in 38 | let st = Rel_sql.Stmt.(func sql @@ ret row) in 39 | let* ps = Rel_sqlite3.fold db st List.cons [] in 40 | Format.printf "%a" (Row.value_pp_list ~header:true row) (List.rev ps); 41 | Ok () 42 | 43 | let playlist_id db id = 44 | let row = Table.row Playlist.table in 45 | let sql = "select * from Playlist where PlaylistId = ?1" in 46 | let playlist_with_id = Rel_sql.Stmt.(func sql @@ int @-> ret row) in 47 | let* ps = Rel_sqlite3.fold db (playlist_with_id id) List.cons [] in 48 | Format.printf "\n\nplaylist %d: %a" id Playlist.pp (List.hd ps); 49 | Ok () 50 | 51 | let test = 52 | Test.test "Ad-hoc schema" @@ fun () -> 53 | with_db @@ fun db -> 54 | let* () = playlists db in 55 | let* () = playlist_id db 3 in 56 | let* () = playlist_id db 4 in 57 | Ok () 58 | end 59 | 60 | module Generated_schema = struct 61 | open Rel 62 | open Rel_query.Syntax 63 | open Chinook 64 | 65 | let all_tracks = 66 | let* t = Bag.table Track.table in 67 | Bag.yield t 68 | 69 | let select_track_cols = 70 | let _r = Row.(Track.(t4 trackId' name' composer' unitPrice')) in 71 | let* t = Bag.table Track.table in 72 | Bag.yield (Bag.row (fun a b c d -> (a, b, c, d)) $ 73 | t #. Track.trackId' $ 74 | t #. Track.name' $ 75 | t #. Track.composer' $ 76 | t #. Track.unitPrice') 77 | 78 | let (let* ) = Result.bind 79 | 80 | let run_bag db b row = 81 | let stmt = Rel_query.Sql.of_bag row b in 82 | let* ps = Rel_sqlite3.fold db stmt List.cons [] in 83 | assert (List.length ps = 3503); 84 | Ok () 85 | 86 | let test = 87 | Test.test "Generated schema" @@ fun () -> 88 | with_db @@ fun db -> 89 | let* () = run_bag db all_tracks (Table.row Track.table) in 90 | Ok () 91 | end 92 | 93 | let main () = Test.main @@ fun () -> Test.autorun () 94 | let () = if !Sys.interactive then () else exit (main ()) 95 | -------------------------------------------------------------------------------- /src/cli/rel_cli.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2022 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Cmdliner 7 | 8 | (* Schema format *) 9 | 10 | type schema_format = 11 | [ `Dot of Rel.Schema.dot_rankdir | `Sqlite3 12 | | `Ocaml of [`Intf | `Impl | `Both] ] 13 | 14 | let schema_format ?docs ?(opts = ["f"; "format"]) ~default () = 15 | let formats = 16 | [ "dot", `Dot `LR; "dot-lr", `Dot `LR; "dot-tb", `Dot `TB; 17 | "sqlite3", `Sqlite3; 18 | "ocaml", `Ocaml `Both; "ocaml-mli", `Ocaml `Intf; 19 | "ocaml-ml", `Ocaml `Impl; ] 20 | in 21 | let doc = Printf.sprintf 22 | "Schema output format. $(docv) Must be %s. $(b,dot*) are for dot \ 23 | graphs with given rank directions; pipe to $(b,dot -Tsvg) to \ 24 | generate an SVG file. $(b,ocaml*) is for \ 25 | rel OCaml definitions. Other values are for SQL data definitions \ 26 | in the dialect of the corresponding database management system." 27 | (Arg.doc_alts_enum formats) 28 | in 29 | let docv = "FMT" in 30 | Arg.(value & opt (enum formats) default & info opts ~doc ~docv ?docs) 31 | 32 | (* Renames *) 33 | 34 | let cut_right c s = match String.rindex_opt s c with 35 | | None -> None 36 | | Some i -> 37 | Some (String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)) 38 | 39 | let rename = 40 | let parser s = match cut_right ',' s with 41 | | None -> 42 | Error "Could not parse a table or column rename from %S, missing a comma." 43 | | Some (l, r) -> 44 | match cut_right '.' l with 45 | | None -> Ok (`Rename_table (l, r)) 46 | | Some (t, c) -> Ok (`Rename_col (t, (c, r))) 47 | in 48 | let printer ppf = function 49 | | `Rename_table (s, d) -> Format.fprintf ppf "%s,%s" s d 50 | | `Rename_col (t, (s, d)) -> Format.fprintf ppf "%s.%s,%s" t s d 51 | in 52 | Arg.conv' ~docv:"TBL[.COL],DST" (parser, printer) 53 | 54 | let renames ?docs ?(opts = ["r"; "rename"]) () = 55 | let doc = 56 | "Specifies a table or column rename (repeatable). The option argument \ 57 | has either the form $(i,TBL,DST) to rename table $(i,TBL) to $(i,DST). \ 58 | Or the form $(i,TBL.COL,DST) to rename the column named $(i,COL) of table \ 59 | $(i,TBL) in the source schema to a column named $(i,DST); $(i,TBL) must \ 60 | be a name in the source schema, if it gets renamed by another option \ 61 | this is handled correctly." 62 | in 63 | let docv = "TBL[.COL],DST" in 64 | let sort_renames renames = 65 | let module Smap = Map.Make (String) in 66 | let rec loop cr tr = function 67 | | [] -> 68 | let cr = Smap.fold (fun t rs acc -> (t, rs) :: acc) cr [] in 69 | List.rev cr, List.rev tr 70 | | `Rename_table (s, d) :: rs -> loop cr ((s, d) :: tr) rs 71 | | `Rename_col (t, r) :: rs -> 72 | let add t r cr = match Smap.find_opt t cr with 73 | | None -> Smap.add t [r] cr | Some rs -> Smap.add t (r :: rs) cr 74 | in 75 | loop (add t r cr) tr rs 76 | in 77 | loop Smap.empty [] renames 78 | in 79 | let renames = Arg.(value & opt_all rename [] & info opts ~doc ~docv ?docs) in 80 | Term.(const sort_renames $ renames) 81 | -------------------------------------------------------------------------------- /src/rel_kit.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | module type ID = sig 7 | type t 8 | val type' : t Rel.Type.t 9 | val v : t -> t Rel_query.value 10 | val equal : t Rel_query.value -> t Rel_query.value -> bool Rel_query.value 11 | val ( = ) : t Rel_query.value -> t Rel_query.value -> bool Rel_query.value 12 | val to_text : t Rel_query.value -> string Rel_query.value 13 | val to_string : t -> string 14 | val of_string : string -> (t, string) result 15 | val pp : Format.formatter -> t -> unit 16 | module Set : Set.S with type elt = t 17 | module Map : sig 18 | include Map.S with type key = t 19 | val of_elts : ('a -> key) -> 'a list -> 'a t 20 | val add_to_set : 21 | (module Stdlib.Set.S with type elt = 'a and type t = 'set) -> 22 | key -> 'a -> 'set t -> 'set t 23 | val get_list : key -> 'a list t -> 'a list 24 | end 25 | end 26 | 27 | module type INTABLE_ID = sig 28 | include ID 29 | val zero : t 30 | val to_int : t -> int 31 | val of_int : int -> (t, string) result 32 | end 33 | 34 | module Id = struct 35 | 36 | (** Base signature *) 37 | module type Base = sig 38 | type t 39 | val rel_type : t Rel.Type.t 40 | val rel_make : t -> t Rel_query.value 41 | val rel_equal : 42 | t Rel_query.value -> t Rel_query.value -> bool Rel_query.value 43 | val rel_to_text : t Rel_query.value -> string Rel_query.value 44 | val compare : t -> t -> int 45 | val to_string : t -> string 46 | val of_string : string -> (t, string) result 47 | end 48 | 49 | module Make (Base : Base) () : ID with type t = Base.t = struct 50 | type t = Base.t 51 | let type' = Base.rel_type 52 | let v = Base.rel_make 53 | let equal = Base.rel_equal 54 | let ( = ) = Base.rel_equal 55 | let to_text = Base.rel_to_text 56 | let to_string = Base.to_string 57 | let of_string = Base.of_string 58 | let pp ppf id = Format.pp_print_string ppf (to_string id) 59 | module Set = Set.Make (Base) 60 | module Map = struct 61 | include Map.Make (Base) 62 | let of_elts id l = List.fold_left (fun acc v -> add (id v) v acc) empty l 63 | let get_list k m = Option.value ~default:[] (find_opt k m) 64 | let add_to_set 65 | (type set) (type elt) 66 | (module S : Stdlib.Set.S with type elt = elt and type t = set) 67 | k v m 68 | = 69 | match find_opt k m with 70 | | None -> add k (S.singleton v) m 71 | | Some set -> add k (S.add v set) m 72 | end 73 | end 74 | 75 | module Base_int = struct 76 | type t = int 77 | let rel_type = Rel.Type.int 78 | let rel_make = Rel_query.Int.v 79 | let rel_equal = Rel_query.Int.equal 80 | let rel_to_text = Rel_query.Text.of_int 81 | let compare = Int.compare 82 | let to_string = string_of_int 83 | let of_string s = 84 | let not_id s = Printf.sprintf "%S: not an identifier" s in 85 | match int_of_string_opt s with 86 | | None -> Error (not_id s) 87 | | Some id when id < 0 -> Error (not_id s) 88 | | Some id -> Ok id 89 | end 90 | 91 | module MakeInt () : INTABLE_ID = struct 92 | include Make (Base_int) () 93 | let zero = 0 94 | let to_int = Fun.id 95 | let of_int i = 96 | if i < 0 then Error (Printf.sprintf "%d: not an identifier" i) else Ok i 97 | end 98 | end 99 | -------------------------------------------------------------------------------- /src/rel_kit.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2024 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Schema definition helpers. *) 7 | 8 | (** The type for table identifiers. *) 9 | module type ID = sig 10 | 11 | type t 12 | (** The type for table identifiers. *) 13 | 14 | val type' : t Rel.Type.t 15 | (** The rel type for table identifiers. *) 16 | 17 | val v : t -> t Rel_query.value 18 | (** [v id] injects constants identifiers into queries. *) 19 | 20 | val equal : t Rel_query.value -> t Rel_query.value -> bool Rel_query.value 21 | (** [equal t] *) 22 | 23 | val ( = ) : t Rel_query.value -> t Rel_query.value -> bool Rel_query.value 24 | (** [ ( = )] is {!equal}. *) 25 | 26 | val to_text : t Rel_query.value -> string Rel_query.value 27 | (** [to_text t] is [t] as SQL text. FIXME get rid of that. *) 28 | 29 | val to_string : t -> string 30 | (** [to_string id] should be an UTF-8 compatible encoding of [id]. *) 31 | 32 | val of_string : string -> (t, string) result 33 | (** [of_string s] parses an identifier from [s]. *) 34 | 35 | val pp : Format.formatter -> t -> unit 36 | (** [pp] is a formatter for identifiers. *) 37 | 38 | (** {1:sets and maps Sets and maps} *) 39 | 40 | (** Sets of identifiers. *) 41 | module Set : Set.S with type elt = t 42 | 43 | (** Maps of identifiers. *) 44 | module Map : sig 45 | 46 | include Map.S with type key = t 47 | 48 | (** {1:add Additional adds and gets} *) 49 | 50 | val of_elts : ('a -> key) -> 'a list -> 'a t 51 | (** [of_lets key elts] is a map from elements identified by [key]. *) 52 | 53 | val add_to_set : 54 | (module Stdlib.Set.S with type elt = 'a and type t = 'set) -> 55 | key -> 'a -> 'set t -> 'set t 56 | (** [add (module S) k v m] is [m] with [k] mapping to [s] such 57 | that [s] is [S.add v (find k m)] if [k] was bound in [m] and 58 | [S.singleton [v]] otherwise. *) 59 | 60 | val get_list : key -> 'a list t -> 'a list 61 | (** [get_list k m] is the list bound to [k] in [m] or the empty 62 | list if [k] is unbound. *) 63 | end 64 | end 65 | 66 | (** The type for table identifiers convertible to [int] values. *) 67 | module type INTABLE_ID = sig 68 | 69 | include ID 70 | 71 | val zero : t 72 | (** [zero] is the [0] id. *) 73 | 74 | val to_int : t -> int 75 | (** [to_int id] converts [id] to a non-negative integer. *) 76 | 77 | val of_int : int -> (t, string) result 78 | (** [of_int i] converts [i] to an identifier. Errors if 79 | [i] is negative. *) 80 | end 81 | 82 | (** Types for table identifier. 83 | 84 | {b TODO.} It's not exactly what we want yet. *) 85 | module Id : sig 86 | 87 | (** Base signature *) 88 | module type Base = sig 89 | 90 | type t 91 | (** The type for identifiers. *) 92 | 93 | val rel_type : t Rel.Type.t 94 | (** [rel_type] the [Rel] type for the identifier. *) 95 | 96 | val rel_make : t -> t Rel_query.value 97 | (** [rel_make id] injects constants identifiers into queries. *) 98 | 99 | val rel_equal : 100 | t Rel_query.value -> t Rel_query.value -> bool Rel_query.value 101 | (** [rel_equal id0 id1] determines equality on identifiers in 102 | the query language. *) 103 | 104 | val rel_to_text : t Rel_query.value -> string Rel_query.value 105 | (** [rel_to_text id] is [id] as text. FIXME get rid of that. *) 106 | 107 | val compare : t -> t -> int 108 | (** [compare] is a total order on identifiers. *) 109 | 110 | val to_string : t -> string 111 | (** [to_string id] should be an UTF-8 compatible encoding of [id]. *) 112 | 113 | val of_string : string -> (t, string) result 114 | (** [of_string s] parses an identifier from [s]. *) 115 | end 116 | 117 | (** [Make (Base) ()] are identifiers from the base type {!Base}. *) 118 | module Make (Base : Base) () : ID with type t = Base.t 119 | 120 | (** {!Rel.Type.int} identifiers (XXX this should be abstract) *) 121 | module MakeInt () : INTABLE_ID 122 | end 123 | -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | open Result.Syntax 3 | 4 | (* OCaml library names *) 5 | 6 | let threads = B0_ocaml.libname "threads.posix" 7 | let cmdliner = B0_ocaml.libname "cmdliner" 8 | let b0_std = B0_ocaml.libname "b0.std" 9 | 10 | let rel = B0_ocaml.libname "rel" 11 | let rel_pool = B0_ocaml.libname "rel.pool" 12 | let rel_cli = B0_ocaml.libname "rel.cli" 13 | let rel_sqlite3 = B0_ocaml.libname "rel.sqlite3" 14 | 15 | (* Libraries *) 16 | 17 | let rel_lib = 18 | let srcs = [ `Dir ~/"src" ] in 19 | B0_ocaml.lib rel ~name:"rel-lib" ~srcs 20 | 21 | let rel_cli_lib = 22 | let srcs = [ `Dir ~/"src/cli" ] in 23 | B0_ocaml.lib rel_cli ~srcs ~requires:[rel; cmdliner] 24 | 25 | let rel_sqlite3_lib = 26 | let stubs =`File ~/"src/sqlite3/rel_sqlite3_stubs.c" in 27 | let srcs = [stubs; `Dir ~/"src/sqlite3" ]in 28 | let c_requires = Cmd.arg "-lsqlite3" in 29 | B0_ocaml.lib rel_sqlite3 ~srcs ~requires:[rel] ~c_requires 30 | 31 | let rel_pool_lib = (* We can put that into the rel library on OCaml > 5. *) 32 | let srcs = [`Dir ~/"src/pool"] in 33 | let requires = [threads] in 34 | B0_ocaml.lib rel_pool ~srcs ~requires 35 | 36 | (* Tools *) 37 | 38 | let rel_tool = 39 | let srcs = [ `Dir ~/"src/tool" ] in 40 | let requires = [cmdliner; rel; rel_cli; rel_sqlite3] in 41 | B0_ocaml.exe "rel" ~public:true ~srcs ~requires ~doc:"Rel tool" 42 | 43 | (* Tests *) 44 | 45 | let test ?doc ?run:(r = true) ?(requires = []) ?(srcs = []) src = 46 | let srcs = (`File src) :: srcs in 47 | let requires = b0_std :: rel :: requires in 48 | let meta = 49 | B0_meta.empty 50 | |> B0_meta.(tag test) 51 | |> ~~ B0_meta.run r 52 | |> ~~ B0_unit.Action.cwd (`In (`Scope_dir, ~/"test")) 53 | in 54 | let name = Fpath.basename ~strip_exts:true src in 55 | B0_ocaml.exe name ~srcs ~requires ~meta ?doc 56 | 57 | let chinook = [`File ~/"test/chinook.ml"] 58 | let schemas = [`File ~/"test/schemas.ml"] 59 | 60 | let test_rel = test ~/"test/test_rel.ml" 61 | let test_rel = test ~/"test/test_query.ml" 62 | let test_sql = 63 | test ~/"test/test_sql.ml" ~requires:[rel_sqlite3] ~srcs:schemas 64 | 65 | let test_sqlite3_stub = 66 | test ~/"test/test_sqlite3_stub.ml" ~requires:[rel_sqlite3] ~srcs:schemas 67 | 68 | let test_sqlite3_chinook = 69 | test ~/"test/test_sqlite3_chinook.ml" ~requires:[rel_sqlite3] ~srcs:chinook 70 | 71 | let test_issue_4 = test ~/"test/test_issue_4.ml" ~requires:[rel_sqlite3] 72 | 73 | let examples = test ~/"test/examples.ml" ~run:false 74 | 75 | (* Test data *) 76 | 77 | let chinook_sqlite3_url = 78 | "https://github.com/lerocha/chinook-database/releases/latest/\ 79 | download/Chinook_Sqlite.sqlite" 80 | 81 | let download_chinook = 82 | let doc = "Download the Chinook test database to test/" in 83 | B0_unit.of_action "download-chinook" ~doc @@ fun env _ ~args:_ -> 84 | let file = B0_env.in_scope_dir env ~/"test/Chinook_Sqlite.sqlite" in 85 | B0_action_kit.fetch_url env chinook_sqlite3_url file 86 | 87 | (* Packs *) 88 | 89 | let default = 90 | let meta = 91 | B0_meta.empty 92 | |> ~~ B0_meta.authors ["The rel programmers"] 93 | |> ~~ B0_meta.maintainers ["Daniel Bünzli "] 94 | |> ~~ B0_meta.homepage "https://erratique.ch/software/rel" 95 | |> ~~ B0_meta.online_doc "https://erratique.ch/software/rel/doc" 96 | |> ~~ B0_meta.repo "git+https://erratique.ch/repos/rel.git" 97 | |> ~~ B0_meta.issues "https://github.com/dbuenzli/rel/issues" 98 | |> ~~ B0_meta.description_tags 99 | ["database"; "query"; "SQL"; "org:erratique"; ] 100 | |> ~~ B0_meta.licenses ["ISC"] 101 | |> ~~ B0_opam.depopts ["conf-sqlite3", ""] 102 | |> ~~ B0_opam.build 103 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%" 104 | "--with-conf-sqlite3" "%{conf-sqlite3:installed}%" ]]|} 105 | |> ~~ B0_opam.depends 106 | [ "ocaml", {|>= "4.14.0"|}; 107 | "ocamlfind", {|build|}; 108 | "ocamlbuild", {|build|}; 109 | "topkg", {|build & >= "1.1.0"|}; 110 | "cmdliner", {|>= "1.3.0"|}; 111 | ] 112 | |> B0_meta.tag B0_opam.tag 113 | |> B0_meta.tag B0_release.tag 114 | in 115 | B0_pack.make "default" ~doc:"rel package" ~meta ~locked:true @@ 116 | B0_unit.list () 117 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Rel {%html: %%VERSION%%%}} 2 | 3 | Rel is a library for programming with relational databases in OCaml. 4 | It provides: 5 | 6 | - Typed combinators to describe database rows and their representation 7 | as custom OCaml values. 8 | - Typed combinators to describe database schemas. Schemas can be 9 | translated to SQL data definitions or, conversly, generated for 10 | existing databases (external schema definition). 11 | - Automatic schema change computation via schema diffing. 12 | - Raw SQL statements typing and SQL generation helpers. 13 | - Query language embedded in *plain* OCaml. Queries are typed, 14 | composable and compile to a single, flat, SQL query (experimental). 15 | - Support for using SQLite3 databases. 16 | 17 | {1:manuals Manuals} 18 | 19 | A few things are {{!todo}TODO}. 20 | 21 | These manuals are available: 22 | 23 | - The {{!page-tutorial}database tutorial} is a short tutorial. It 24 | assumes you have SQLite3 installed, that you want to make your own 25 | database and that you want to fully model it in OCaml. 26 | - The {{!page-query_tutorial}query tutorial} is a short tutorial. It 27 | assumes you need to query an existing SQLite3 database. 28 | - The schema {{!page-schema_quickstart}quick start} and 29 | {{!page-schema_howto}how-to} discusses how to manage your 30 | database schema when using Rel. 31 | - The query {{!page-query_quickstart}quick start} and 32 | {{!page-query_howto}how-to} discusses how to query your data 33 | ith Rel's embedded query language. 34 | - The SQLite3 {{!page-sqlite3_quickstart}quick start} and 35 | {{!page-sqlite3_howto}how-to} explain how to deal with SQLite3 36 | databases. 37 | - The {{!page-sql_stmt_manual}SQL statement typing manual} explains the 38 | low-level mecanism to type and execute SQL statements. 39 | 40 | {1:rel The [rel] library} 41 | 42 | {!modules: 43 | Rel 44 | Rel_sql 45 | Rel_query 46 | Rel_list 47 | Rel_kit 48 | } 49 | 50 | {1:dbms_support Database management systems} 51 | 52 | Each of these modules live in its own [rel.*] library. 53 | 54 | {!modules: 55 | Rel_sqlite3 56 | } 57 | 58 | {1:convenience Convenience libraries} 59 | 60 | Each of these modules live in its own [rel.*] library. 61 | 62 | {!modules: 63 | Rel_kit 64 | Rel_cli 65 | Rel_pool 66 | } 67 | 68 | {1:todo TODO} 69 | 70 | - SQLite seems quite unique in not specifying a size for 71 | text. We likely need to add an int to {!Rel.Type.Text} at some 72 | point. 73 | 74 | - When we try to prepare a statement with a comment, our error 75 | path through the DB handle gets a misleading out of memory 76 | error. If we consult the error message of the code it's SQL_MISUSE. 77 | (?) a bit unclear what the correct workflow is here. 78 | 79 | - A simple short, {{!page-tutorial}tutorial}. 80 | 81 | - {!Rel} should maybe depend on {!Rel_sql}, or possibly have a 82 | pre-Rel_sql with the expression language, since we will hit 83 | recursive dependencies. One issue is that we would like to be able 84 | to define an expression for the default of columns. This should be 85 | parametric on the dialect and/or be a structured SQL expression. 86 | 87 | - Having {!Rel_sql.type-dialect} at the level of statements creation 88 | is a bit annoying. Maybe go back to the idea of having an AST in 89 | {!Rel_sql.Stmt.src}. The backends then directly act on this. The only thing 90 | we need is something that is fast to test for equality for caches of 91 | prepared statements. 92 | 93 | - {!Rel.Col} need a collation parameter. Also the [`Expr] 94 | {!Rel.Col.type-default} case is unsatisfying it should be either an SQL 95 | expression AST or at least be a function of the dialect (which gets 96 | us into recursive trouble). Also for indexes this is not as 97 | expressive as it 98 | {{:https://www.sqlite.org/syntax/indexed-column.html}could be}. 99 | 100 | - Sort-out the naming stuff. For constraints and indices (the 101 | {!Rel.Table.Index.get_name} stuff is not that great, should we simply 102 | have [""] as a default and rename when we add to a table ?) 103 | 104 | - Table updates or inserts we can likely avoid going through listts of 105 | {!Rel.Col.value} value but that's not what we have in the API at the 106 | moment. 107 | 108 | - {!Rel_sqlite3} changes. Be smarter on tables changes that involve 109 | only index/add drops. -------------------------------------------------------------------------------- /src/rel_list.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Rel 7 | 8 | module Table_env = struct 9 | 10 | (* Note. Making that typed is possible but a bit unconvenient. We'd need a 11 | type identifier in `Table.t` values which would make constructing them 12 | more involved (value restriction if we care about objects) and we 13 | actually don't need them for the SQL main use case. Let's go with the 14 | heresy for now. *) 15 | 16 | type binding = Obj.t * Obj.t 17 | type t = binding list 18 | let empty = [] 19 | let add : type a. a Table.t -> a list -> t -> t = 20 | fun k v m -> (Obj.repr k, Obj.repr v) :: m 21 | 22 | let find : type a. a Table.t -> t -> a list option = 23 | fun k m -> Option.map Obj.obj (List.assq_opt (Obj.repr k) m) 24 | end 25 | 26 | let list_concat_map f l = (* available in 4.10 *) 27 | let rec loop f acc = function 28 | | [] -> List.rev acc 29 | | v :: vs -> loop f (List.rev_append (f v) acc) vs 30 | in 31 | loop f [] l 32 | 33 | (* Evaluation error *) 34 | 35 | type error = 36 | [ `Undefined_table of Table.def 37 | | `Unknown_extension of string 38 | | `Unexpected_variable of string ] 39 | 40 | exception Error of error 41 | let undefined t = raise_notrace (Error (`Undefined_table t)) 42 | let unknown_extension k = raise_notrace (Error (`Unknown_extension k)) 43 | let unexpected_variable n = raise_notrace (Error (`Unexpected_variable n)) 44 | 45 | let error_to_string = function 46 | | `Undefined_table (Table.Def t) -> "Undefined table: " ^ (Table.name t) 47 | | `Unknown_extension kind -> String.concat "" ["Unknown "; kind; " extension"] 48 | | `Unexpected_variable v -> "Unexpected variable " ^ v 49 | 50 | (* Evaluation *) 51 | 52 | let rec eval_add : type t. t Type.Repr.t -> t -> t -> t = function 53 | | Int -> Int.add | Int64 -> Int64.add | Float -> Float.add 54 | | _ -> unknown_extension "addition" 55 | 56 | let rec eval_sub : type t. t Type.Repr.t -> t -> t -> t = function 57 | | Int -> Int.sub | Int64 -> Int64.sub | Float -> Float.sub 58 | | _ -> unknown_extension "subtraction" 59 | 60 | let rec eval_mul : type t. t Type.Repr.t -> t -> t -> t = function 61 | | Int -> Int.mul | Int64 -> Int64.mul | Float -> Float.mul 62 | | _ -> unknown_extension "multiplication" 63 | 64 | let rec eval_div : type t. t Type.Repr.t -> t -> t -> t = function 65 | | Int -> Int.div | Int64 -> Int64.div | Float -> Float.div 66 | | _ -> unknown_extension "division" 67 | 68 | open Rel_query.Private 69 | 70 | let eval_unop : type a r. (a, r) unop -> a -> r = 71 | fun op x -> match op with 72 | | Neg t -> 73 | begin match t with 74 | | Bool -> Bool.not x 75 | | Int -> Int.neg x 76 | | Int64 -> Int64.neg x 77 | | Float -> Float.neg x 78 | | _ -> unknown_extension "negation" 79 | end 80 | | _ -> unknown_extension "unary operation" 81 | 82 | let eval_binop : type a r. (a, r) binop -> a -> a -> r = 83 | fun op x y -> match op with 84 | | Arith (op, t) -> 85 | begin match op with 86 | | Add -> eval_add t x y 87 | | Sub -> eval_sub t x y 88 | | Mul -> eval_mul t x y 89 | | Div -> eval_div t x y 90 | end 91 | | Cmp (op, t) -> 92 | begin match op with 93 | | Eq -> x = y 94 | | Neq -> x <> y 95 | | Lt -> x < y 96 | | Leq -> x <= y 97 | | Gt -> x > y 98 | | Geq -> x >= y 99 | end 100 | | And -> Bool.( && ) x y 101 | | Or -> Bool.( || ) x y 102 | | _ -> unknown_extension "binary operation" 103 | 104 | let rec eval_value : type r. Table_env.t -> r value -> r = 105 | fun e v -> match v with 106 | | Const (_, v) -> v 107 | | Unop (op, v) -> eval_unop op (eval_value e v) 108 | | Binop (op, x, y) -> eval_binop op (eval_value e x) (eval_value e y) 109 | | Proj (r, c) -> (Rel.Col.proj c) (eval_value e r) 110 | | Row f -> f 111 | | Tuple (f, v) -> (eval_value e f) (eval_value e v) 112 | | Exists b -> eval_bag e b <> [] 113 | | Var n -> unexpected_variable n 114 | 115 | and eval_bag : type r e. Table_env.t -> (r, e) bag -> r list = 116 | fun e b -> match b with 117 | | Table t -> 118 | begin match Table_env.find t e with 119 | | None -> undefined (Table.Def t) 120 | | Some l -> l 121 | end 122 | | Empty -> [] 123 | | Yield v -> [eval_value e v] 124 | | Union (b0, b1) -> List.append (eval_bag e b0) (eval_bag e b1) 125 | | Foreach (b, y) -> 126 | let l = eval_bag e b in 127 | let yield v = eval_bag e (y (Row v)) in 128 | list_concat_map yield l 129 | | Where (c, b) -> if eval_value e c then eval_bag e b else [] 130 | 131 | let of_bag e b = try Ok (eval_bag e (bag_to_bag b)) with 132 | | Error k -> Error k 133 | -------------------------------------------------------------------------------- /src/rel_sql.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Rel 7 | 8 | module Fmt = struct 9 | let str = Format.asprintf 10 | let pf = Format.fprintf 11 | let comma ppf _ = Format.pp_print_char ppf ','; Format.pp_print_space ppf () 12 | let string = Format.pp_print_string 13 | let hbox pp_v ppf v = 14 | Format.(pp_open_hbox ppf (); pp_v ppf v; pp_close_box ppf ()) 15 | 16 | let lines ppf s = 17 | let ls = String.split_on_char '\n' s in 18 | Format.pp_print_list ~pp_sep:Format.pp_force_newline string ppf ls 19 | end 20 | 21 | module Stmt = struct 22 | type arg = Arg : 'a Type.t * 'a -> arg 23 | let pp_arg ppf (Arg (t, v)) = Type.value_pp t ppf v 24 | 25 | type 'r t = { src : string; rev_args : arg list; result : 'r Row.t; } 26 | let v src ~rev_args ~result = { src; rev_args; result } 27 | let src st = st.src 28 | let result st = st.result 29 | let rev_args st = st.rev_args 30 | let pp_src ppf st = Fmt.lines ppf st.src 31 | let pp ppf st = 32 | Fmt.pf ppf "@[%a@,@[%a@]@]" 33 | Fmt.lines st.src 34 | (Format.pp_print_list ~pp_sep:(Format.pp_print_space) pp_arg) 35 | (List.rev st.rev_args) 36 | 37 | type 'a func = string -> arg list -> 'a 38 | let func src f = f src [] 39 | let ret result = fun src rev_args -> { src; rev_args; result} 40 | let ret_rev result = 41 | fun src args -> { src; rev_args = List.rev args; result } 42 | 43 | let arg t f = fun src rev_args v -> f src (Arg (t, v) :: rev_args) 44 | let ( @-> ) = arg 45 | 46 | let unit = ret Row.empty 47 | let bool = Type.bool 48 | let int = Type.int 49 | let int64 = Type.int64 50 | let float = Type.float 51 | let text = Type.text 52 | let blob = Type.blob 53 | let option v = (Type.option v) 54 | let nop f = fun src rev_args v -> f src rev_args 55 | let proj p t f = fun src rev_args r -> f src (Arg (t, p r) :: rev_args) r 56 | let col : 57 | type r a. (r, a) Col.t -> (r -> 'b) func -> (r -> 'b) func = 58 | fun col f -> fun src rev_args r -> 59 | let arg = Arg (Col.type' col, (Col.proj col) r) in 60 | f src (arg :: rev_args) r 61 | end 62 | 63 | module Syntax = struct 64 | let sql_quote qchar s = 65 | let len = String.length s in 66 | let qlen = ref (len + 2) in 67 | for i = 0 to len - 1 do if s.[i] = qchar then incr qlen done; 68 | let b = Bytes.make !qlen qchar in 69 | match !qlen = len + 2 with 70 | | true -> Bytes.blit_string s 0 b 1 len; Bytes.unsafe_to_string b 71 | | false -> 72 | let k = ref 1 in 73 | for i = 0 to len - 1 do 74 | Bytes.set b !k s.[i]; 75 | k := !k + if s.[i] = qchar then 2 else 1; 76 | done; 77 | Bytes.unsafe_to_string b 78 | 79 | let sql_unquote kind qchar s = 80 | try 81 | (* N.B. this will accept strings with single internal qchar *) 82 | let len = String.length s in 83 | if len < 2 || s.[0] <> qchar || s.[len - 1] <> qchar 84 | then failwith (Fmt.str "%S: not a %s (missing %c)" s kind qchar) else 85 | let rec find_len last len max i = 86 | if i > max then len else 87 | if last = qchar && s.[i] = qchar 88 | then find_len '\x00' len max (i + 1) 89 | else find_len s.[i] (len + 1) max (i + 1) 90 | in 91 | let slen = find_len '\x00' 0 (len - 2) 1 in 92 | if slen = len - 2 then Ok (String.sub s 1 (len - 2)) else 93 | let b = Bytes.create slen in 94 | let rec loop max b i s k last = match i > max with 95 | | true -> Ok (Bytes.unsafe_to_string b) 96 | | false -> 97 | if last = qchar && s.[k] = qchar 98 | then loop max b i s (k + 1) '\x00' 99 | else (Bytes.set b i s.[k]; loop max b (i + 1) s (k + 1) s.[k]) 100 | in 101 | loop (slen - 1) b 0 s 1 '\x00' 102 | with 103 | | Failure e -> Error e 104 | 105 | let string_to_literal s = sql_quote '\'' s 106 | let string_of_literal s = sql_unquote "string literal" '\'' s 107 | 108 | let id s = sql_quote '\"' s 109 | let id_in_schema ?schema i = match schema with 110 | | None -> id i | Some s -> Fmt.str "%s.%s" (id s) (id i) 111 | 112 | let sort_order_keyword = function `Asc -> "ASC" | `Desc -> "DESC" 113 | let foreign_key_action_keyword = function 114 | | `Set_null -> "SET NULL" | `Set_default -> "SET DEFAULT" 115 | | `Cascade -> "CASCADE" | `Restrict -> "RESTRICT" 116 | end 117 | 118 | type insert_or_action = [`Abort | `Fail | `Ignore | `Replace | `Rollback ] 119 | 120 | module type DIALECT = sig 121 | val kind : string 122 | 123 | val insert_into : 124 | ?or_action:insert_or_action -> ?schema:Schema.name -> 125 | ?ignore:'r Col.def list -> 'r Table.t -> ('r -> unit Stmt.t) 126 | 127 | val insert_into_cols : 128 | ?schema:Schema.name -> ?ignore:'r Col.def list -> 'r Table.t -> 129 | ('r Col.value list -> unit Stmt.t) 130 | 131 | val update : 132 | ?schema:Schema.name -> 'r Table.t -> set:'r Col.value list -> 133 | where:'r Col.value list -> unit Stmt.t 134 | 135 | val delete_from : 136 | ?schema:string -> 'r Table.t -> where:'r Col.value list -> 137 | unit Stmt.t 138 | 139 | val create_table : 140 | ?schema:Schema.name -> ?if_not_exists:unit -> 'r Table.t -> unit Stmt.t 141 | 142 | val drop_table : 143 | ?schema:Schema.name -> ?if_exists:unit -> 'r Table.t -> unit Stmt.t 144 | 145 | val create_index : 146 | ?schema:Schema.name -> ?if_not_exists:unit -> 'r Table.t -> 147 | 'r Table.Index.t -> unit Stmt.t 148 | 149 | val drop_index : 150 | ?schema:Schema.name -> ?if_exists:unit -> 'r Table.t -> 'r Table.Index.t -> 151 | unit Stmt.t 152 | 153 | val schema_changes : 154 | ?schema:Schema.name -> Schema.change list -> bool * unit Stmt.t list 155 | end 156 | 157 | type dialect = (module DIALECT) 158 | 159 | let insert_into (module Sql : DIALECT) ?or_action ?schema ?ignore t = 160 | Sql.insert_into ?or_action ?schema ?ignore t 161 | 162 | let insert_into_cols (module Sql : DIALECT) ?schema ?ignore t cols = 163 | Sql.insert_into_cols ?schema ?ignore t cols 164 | 165 | let update (module Sql : DIALECT) ?schema t ~set ~where = 166 | Sql.update ?schema t ~set ~where 167 | 168 | let delete_from (module Sql : DIALECT) ?schema t ~where = 169 | Sql.delete_from ?schema t ~where 170 | 171 | let create_table (module Sql : DIALECT) ?schema ?if_not_exists t = 172 | Sql.create_table ?schema ?if_not_exists t 173 | 174 | let drop_table (module Sql : DIALECT) ?schema ?if_exists t = 175 | Sql.drop_table ?schema ?if_exists t 176 | 177 | let create_index (module Sql : DIALECT) ?schema ?if_not_exists t i = 178 | Sql.create_index ?schema ?if_not_exists t i 179 | 180 | let drop_index (module Sql : DIALECT) ?schema ?if_exists t i = 181 | Sql.drop_index ?schema ?if_exists t i 182 | 183 | let create_schema (module Sql : DIALECT) s = 184 | let schema = Schema.name s in 185 | let add_table acc (Table.Def t) = 186 | let acc = Sql.create_table ?schema t :: acc in 187 | let add_index acc i = Sql.create_index ?schema t i :: acc in 188 | List.fold_left add_index acc (Table.indices t) 189 | in 190 | List.rev (List.fold_left add_table [] (Schema.tables s)) 191 | 192 | let drop_schema (module Sql : DIALECT) ?if_exists s = 193 | let schema = Schema.name s in 194 | let drop_table (Table.Def t) = Sql.drop_table ?schema ?if_exists t in 195 | List.rev_map drop_table (Schema.tables s) 196 | 197 | let schema_changes (module Sql : DIALECT) ?schema cs = 198 | Sql.schema_changes ?schema cs 199 | -------------------------------------------------------------------------------- /src/tool/rel_tool.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Rel 7 | 8 | (* Preliminaries *) 9 | 10 | let ( let* ) = Result.bind 11 | let exec = Filename.basename Sys.executable_name 12 | 13 | let tty_bold = "\027[01m" 14 | let tty_red_bold = "\027[31;01m" 15 | let tty_reset = "\027[m" 16 | let pp_code ppf s = Format.fprintf ppf "@<0>%s%s@<0>%s" tty_bold s tty_reset 17 | let log_err fmt = 18 | Format.eprintf ("@[%s: @<0>%s%s@<0>%s: " ^^ fmt ^^ "@]@.") 19 | exec tty_red_bold "Error" tty_reset 20 | 21 | let log_if_error ~use = function Ok v -> v | Error e -> log_err "%s" e; use 22 | 23 | let log_warn fmt = Format.eprintf ("Warning: " ^^ fmt ^^ "@.") 24 | 25 | let strf = Format.sprintf 26 | let pf = Format.fprintf 27 | let pr = Format.printf 28 | 29 | let string_of_file file = 30 | try 31 | if file = "-" 32 | then Ok (In_channel.input_all stdin) 33 | else Ok (In_channel.with_open_bin file In_channel.input_all) 34 | with Sys_error e -> Error e 35 | 36 | (* Schema lookup *) 37 | 38 | let sqlite3_db_of_sql sql_file = (* Create an in-memory db for the sql file. *) 39 | let* sql = string_of_file sql_file in 40 | Rel_sqlite3.string_error @@ Result.join @@ 41 | let* db = Rel_sqlite3.(open' ~mode:Memory "") in 42 | Rel_sqlite3.with_transaction `Immediate db @@ fun db -> 43 | let* () = Rel_sqlite3.exec_sql db sql in 44 | Ok db 45 | 46 | let file_error file = Result.map_error (strf "%s: %s" file) 47 | 48 | let get_sqlite3_schema spec = 49 | let* file, db = match spec with 50 | | `Sqlite3 "-" -> Error (strf "Cannot read an SQlite3 file from stdin") 51 | | `Sqlite3 file -> 52 | file_error file @@ 53 | let* db = Rel_sqlite3.(open' ~mode:Read file |> string_error) in 54 | Ok (file, db) 55 | | `Sqlite3_sql file -> 56 | file_error file @@ 57 | let* db = sqlite3_db_of_sql file in 58 | Ok (file, db) 59 | in 60 | let finally () = log_if_error ~use:() Rel_sqlite3.(close db |> string_error)in 61 | Fun.protect ~finally @@ fun () -> 62 | file_error file @@ 63 | let* (s, issues) = Rel_sqlite3.(schema_of_db db |> string_error) in 64 | Ok (file, s, issues) 65 | 66 | let get_schema db_spec = match db_spec with 67 | | (`Sqlite3 _ | `Sqlite3_sql _ as db_spec) -> get_sqlite3_schema db_spec 68 | 69 | (* Schema command *) 70 | 71 | let schema db_spec format = 72 | log_if_error ~use:Cmdliner.Cmd.Exit.some_error @@ 73 | let* _, s, issues = get_schema db_spec in 74 | let* () = match format with 75 | | `Dot rankdir -> pr "@[%a@]@." (Schema.pp_dot ~rankdir) s; Ok () 76 | | `Sqlite3 -> 77 | let stmts = Rel_sql.create_schema Rel_sqlite3.dialect s in 78 | pr "@[%a@]@." (Format.pp_print_list Rel_sql.Stmt.pp_src) stmts; Ok () 79 | | `Ocaml kind -> 80 | let* () = Schema.must_be_dag s in 81 | pr "@[%a@]@." (Schema.pp_ocaml kind) s; Ok () 82 | in 83 | List.iter (log_warn "%s") issues; 84 | Ok 0 85 | 86 | (* Changes command *) 87 | 88 | let changes (col_renames, table_renames) src dst' format = 89 | log_if_error ~use:Cmdliner.Cmd.Exit.some_error @@ 90 | let* src_file, src, src_issues = get_schema src in 91 | let* dst_file, dst, dst_issues = get_schema dst' in 92 | List.iter (log_warn "%s: %s" src_file) src_issues; 93 | List.iter (log_warn "%s: %s" dst_file) dst_issues; 94 | let* cs = Schema.changes ~col_renames ~table_renames ~src ~dst () in 95 | begin match format with 96 | | None -> 97 | begin match dst' with 98 | | `Sqlite3 _ | `Sqlite3_sql _ -> 99 | let _, stmts = Rel_sql.schema_changes Rel_sqlite3.dialect cs in 100 | pr "@[%a@]@." (Format.pp_print_list Rel_sql.Stmt.pp_src) stmts 101 | end 102 | | Some `Pseudo_sql -> 103 | pr "@[%a@]" (Format.pp_print_list Schema.pp_change) cs; 104 | | Some `Sqlite3 -> 105 | let _, stmts = Rel_sql.schema_changes Rel_sqlite3.dialect cs in 106 | pr "@[%a@]@." (Format.pp_print_list Rel_sql.Stmt.pp_src) stmts 107 | end; 108 | Ok 0 109 | 110 | (* Command line interface *) 111 | 112 | open Cmdliner 113 | 114 | let db_spec = 115 | let prefixes = 116 | [ "sqlite3://", (fun s -> `Sqlite3 s); 117 | "sqlite3-sql://", (fun s -> `Sqlite3_sql s) ] 118 | in 119 | let is_prefix s (prefix, c) = 120 | let plen = String.length prefix in 121 | if String.starts_with ~prefix s 122 | then Some (c (String.sub s plen (String.length s - plen))) 123 | else None 124 | in 125 | let parser s = match List.find_map (is_prefix s) prefixes with 126 | | Some p -> Ok p 127 | | None -> 128 | if Filename.check_suffix s ".sql" 129 | then Ok (`Sqlite3_sql s) 130 | else Ok (`Sqlite3 s) 131 | in 132 | let printer ppf = function 133 | | `Sqlite3 file -> Format.fprintf ppf "sqlite3://%s" file 134 | | `Sqlite3_sql file -> Format.fprintf ppf "sqlite3-sql://%s" file 135 | in 136 | Arg.conv' ~docv:"DB[.sql]" (parser, printer) 137 | 138 | let db_docv = "DB[.sql]" 139 | let db_spec_doc = 140 | "The database $(docv) to consider. If this is a file ending with $(b,.sql), \ 141 | a text file with SQLite SQL data definitions is expected. Otherwise an \ 142 | SQLite database file is expected. Expectations can be forced by prefixing \ 143 | the file with either $(b,sqlite3-sql://) or $(b,sqlite3://)." 144 | 145 | let schema_cmd = 146 | let doc = "Output database schemas" in 147 | let man = [ 148 | `S Manpage.s_description; 149 | `P "$(tname) outputs database schemas in various formats."; ] 150 | in 151 | let db = 152 | let doc = db_spec_doc and docv = db_docv in 153 | Arg.(required & pos 0 (some db_spec) None & info [] ~doc ~docv) 154 | in 155 | let format = Rel_cli.schema_format ~default:(`Ocaml `Both) () in 156 | Cmd.v (Cmd.info "schema" ~doc ~man) Term.(const schema $ db $ format) 157 | 158 | let changes_cmd = 159 | let doc = "Output changes between database schemas" in 160 | let man = [ 161 | `S Manpage.s_description; 162 | `P "$(tname) outputs SQL data definitions to execute on a source schema \ 163 | to bring it to a destination schema."; 164 | `P "Table and column renames are not detected automatically and need \ 165 | to be specified via the $(b,--rename) option."; 166 | `P "$(b,WARNING) always make a database backup and check the steps \ 167 | yourself before applying them."; ] 168 | in 169 | let src = 170 | let doc = db_spec_doc and docv = "SRC[.sql]" in 171 | Arg.(required & pos 0 (some db_spec) None & info [] ~doc ~docv) 172 | in 173 | let dst = 174 | let doc = db_spec_doc and docv = "DST[.sql]" in 175 | Arg.(required & pos 1 (some db_spec) None & info [] ~doc ~docv) 176 | in 177 | let format = 178 | let formats = [ "pseudo-sql", `Pseudo_sql; "sqlite3", `Sqlite3; ] in 179 | let doc = Printf.sprintf 180 | "Changes output format, by default outputs SQL data definition in \ 181 | the dialect of the destination. $(docv) must be %s. $(b,pseudo-sql) \ 182 | is an ad-hoc format used for understanding. Other values are \ 183 | for SQL data definitions in the dialect of the corresponding \ 184 | database management system." 185 | (Arg.doc_alts_enum formats) 186 | in 187 | let docv = "FMT" in 188 | Arg.(value & opt (some (enum formats)) None & info ["format"] ~doc ~docv) 189 | in 190 | Cmd.v (Cmd.info "changes" ~doc ~man) 191 | Term.(const changes $ Rel_cli.renames () $ src $ dst $ format) 192 | 193 | let cmd = 194 | let doc = "Rel database schema tool" in 195 | let man = [ 196 | `S Manpage.s_description; 197 | `P "$(tname) is a database schema tool. It outputs database \ 198 | schemas in various formats and compute schema changes."; 199 | `S Manpage.s_bugs; 200 | `P "This program is distributed with the Rel OCaml library. 201 | See https://erratique.ch/software/rel for contact information"; ] 202 | in 203 | let info = Cmd.info exec ~version:"%%VERSION%%" ~doc ~man in 204 | Cmd.group info [schema_cmd; changes_cmd] 205 | 206 | let main () = Cmd.eval' cmd 207 | let () = if !Sys.interactive then () else exit (main ()) 208 | -------------------------------------------------------------------------------- /test/test_sql.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_testing 7 | 8 | (* FIXME rewrites w.r.t. to API evolution. *) 9 | 10 | open Rel 11 | open Rel_query.Syntax 12 | 13 | let ( let* ) = Result.bind 14 | 15 | let debug = false 16 | 17 | let log fmt = 18 | if debug then Format.printf (fmt ^^ "@.") else 19 | Format.ifprintf Format.std_formatter (fmt ^^ "@.") 20 | 21 | let log_sql what sql = log "@[Executing %s@,---@,%s@,---@,@]" what sql 22 | 23 | let create_schema db schema = 24 | List.iter (fun s -> log_sql "schema" (Rel_sql.Stmt.src s)) schema; 25 | List.iter (fun s -> ignore (Rel_sqlite3.exec db s)) schema; 26 | Ok () 27 | 28 | let insert_row db sql r = 29 | let st = sql r in 30 | log_sql "insert" (Rel_sql.Stmt.src st); 31 | Rel_sqlite3.exec db st 32 | 33 | let rec insert_rows db sql t = function 34 | | [] -> Ok () 35 | | r :: rs -> 36 | log "Inserting row: %a" (Row.value_pp (Table.row t)) r; 37 | match insert_row db sql r with 38 | | Error _ as e -> e | Ok () -> insert_rows db sql t rs 39 | 40 | let select_rows db bag row = 41 | let st = Rel_query.Sql.of_bag row bag in 42 | log_sql "select" (Rel_sql.Stmt.src st); 43 | let* ops = Rel_sqlite3.fold db st List.cons [] in 44 | let ops = List.rev ops in 45 | log "@[%a@,---@]" (Row.value_pp_list ~header:true row) ops; 46 | Ok () 47 | 48 | let with_in_memory_db f = 49 | B0_std.Result.get_ok' @@ Rel_sqlite3.string_error @@ 50 | let* db = Rel_sqlite3.open' ~mode:Memory "" in 51 | let finally () = match Rel_sqlite3.close db with 52 | | Ok () -> () | Error e -> Test.log_fail "%s" (Rel_sqlite3.Error.message e) 53 | in 54 | Fun.protect ~finally @@ fun () -> f db 55 | 56 | (* 57 | module Test_sql_src = struct 58 | open Test_schema.Products_flat_with_objects 59 | open Rel_query.Syntax 60 | 61 | let sql = "SELECT * FROM product WHERE name = $1 and price = $2" 62 | let req = 63 | Rel_sql.Stmt.(func sql @@ text @-> int @-> ret (Table.row S.product_table)) 64 | 65 | let order2 = Q.get_order (Int.v 2) 66 | let order2_sales = 67 | let* o2 = order2 in 68 | Q.get_order_sales o2 69 | 70 | let run () = 71 | Format.printf "order2:\n%a\n\n" 72 | Rel_sql.Stmt.pp_src (Rel_query.Sql.of_bag' S.order_table order2); 73 | Format.printf "@[order2_sales:@,@[%a@]@,order2_sales_nf:@,@[%a@]@]@." 74 | Bag.pp order2_sales Bag.pp (Rel_query.Sql.normalize order2_sales); 75 | Format.printf "order2_sales:\n%a\n\n" 76 | Rel_sql.Stmt.pp_src (Rel_query.Sql.of_bag S.sales_row order2_sales); 77 | Ok () 78 | end 79 | *) 80 | 81 | module Test_products = struct 82 | open Schemas.Products_with_adts 83 | 84 | (* SQL *) 85 | 86 | let dialect = Rel_sqlite3.dialect 87 | 88 | let schema = 89 | let tables = Table.[Def Product.table; Def Order.table] in 90 | let schema = Rel.Schema.make ~tables () in 91 | Rel_sql.create_schema dialect schema 92 | 93 | let insert_orders = Rel_sql.insert_into dialect Order.table 94 | let insert_product = 95 | let ignore = [(* Col.V Product.pid' *)] in 96 | Rel_sql.insert_into dialect ~ignore Product.table 97 | 98 | (* TODO streamline *) 99 | 100 | let get_products db = 101 | let get_products = 102 | let open Rel_query.Syntax in 103 | let* p = Bag.table Product.table in 104 | Bag.yield p 105 | in 106 | select_rows db get_products (Table.row Product.table) 107 | 108 | let order2 = Q.get_order (Rel_query.Int.v 2) (* FIXME bind *) 109 | let get_order2 db = select_rows db order2 (Table.row Order.table) 110 | 111 | let order2_sales = 112 | let open Rel_query.Syntax in 113 | let* o = order2 in 114 | Q.get_order_sales o 115 | 116 | (* 117 | let get_order2_sales db = 118 | let row = Row.(t3 (int "pid") (text "name") (int "sales")) in 119 | select_rows db order2_sales row 120 | *) 121 | 122 | let test = 123 | Test.test "Products schema" @@ fun () -> 124 | with_in_memory_db @@ fun db -> 125 | let* () = create_schema db schema in 126 | let* () = insert_rows db insert_product Product.table Data.products in 127 | let* () = insert_rows db insert_orders Order.table Data.orders in 128 | let* () = get_products db in 129 | let* () = get_order2 db in 130 | (* let* () = get_order2_sales db in *) 131 | Ok () 132 | end 133 | 134 | module Test_duos = struct 135 | open Schemas.Duos 136 | 137 | let dialect = Rel_sqlite3.dialect 138 | let schema = 139 | let tables = Table.[Def Person.table; Def Duo.table] in 140 | let schema = Schema.make ~tables () in 141 | Rel_sql.create_schema dialect schema 142 | 143 | let insert_person = Rel_sql.insert_into dialect Person.table 144 | let insert_duo = Rel_sql.insert_into dialect Duo.table 145 | 146 | let diff = Q.diff 147 | 148 | let diff db = 149 | let row = Row.(t2 (text "name") (int "diff")) in 150 | select_rows db diff row 151 | 152 | let thirties = 153 | let open Rel_query.Syntax in 154 | Q.persons_in_age_range ~first:(Int.v 30) ~last:(Int.v 39) 155 | 156 | let thirties db = 157 | let row = Row.(t1 (text "name")) in 158 | select_rows db thirties row 159 | 160 | let thirties' = 161 | let open Rel_query.Syntax in 162 | let in_thirties p = 163 | let age = p #. Person.age' in 164 | Int.(v 30 <= age && age <= v 39) 165 | in 166 | Q.persons_sat ~sat:in_thirties 167 | 168 | let thirties' db = 169 | let row = Row.(t1 (text "name")) in 170 | select_rows db thirties' row 171 | 172 | let between_edna_and_bert_excl = 173 | let open Rel_query.Syntax in 174 | let* edna = Q.person_age ~name:(Text.v "Edna") in 175 | let* bert = Q.person_age ~name:(Text.v "Bert") in 176 | Q.persons_in_age_range ~first:edna ~last:(Int.(bert - v 1)) 177 | 178 | let between_edna_and_bert_excl db = 179 | let row = Row.(t1 (text "name")) in 180 | select_rows db between_edna_and_bert_excl row 181 | 182 | let thirties_by_pred pred = 183 | let open Rel_query.Syntax in 184 | let in_thirties p = 185 | let age = p #. Person.age' in 186 | Q.pred pred age 187 | in 188 | Q.persons_sat ~sat:in_thirties 189 | 190 | let thirties_by_pred' db = 191 | let row = Row.(t1 (text "name")) in 192 | select_rows db (thirties_by_pred Q.thirties_pred') row 193 | 194 | let thirties_by_pred db = 195 | let row = Row.(t1 (text "name")) in 196 | select_rows db (thirties_by_pred Q.thirties_pred) row 197 | 198 | let test = 199 | Test.test "Duos schema" @@ fun () -> 200 | with_in_memory_db @@ fun db -> 201 | let* () = create_schema db schema in 202 | let* () = insert_rows db insert_person Person.table Data.persons in 203 | let* () = insert_rows db insert_duo Duo.table Data.duos in 204 | let* () = diff db in 205 | let* () = thirties db in 206 | let* () = thirties' db in 207 | let* () = between_edna_and_bert_excl db in 208 | let* () = thirties_by_pred db in 209 | let* () = thirties_by_pred' db in 210 | Ok () 211 | end 212 | 213 | module Test_org = struct 214 | open Schemas.Org 215 | let dialect = Rel_sqlite3.dialect 216 | 217 | let tables = Table.[Def Department.table; Def Person.table; Def Task.table] 218 | let schema = 219 | let schema = Schema.make ~tables () in 220 | Rel_sql.create_schema dialect schema 221 | 222 | let insert_department = Rel_sql.insert_into dialect Department.table 223 | let insert_person = Rel_sql.insert_into dialect Person.table 224 | let insert_task = Rel_sql.insert_into dialect Task.table 225 | 226 | let abstract_expertise = 227 | let open Rel_query.Syntax in 228 | Q.department_expertise ~task:(Text.v "abstract") 229 | 230 | let abstract_expertise db = 231 | let row = Row.(t1 (text "name")) in 232 | select_rows db abstract_expertise row 233 | 234 | let test = 235 | Test.test "Duos" @@ fun () -> 236 | with_in_memory_db @@ fun db -> 237 | let* () = create_schema db schema in 238 | let* () = 239 | insert_rows db insert_department Department.table Data.departments 240 | in 241 | let* () = insert_rows db insert_person Person.table Data.persons in 242 | let* () = insert_rows db insert_task Task.table Data.tasks in 243 | let* () = abstract_expertise db in 244 | Ok () 245 | end 246 | 247 | let main () = Test.main @@ fun () -> Test.autorun () 248 | let () = if !Sys.interactive then () else exit (main ()) 249 | -------------------------------------------------------------------------------- /doc/schema_howto.mld: -------------------------------------------------------------------------------- 1 | {0 Schema management howto} 2 | 3 | A few tips on how to manage your database schema with Rel. 4 | 5 | {1:def Schema definition strategy} 6 | 7 | Rel lets you decide where you want to define your database schema. 8 | You can define it either {e internally}, with an OCaml {!Rel.Schema.t} 9 | value or {e externally} using any other tool you may see fit. It is 10 | also possible, to some extent, to move from one strategy to the other. 11 | 12 | An internal OCaml definition can always be switched to an external 13 | one. The {!Rel_sql.create_schema} function generates legible SQL 14 | data definitions from a {!Rel.Schema.t} value in the dialect of your 15 | database management system (DBMS). Would you need to move away 16 | from Rel this {e always} works. 17 | 18 | An external schema definition can be moved to an OCaml one by 19 | connecting to your database and generating the OCaml code for a 20 | {!Rel.Schema.t} value representing it. This can be done with: 21 | 22 | - The [rel] command line tool. 23 | - {!Rel_sqlite3.schema_of_db} and {!Rel.Schema.pp_ocaml} 24 | 25 | However if the external schema definition uses features that cannot be 26 | expressed by a {!Rel.Schema.t} value, it is not posssible to 27 | faithfully represent and regenerate the external schema from the 28 | generated OCaml schema – it is nevertheless useful to query and update 29 | the database with Rel. 30 | 31 | Ultimately which solution you choose depends on the degree of control 32 | you need over your DBMS. Since {!Rel.Schema.t} abstracts over DBMS and 33 | their differences, you may find yourself limited by sticking to an 34 | OCaml internal definition. Though using {{!page-sql_stmt_manual}raw 35 | SQL statements} can bring you a long way. 36 | 37 | {1:changes Schema changes} 38 | 39 | The goal of a schema change is to make the {e live schema} (which can 40 | be captured for example with {!Rel_sqlite3.schema_of_db}) of a 41 | database instance to coincide with the {e application's schema}, that 42 | is the schema that your software is assuming to hold in the database 43 | it interacts with. 44 | 45 | Rel provides support to compute the change between a source and 46 | destination {!Rel.Schema.t} value. Table and column renames need 47 | however to be provided manually. The [rel changes] command or 48 | the {!Rel.Schema.val-changes} function perform this. 49 | 50 | This allow to compute the changes needed by your live database to 51 | bring it to the schema you need. 52 | 53 | These changes can be turned into SQL data definition statements with 54 | the {!Rel_sql.schema_changes} functions to apply on a source 55 | schema to bring it to the destination schema. Note that this only 56 | handles structural changes to the database. You may need to provide 57 | additional statements to handle data migrations. You should also 58 | always have a careful look at these steps and possibly tweak them, 59 | especially if you do this with externally defined schemas. 60 | 61 | {2:single Single live database instance or development mode} 62 | 63 | - Let [dst] be the application database's schema. 64 | - Let [src] be the the live database schema. 65 | - Derive the steps to move from [src] to [dst]. 66 | - If the steps are empty, your live database is up-to-date. Otherwise 67 | {b check} the steps, make a backup of your database and apply the 68 | steps to the live schema. 69 | 70 | {2:released Released schemas} 71 | 72 | In this case we need to version the schema. The way to do this is DBMS 73 | dependent. Here a few ways: 74 | 75 | - Use the {{:https://www.sqlite.org/pragma.html#pragma_user_version} 76 | [user_version] pragma} for sqlite3. 77 | 78 | The application keeps the latest version of the schema and diff steps 79 | to go from earlier versions to the next version until the latest one. 80 | 81 | Before interacting with the database: 82 | 83 | - Get the version of the live database. 84 | - Apply the steps to go the next version until the application database 85 | version is reached. 86 | 87 | {1:conventions Schema conventions} 88 | 89 | There's more than one way to model your database in OCaml with [Rel]. 90 | The following defines a simple conventions you can follow. 91 | 92 | These conventions is followed by the [rel] tool when it outputs 93 | the OCaml code needed to support interaction with an externally defined 94 | database schema, except for the naming conventions which respect those 95 | found in the existing schema. 96 | 97 | {2:names Names} 98 | 99 | {ul 100 | {- Table names, keep them singular, lower and snake cased.} 101 | {- Column names, keep them lower, snake cased. Have the primary key 102 | as the first column and then unless there are few of them 103 | sort them in alphabetical order.} 104 | {- Relations, use the related table names seperated by a [_] to name them.} 105 | {- Indices, use the table name and the indexed columns separated by 106 | a [_]. {!Rel.Table.Index} does this for you automatically if you don't 107 | specify a name for the index.}} 108 | 109 | {2:table Tables representation} 110 | 111 | Given a table named {e n} with columns {e c{_0}, c{_1}, …} define a 112 | module [N] ({e n} capitalized) for it. This module should have 113 | 114 | {ul 115 | {- An abstract type [N.t] for representing table rows.} 116 | {- An [N.row] constructor for the row with arguments in the order of columns.} 117 | {- (Optional) A user friendly [N.v] constructor with labelled arguments.} 118 | {- Accessors [N.c]{_i} projecting the corresponding column {e c{_i}} 119 | from [N.t] values.} 120 | {- Values [N.c']{_i} of type {!Rel.Col.t} for each corresponding 121 | column {e c{_i}}.} 122 | {- A value [N.table] of type {!Rel.Table.t} that defines the table.}} 123 | 124 | Once you have modelled your tables and gathered them into a schema 125 | values with {!Rel.Schema.make} you can use {!Rel_sql.create_schema} to 126 | output the corresponding schema in SQL's data definition language. 127 | 128 | {2:example Example} 129 | 130 | Consider a [person] table which has three columns [id] and 131 | [first_name] and [last_name] columns. The following interface 132 | represents such a table according to the convention. 133 | 134 | {[ 135 | (** Persons. *) 136 | module Person : sig 137 | 138 | type id = int 139 | (** The type for person identifiers. *) 140 | 141 | type t 142 | (** The type for persons. *) 143 | 144 | val v : id:id -> first_name:string -> last_name:string -> t 145 | (** [v ~id ~first_name ~last_name] is a person with given attributes. 146 | See accessors for semantics. *) 147 | 148 | val row : id -> string -> string -> t 149 | (** [row] is unlabelled {!v}. *) 150 | 151 | val id : t -> id 152 | (** [id p] is the unique identifier of [p]. *) 153 | 154 | val first_name : t -> string 155 | (** [first_name p] is the first name of [p]. *) 156 | 157 | val last_name : t -> string 158 | (** [last_name p] is the last name of [p]. *) 159 | 160 | (** {1:table Table} *) 161 | 162 | open Rel 163 | 164 | val id' : (t, id) Col.t 165 | (** [id'] is the {!id} column. *) 166 | 167 | val first_name' : (t, string) Col.t 168 | (** [first_name'] is the {!first_name} column. *) 169 | 170 | val last_name' : (t, string) Col.t 171 | (** [last_name'] is the {!last_name} column. *) 172 | 173 | val table : t Table.t 174 | (** [table] is the person table. *) 175 | end 176 | ]} 177 | 178 | The simplest way of implementing this signature is by using OCaml records. 179 | For example: 180 | 181 | {[ 182 | module Person = struct 183 | type id = int 184 | type t = { id : id; first_name : string; last_name : string } 185 | 186 | let v ~id ~first_name ~last_name = { id; first_name; last_name } 187 | let row id first_name last_name = { id; first_name; last_name } 188 | 189 | let id r = r.id 190 | let first_name r = r.first_name 191 | let last_name r = r.last_name 192 | 193 | open Rel 194 | 195 | let id' = Col.v "id" Type.Int id 196 | let first_name' = Col.v "first_name" Type.Text first_name 197 | let last_name' = Col.v "last_name" Type.Text last_name 198 | 199 | let table = 200 | let primary_key = Col.[V id'] in 201 | Table.make "person" ~primary_key @@ 202 | Row.(unit row * id' * first_name' * last_name') 203 | end 204 | ]} 205 | 206 | {2:alt Alernate direction} 207 | 208 | An alternate direction could be to simply define abstract types for 209 | tables but simply have them as generic column map (i.e. heterogenous 210 | dictionary). Could have less boiler plate and less gc pressure since 211 | we do pack {!Rel.Col.value}s at the IO boundary anyways. 212 | 213 | {1:unsupported Unsupported DBMS features} 214 | 215 | A few DBMS features that would be nice to have but are not supported 216 | at the moment. 217 | 218 | For SQLite3. 219 | 220 | - Generating SQLite {{:https://www.sqlite.org/stricttables.html} 221 | strict table} would be nice. However if we do so we can no longer 222 | distinguish between [bool], [int] and [int64] columns. 223 | - Tables. Table options. [CHECK] constraints on tables. First needs a 224 | story for SQL expressions. Second in SQLite3 AFAIK it's not possible 225 | to get it from the meta tables. This means we would have to parse 226 | the SQL CREATE statements for {!Rel_sqlite3.schema_of_db} which 227 | we avoided so far. 228 | - Indices. partial indexes. 229 | - Views. Virtual tables. Triggers 230 | - Column constraints. Some are supported at the table level (primary 231 | key, unique, foreign keys) or the type level (not null). But we are 232 | missing COLLATE, GENERATED, AUTOINCREMENT. 233 | - Primary keys ASC/DESC. 234 | 235 | 236 | {1:recipes Recipes} 237 | 238 | {2:enum_column Column type for a simple OCaml variant} 239 | 240 | Use a coded column. Example 241 | {[ 242 | module Role = struct 243 | type t = Author | Editor 244 | 245 | let to_string = function Author -> "author" | Editor -> "editor" 246 | let pp ppf r = Fmt.string ppf (role_to_string r) 247 | 248 | let role_type = 249 | let enc = function Author -> 0 | Editor -> 1 in 250 | let dec = function 251 | | 0 -> Author | 1 -> Editor | n -> Fmt.failwith "%d: Unknown role" n 252 | in 253 | Type.coded @@ 254 | Type.Coded.make ~name:"Contributor.role" Type.int ~enc ~dec ~pp:pp_role 255 | end 256 | ]} 257 | 258 | FIXME try to get something out of a typegist. 259 | -------------------------------------------------------------------------------- /src/rel_sql.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** SQL helpers. 7 | 8 | This module provides mecanism to type and bind parameters of 9 | raw SQL statements and high-level functions to generate SQL 10 | statements from {!Rel} representations. *) 11 | 12 | open Rel 13 | 14 | (** {1:stmt Statements} *) 15 | 16 | (** Typed SQL statements. 17 | 18 | See the {{!page-sql_stmt_manual}SQL statement typing howto} 19 | for a short introduction. *) 20 | module Stmt : sig 21 | 22 | (** {1:arg Arguments} *) 23 | 24 | type arg = Arg : 'a Type.t * 'a -> arg (** *) 25 | (** The type for SQL statement arguments (parameters). *) 26 | 27 | val pp_arg : Format.formatter -> arg -> unit 28 | (** [pp_arg] formats an argument with {!Rel.Type.value_pp}. *) 29 | 30 | (** {1:stmts Statements} *) 31 | 32 | type 'r t 33 | (** The type for a closed (all arguments are bound) SQL statement 34 | returning rows of type ['r]. Note that this must be a single 35 | statement. *) 36 | 37 | val v : string -> rev_args:arg list -> result:'r Row.t -> 'r t 38 | (** [v sql rev_args result] is a closed statement with srouce 39 | [sql], revered list of arguments (parameters) [rev_args] and 40 | yielding rows of type [result]. *) 41 | 42 | val src : 'r t -> string 43 | (** [src st] is the source SQL statement of [st]. *) 44 | 45 | val result : 'r t -> 'r Row.t 46 | (** [result s] is the result of [s]. *) 47 | 48 | val rev_args : 'r t -> arg list 49 | (** [rev_args st] is the reversed list of arguments of the statement. *) 50 | 51 | val pp_src : Format.formatter -> 'r t -> unit 52 | (** [pp_src] formats the statement's source. *) 53 | 54 | val pp : Format.formatter -> 'r t -> unit 55 | (** [pp ppf st] formats the statement's source and its arguments. *) 56 | 57 | (** {1:bind Binding functions} *) 58 | 59 | type 'a func 60 | (** The type for open SQL statements with argument binding 61 | function of type ['a]. *) 62 | 63 | val func : string -> 'a func -> 'a 64 | (** [func sql f] is the binding function of [f] used on the source 65 | SQL statement [sql]. *) 66 | 67 | val ret : 'r Row.t -> 'r t func 68 | (** [ret st row] is an open SQL statement [st] returning values of 69 | type [row]. *) 70 | 71 | val ret_rev : 'r Row.t -> 'r t func 72 | 73 | val arg : 'a Type.t -> 'b func -> ('a -> 'b) func 74 | (** [arg t f] binds a new variable of type [t] to [f]. *) 75 | 76 | val ( @-> ) : 'a Type.t -> 'b func -> ('a -> 'b) func 77 | (** [t @-> f] is [arg t f]. *) 78 | 79 | val unit : unit t func 80 | (** [unit] is [ret ]{!Rel.Row.empty}. *) 81 | 82 | (** The following constants get redefined here to allow consise 83 | specification with the [Sql.Stmt.()] notation. *) 84 | 85 | val bool : bool Type.t 86 | (** [bool] is {!Rel.Type.Bool}. *) 87 | 88 | val int : int Type.t 89 | (** [int] is {!Rel.Type.Int}. *) 90 | 91 | val int64 : int64 Type.t 92 | (** [int64] is {!Rel.Type.Int64}. *) 93 | 94 | val float : float Type.t 95 | (** [float] is {!Rel.Type.Float}. *) 96 | 97 | val text : string Type.t 98 | (** [text] is {!Rel.Type.Text}. *) 99 | 100 | val blob : string Type.t 101 | (** [blob] is {!Rel.Type.Blob}. *) 102 | 103 | val option : 'a Type.t -> 'a option Type.t 104 | (** [option t] is {!Rel.Type.Option}[ t]. *) 105 | 106 | (** {2:projs Binding projections} 107 | 108 | See the {{!page-sql_stmt_manual.binding_projection}this section} 109 | of the SQL statement typing howto. *) 110 | 111 | val nop : 'b func -> ('a -> 'b) func 112 | (** [nop f] adds an unused argument to [f]. *) 113 | 114 | val proj : ('r -> 'a) -> 'a Type.t -> ('r -> 'b) func -> ('r -> 'b) func 115 | (** [proj p t] binds the projection [p] of a value of type [t]. *) 116 | 117 | val col : ('r, 'a) Col.t -> ('r -> 'b) func -> ('r -> 'b) func 118 | (** [col c f] binds the projection on column [c] of a row of type ['r] *) 119 | end 120 | 121 | (** {1:dialect Dialects} *) 122 | 123 | (** Standard SQL syntax fragments. *) 124 | module Syntax : sig 125 | 126 | val string_to_literal : string -> string 127 | (** [string_to_literal s] is [s] between single quotes (['\'']) with 128 | single quotes in [s] properly escaped. *) 129 | 130 | val string_of_literal : string -> (string, string) result 131 | (** [string_of_literal s] parses a string literal from [s]. This 132 | removes enclosing single quotes (['\'']) and collapses sequences 133 | of two quotes to a single one (it leaves lone internal single 134 | quotes untouched). *) 135 | 136 | val id : string -> string 137 | (** [id id] is [id] between double quotes (['\"']) with double quotes 138 | in [s] properly escaped. *) 139 | 140 | val id_in_schema : ?schema:string -> string -> string 141 | (** [id_in_schema] is like {!id} but prefixes an escaped 142 | [schema] if specified. *) 143 | 144 | val sort_order_keyword : [`Asc | `Desc] -> string 145 | val foreign_key_action_keyword : Table.Foreign_key.action -> string 146 | end 147 | 148 | type insert_or_action = [`Abort | `Fail | `Ignore | `Replace | `Rollback ] 149 | 150 | (** SQL satements in a given dialect. 151 | 152 | This does not always try to abstract SQL per se but rather what we want 153 | to do with the SQL. For example {!DIALECT.schema_changes}: in 154 | SQLite most ALTER TABLE statements are unsupported so the returned 155 | statement implement the 156 | {{:https://sqlite.org/lang_altertable.html#making_other_kinds_of_table_schema_changes} 157 | sequence of operations} that allow to mimic them in bulk. *) 158 | module type DIALECT = sig 159 | 160 | val kind : string 161 | (** [kind] is the kind of dialect. Usually the name of the database 162 | management system. *) 163 | 164 | (** {1:inserts Inserts} *) 165 | 166 | val insert_into : 167 | ?or_action:insert_or_action -> ?schema:Schema.name -> 168 | ?ignore:'r Col.def list -> 'r Table.t -> ('r -> unit Stmt.t) 169 | (** See {!Rel_sql.insert_into}. *) 170 | 171 | val insert_into_cols : 172 | ?schema:Schema.name -> ?ignore:'r Col.def list -> 'r Table.t -> 173 | ('r Col.value list -> unit Stmt.t) 174 | (** See {!Rel_sql.insert_into_cols}. *) 175 | 176 | val update : 177 | ?schema:Schema.name -> 'r Table.t -> set:'r Col.value list -> 178 | where:'r Col.value list -> unit Stmt.t 179 | (** See {!Rel_sql.update}. *) 180 | 181 | val delete_from : 182 | ?schema:string -> 'r Table.t -> where:'r Col.value list -> 183 | unit Stmt.t 184 | (** See {!Rel_sql.delete_from}. *) 185 | 186 | (** {1:ddl Data definition statements} *) 187 | 188 | val create_table : 189 | ?schema:Schema.name -> ?if_not_exists:unit -> 'r Table.t -> unit Stmt.t 190 | (** See {!Rel_sql.create_table}. *) 191 | 192 | val drop_table : 193 | ?schema:Schema.name -> ?if_exists:unit -> 'r Table.t -> unit Stmt.t 194 | (** See {!Rel_sql.drop_table}. *) 195 | 196 | val create_index : 197 | ?schema:Schema.name -> ?if_not_exists:unit -> 'r Table.t -> 198 | 'r Table.Index.t -> unit Stmt.t 199 | (** See {!Rel_sql.create_index}. *) 200 | 201 | val drop_index : 202 | ?schema:Schema.name -> ?if_exists:unit -> 'r Table.t -> 'r Table.Index.t -> 203 | unit Stmt.t 204 | (** See {!Rel_sql.drop_index}. *) 205 | 206 | val schema_changes : 207 | ?schema:Schema.name -> Schema.change list -> bool * unit Stmt.t list 208 | (** See {!Rel_sql.schema_changes} *) 209 | end 210 | 211 | type dialect = (module DIALECT) 212 | (** The type for SQL dialects. *) 213 | 214 | (** {1:insupd Inserting, updating and deleting} *) 215 | 216 | val insert_into : 217 | dialect -> ?or_action:insert_or_action -> ?schema:Schema.name -> 218 | ?ignore:'r Col.def list -> 'r Table.t -> ('r -> unit Stmt.t) 219 | (** [insert_into d ~ignore t] is an INSERT INTO statement which 220 | inserts i [t] values draw from an value values drawn from a 221 | provided OCaml table row. Columns mentioned in [col] of the row 222 | are ignored for the insertion. [insert_or_action] specifies a 223 | corresponding [INSERT OR]. *) 224 | 225 | val insert_into_cols : 226 | dialect -> ?schema:Schema.name -> ?ignore:'r Col.def list -> 'r Table.t -> 227 | ('r Col.value list -> unit Stmt.t) 228 | (** [insert_into_cols] is like {!insert_into} but uses the 229 | given column values for the insertion. *) 230 | 231 | val update : 232 | dialect -> ?schema:Schema.name -> 'r Table.t -> set:'r Col.value list -> 233 | where:'r Col.value list -> unit Stmt.t 234 | (** [update_cols d t ~set:cols ~where] is an UPDATE statement 235 | which updates columns values [cols] of the rows of [t] where 236 | columns have all the values in [where] (AND). {b FIXME.} The 237 | [where] should become (['r Bag.t -> bool value]). *) 238 | 239 | val delete_from : 240 | dialect -> ?schema:Schema.name -> 'r Table.t -> where:'r Col.value list -> 241 | unit Stmt.t 242 | (** [delete_from d t ~where] is a DELETE FROM statement which deletes 243 | rows where columns have all the values in [where] (AND). 244 | {b FIXME.} The [where] should become (['r Bag.t -> bool value]). *) 245 | 246 | (** {1:ddl Data definition statements} *) 247 | 248 | (** {2:table Tables} *) 249 | 250 | val create_table : 251 | dialect -> ?schema:Schema.name -> ?if_not_exists:unit -> 'a Table.t -> 252 | unit Stmt.t 253 | (** [create_table d t] is a CREATE TABLE statement for [t]. The table 254 | is created in [schema] if specified. The statement is CREATE TABLE 255 | IF NOT EXISTS when [~if_not_exists:()] is given. *) 256 | 257 | val drop_table : 258 | dialect -> ?schema:Schema.name -> ?if_exists:unit -> 'a Table.t -> unit Stmt.t 259 | (** [drop_table d t] is a DROP TABLE statement for [t]. The dropped 260 | table is in [schema] if specified. The statement is DROP TABLE IF 261 | EXISTS when [~if_exists:()] is given. *) 262 | 263 | (** {2:indices Indices} *) 264 | 265 | val create_index : 266 | dialect -> ?schema:Schema.name -> ?if_not_exists:unit -> 'a Table.t -> 267 | 'a Table.Index.t -> unit Stmt.t 268 | (** [create_index d t i] is a CREATE INDEX statement for [i] on table 269 | [t] in schema [schema]. The statement is CREATE INDEX IF NOT 270 | EXISTS when [~if_not_exists:()] is given. *) 271 | 272 | val drop_index : 273 | dialect -> ?schema:Schema.name -> ?if_exists:unit -> 274 | 'a Table.t -> 'a Table.Index.t -> unit Stmt.t 275 | (** [drop_index d t i] is a DROP INDEX statement to drop index [i] of 276 | table [t]. The index and table are in [schema] if specified. The 277 | statement is DROP INDEX IF EXISTS when [~if_exists:()] is 278 | given. *) 279 | 280 | (** {2:schema Schemas} *) 281 | 282 | val create_schema : dialect -> Schema.t -> unit Stmt.t list 283 | (** [create_schema_stmts d s] is the sequence of statements to create 284 | schema [s]. This creates tables and their indices, all of which 285 | should not exist. Use {!drop_schema} to remove previous 286 | definitions. *) 287 | 288 | val drop_schema : dialect -> ?if_exists:unit -> Schema.t -> unit Stmt.t list 289 | (** [drop_schema_stmts d s] is the sequence of statementes to drop 290 | schema [s]. All definitions need to exist unless [~if_exists:()] 291 | is provided. This drops all tables (which should drop their 292 | indices aswell) in reverse order of {!Rel.Schema.tables}; if you have 293 | recursive table dependencies you may have to disable foreign keys 294 | before executing the statment. *) 295 | 296 | val schema_changes : 297 | dialect -> ?schema:Schema.name -> Schema.change list -> 298 | bool * unit Stmt.t list 299 | (** [schema_change_stmts d cs] is the sequence of statements to perform 300 | the changes [cs]. The boolean indicates if this should be performed in 301 | a transaction. 302 | 303 | {b Warning.} In the {!Rel_sqlite3.dialect}, this may set foreign keys on, 304 | if you have them off you may want to set it them off again afterwards. 305 | *) 306 | -------------------------------------------------------------------------------- /src/sqlite3/rel_sqlite3_stubs.c: -------------------------------------------------------------------------------- 1 | /*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | --------------------------------------------------------------------------*/ 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | 13 | #include 14 | #include 15 | #include 16 | 17 | #include 18 | 19 | #if SQLITE_VERSION_NUMBER < 3027002 20 | #error "Unsupported SQLite version, at least 3.27.2 is needed" 21 | #endif 22 | 23 | #define Sqlite3_val(v) (*((sqlite3 **) Data_abstract_val(v))) 24 | #define Sqlite3_stmt_val(v) (*((sqlite3_stmt **) Data_abstract_val(v))) 25 | #define Sqlite3_backup_val(v) (*((sqlite3_backup **) Data_abstract_val(v))) 26 | #define Sqlite3_rc_val(v) Int_val(v) 27 | #define Val_sqlite3_rc(v) Val_int(v) 28 | 29 | /* Library information and configuration */ 30 | 31 | CAMLprim value ocaml_rel_sqlite3_version_number (value unit) 32 | { 33 | return (Val_int (sqlite3_libversion_number ())); 34 | } 35 | 36 | CAMLprim value ocaml_rel_sqlite3_errstr (value rc) 37 | { 38 | return caml_copy_string (sqlite3_errstr (Sqlite3_rc_val (rc))); 39 | } 40 | 41 | /* Database connections */ 42 | 43 | CAMLprim value ocaml_rel_sqlite3_open (value file, value uri, value mode, 44 | value mutex, value vfs) 45 | { 46 | CAMLparam5 (file, uri, mode, mutex, vfs); 47 | CAMLlocal2 (ret, db); 48 | 49 | if (!caml_string_is_c_safe (file)) 50 | caml_invalid_argument ("sqlite3_open: file path string is not C safe."); 51 | 52 | if (!caml_string_is_c_safe (vfs)) 53 | caml_invalid_argument ("sqlite3_open: vfs string is not C safe."); 54 | 55 | int flags = 0; 56 | switch (Int_val (mode)) { 57 | case 0: flags = SQLITE_OPEN_READONLY; break; 58 | case 1: flags = SQLITE_OPEN_READWRITE; break; 59 | case 2: flags = SQLITE_OPEN_READWRITE | SQLITE_OPEN_CREATE; break; 60 | case 3: flags = SQLITE_OPEN_READWRITE | SQLITE_OPEN_MEMORY; break; 61 | default: assert (false); break; 62 | } 63 | switch (Int_val (mutex)) { 64 | case 0: flags |= SQLITE_OPEN_NOMUTEX; break; 65 | case 1: flags |= SQLITE_OPEN_FULLMUTEX; break; 66 | default: assert (false); break; 67 | } 68 | if (Bool_val (uri)) { flags |= SQLITE_OPEN_URI; } 69 | 70 | sqlite3 *dbc = NULL; 71 | char *filec = caml_stat_strdup (String_val (file)); 72 | char *vfsc = 73 | (caml_string_length (vfs) == 0) ? NULL : 74 | caml_stat_strdup (String_val (vfs)); 75 | 76 | caml_release_runtime_system (); 77 | int rc = sqlite3_open_v2 (filec, &dbc, flags, vfsc); 78 | caml_stat_free (filec); 79 | if (vfsc != NULL) { caml_stat_free (vfsc); } 80 | caml_acquire_runtime_system (); 81 | 82 | if (rc == SQLITE_OK) 83 | { 84 | sqlite3_extended_result_codes (dbc, 1); 85 | value db = caml_alloc (1, Abstract_tag); 86 | *((sqlite3 **) Data_abstract_val(db)) = dbc; 87 | ret = caml_alloc (1, 0); 88 | Store_field (ret, 0, db); 89 | } else { 90 | ret = caml_alloc (1, 1); 91 | Store_field (ret, 0, Val_sqlite3_rc (rc)); 92 | } 93 | CAMLreturn (ret); 94 | } 95 | 96 | CAMLprim value ocaml_rel_sqlite3_close (value db) 97 | { 98 | return Val_sqlite3_rc (sqlite3_close (Sqlite3_val (db))); 99 | } 100 | 101 | CAMLprim value ocaml_rel_sqlite3_errmsg (value db) 102 | { 103 | return caml_copy_string (sqlite3_errmsg (Sqlite3_val (db))); 104 | } 105 | 106 | CAMLprim value ocaml_rel_sqlite3_extended_errcode (value db) 107 | { 108 | return Val_int (sqlite3_extended_errcode (Sqlite3_val (db))); 109 | } 110 | 111 | CAMLprim value ocaml_rel_sqlite3_busy_timeout (value db, value ms) 112 | { 113 | return Val_sqlite3_rc (sqlite3_busy_timeout (Sqlite3_val(db), Int_val(ms))); 114 | } 115 | 116 | CAMLprim value ocaml_rel_sqlite3_changes (value db) 117 | { 118 | return Val_int (sqlite3_changes (Sqlite3_val (db))); 119 | } 120 | 121 | CAMLprim value ocaml_rel_sqlite3_last_insert_rowid (value db) 122 | { 123 | return caml_copy_int64 124 | (sqlite3_last_insert_rowid (Sqlite3_val (db))); 125 | } 126 | 127 | /* Queries */ 128 | 129 | CAMLprim value ocaml_rel_sqlite3_exec (value db, value sql) 130 | { 131 | if (!caml_string_is_c_safe (sql)) 132 | caml_invalid_argument ("sqlite3_exec: SQL string is not C safe."); 133 | 134 | sqlite3 *dbc = Sqlite3_val (db); 135 | char *sqlc = caml_stat_strdup (String_val (sql)); 136 | caml_release_runtime_system (); 137 | int rc = sqlite3_exec (dbc, sqlc, NULL, NULL, NULL); 138 | caml_stat_free (sqlc); 139 | caml_acquire_runtime_system(); 140 | return Val_sqlite3_rc (rc); 141 | } 142 | 143 | /* Prepared statements */ 144 | 145 | CAMLprim value ocaml_rel_sqlite3_stmt_errmsg (value stmt) 146 | { 147 | sqlite3_stmt *stmtc = Sqlite3_stmt_val (stmt); 148 | sqlite3 *dbc = sqlite3_db_handle (stmtc); 149 | const char *err = sqlite3_errmsg (dbc); 150 | if (!err) err = ""; 151 | return caml_copy_string (err); 152 | } 153 | 154 | CAMLprim value ocaml_rel_sqlite3_prepare (value db, value sql) 155 | { 156 | CAMLparam2 (db, sql); 157 | CAMLlocal1 (ret); 158 | 159 | if (!caml_string_is_c_safe (sql)) 160 | caml_invalid_argument ("sqlite3_prepare: SQL string is not C safe."); 161 | 162 | sqlite3 *dbc = Sqlite3_val (db); 163 | sqlite3_stmt *stmtc = NULL; 164 | char *sqlc = caml_stat_strdup (String_val (sql)); 165 | caml_release_runtime_system (); 166 | int rc = sqlite3_prepare_v2 (dbc, sqlc, strlen(sqlc), &stmtc, NULL); 167 | caml_stat_free (sqlc); 168 | caml_acquire_runtime_system(); 169 | 170 | if (rc == SQLITE_OK) 171 | { 172 | value stmt = caml_alloc (1, Abstract_tag); 173 | *((sqlite3_stmt **) Data_abstract_val(stmt)) = stmtc; 174 | ret = caml_alloc (1, 0); 175 | Store_field (ret, 0, stmt); 176 | } else { 177 | ret = caml_alloc (1, 1); 178 | Store_field (ret, 0, Val_sqlite3_rc (rc)); 179 | } 180 | CAMLreturn (ret); 181 | } 182 | 183 | CAMLprim value ocaml_rel_sqlite3_finalize (value stmt) 184 | { 185 | return Val_sqlite3_rc (sqlite3_finalize (Sqlite3_stmt_val (stmt))); 186 | } 187 | 188 | CAMLprim value ocaml_rel_sqlite3_reset (value stmt) 189 | { 190 | return Val_sqlite3_rc (sqlite3_reset (Sqlite3_stmt_val (stmt))); 191 | } 192 | 193 | CAMLprim value ocaml_rel_sqlite3_step (value stmt) 194 | { 195 | sqlite3_stmt *stmtc = Sqlite3_stmt_val (stmt); 196 | caml_release_runtime_system (); 197 | int rc = sqlite3_step (stmtc); 198 | caml_acquire_runtime_system (); 199 | return Val_sqlite3_rc (rc); 200 | } 201 | 202 | CAMLprim value ocaml_rel_sqlite3_column_count (value stmt) 203 | { 204 | return Val_int (sqlite3_column_count (Sqlite3_stmt_val (stmt))); 205 | } 206 | 207 | CAMLprim value ocaml_rel_sqlite3_bind_paramater_count (value stmt) 208 | { 209 | return Val_int (sqlite3_bind_parameter_count (Sqlite3_stmt_val (stmt))); 210 | } 211 | 212 | CAMLprim value ocaml_rel_sqlite3_bind_null (value stmt, value i) 213 | { 214 | return Val_sqlite3_rc 215 | (sqlite3_bind_null (Sqlite3_stmt_val (stmt), Int_val (i))); 216 | } 217 | 218 | CAMLprim value ocaml_rel_sqlite3_bind_bool (value stmt, value i, value v) 219 | { 220 | return Val_sqlite3_rc 221 | (sqlite3_bind_int64 (Sqlite3_stmt_val (stmt), Int_val (i), 222 | Bool_val (v) ? 1 : 0)); 223 | } 224 | 225 | CAMLprim value ocaml_rel_sqlite3_bind_int (value stmt, value i, value v) 226 | { 227 | return Val_sqlite3_rc 228 | (sqlite3_bind_int64 (Sqlite3_stmt_val (stmt), Int_val (i), Long_val (v))); 229 | } 230 | 231 | CAMLprim value ocaml_rel_sqlite3_bind_int64 (value stmt, value i, value v) 232 | { 233 | return Val_sqlite3_rc 234 | (sqlite3_bind_int64 (Sqlite3_stmt_val (stmt), Int_val (i), Int64_val (v))); 235 | } 236 | 237 | CAMLprim value ocaml_rel_sqlite3_bind_double (value stmt, value i, value v) 238 | { 239 | return Val_sqlite3_rc 240 | (sqlite3_bind_double (Sqlite3_stmt_val (stmt), Int_val (i), 241 | Double_val (v))); 242 | } 243 | 244 | CAMLprim value ocaml_rel_sqlite3_bind_text (value stmt, value i, value v) 245 | { 246 | return Val_sqlite3_rc 247 | (sqlite3_bind_text (Sqlite3_stmt_val (stmt), Int_val (i), 248 | String_val (v), caml_string_length (v), 249 | SQLITE_TRANSIENT)); 250 | } 251 | 252 | CAMLprim value ocaml_rel_sqlite3_bind_blob (value stmt, value i, value v) 253 | { 254 | return Val_sqlite3_rc 255 | (sqlite3_bind_blob (Sqlite3_stmt_val (stmt), Int_val (i), 256 | String_val (v), caml_string_length (v), 257 | SQLITE_TRANSIENT)); 258 | } 259 | 260 | CAMLprim value ocaml_rel_sqlite3_clear_bindings (value stmt) 261 | { 262 | return Val_sqlite3_rc (sqlite3_clear_bindings (Sqlite3_stmt_val (stmt))); 263 | } 264 | 265 | CAMLprim value ocaml_rel_sqlite3_column_is_null (value stmt, value i) 266 | { 267 | return Val_bool (sqlite3_column_type (Sqlite3_stmt_val (stmt), Int_val (i)) 268 | == SQLITE_NULL); 269 | } 270 | 271 | CAMLprim value ocaml_rel_sqlite3_column_bool (value stmt, value i) 272 | { 273 | return Val_bool (sqlite3_column_int (Sqlite3_stmt_val (stmt), Int_val (i))); 274 | } 275 | 276 | CAMLprim value ocaml_rel_sqlite3_column_int (value stmt, value i) 277 | { 278 | return Val_int (sqlite3_column_int64 (Sqlite3_stmt_val (stmt), Int_val (i))); 279 | } 280 | 281 | CAMLprim value ocaml_rel_sqlite3_column_int64 (value stmt, value i) 282 | { 283 | return caml_copy_int64 284 | (sqlite3_column_int64 (Sqlite3_stmt_val (stmt), Int_val (i))); 285 | } 286 | 287 | CAMLprim value ocaml_rel_sqlite3_column_double (value stmt, value i) 288 | { 289 | return caml_copy_double 290 | (sqlite3_column_double (Sqlite3_stmt_val (stmt), Int_val (i))); 291 | } 292 | 293 | CAMLprim value ocaml_rel_sqlite3_column_text (value stmt, value i) 294 | { 295 | sqlite3_stmt *stmtc = Sqlite3_stmt_val (stmt); 296 | int len = sqlite3_column_bytes (stmtc, Int_val (i)); 297 | return caml_alloc_initialized_string 298 | (len, (char *)sqlite3_column_text (stmtc, Int_val (i))); 299 | } 300 | 301 | CAMLprim value ocaml_rel_sqlite3_column_blob (value stmt, value i) 302 | { 303 | sqlite3_stmt *stmtc = Sqlite3_stmt_val (stmt); 304 | int len = sqlite3_column_bytes (stmtc, Int_val (i)); 305 | return caml_alloc_initialized_string 306 | (len, (char *)sqlite3_column_blob (stmtc, Int_val (i))); 307 | } 308 | 309 | /* Backups */ 310 | 311 | CAMLprim value ocaml_rel_sqlite3_backup_init 312 | (value dst, value dname, value src, value sname) 313 | { 314 | CAMLparam4 (dst, dname, src, sname); 315 | CAMLlocal2 (ret, b); 316 | 317 | if (!caml_string_is_c_safe (dname)) 318 | caml_invalid_argument 319 | ("sqlite3_backup_init: destination database name is not C safe."); 320 | 321 | if (!caml_string_is_c_safe (sname)) 322 | caml_invalid_argument 323 | ("sqlite3_backup_init: source database name is not C safe."); 324 | 325 | sqlite3_backup *bc = NULL; 326 | sqlite3 *dstc = Sqlite3_val (dst); 327 | sqlite3 *srcc = Sqlite3_val (src); 328 | char *dnamec = caml_stat_strdup (String_val (dname)); 329 | char *snamec = caml_stat_strdup (String_val (sname)); 330 | caml_release_runtime_system (); 331 | bc = sqlite3_backup_init (dstc, dnamec, srcc, snamec); 332 | caml_stat_free (dnamec); 333 | caml_stat_free (snamec); 334 | caml_acquire_runtime_system (); 335 | 336 | if (bc) 337 | { 338 | value b = caml_alloc (1, Abstract_tag); 339 | *((sqlite3_backup **) Data_abstract_val (b)) = bc; 340 | ret = caml_alloc (1, 0); 341 | Store_field (ret, 0, b); 342 | } else { 343 | int rc = sqlite3_errcode (dstc); 344 | ret = caml_alloc (1, 1); 345 | Store_field (ret, 0, Val_sqlite3_rc (rc)); 346 | } 347 | CAMLreturn (ret); 348 | } 349 | 350 | CAMLprim value ocaml_rel_sqlite3_backup_finish (value b) 351 | { 352 | return Val_sqlite3_rc (sqlite3_backup_finish (Sqlite3_backup_val (b))); 353 | } 354 | 355 | CAMLprim value ocaml_rel_sqlite3_backup_step (value b, value n) 356 | { 357 | 358 | sqlite3_backup *bc = Sqlite3_backup_val (b); 359 | int nc = Int_val (n); 360 | caml_release_runtime_system (); 361 | int rc = sqlite3_backup_step (bc, nc); 362 | caml_acquire_runtime_system(); 363 | return Val_sqlite3_rc (rc); 364 | } 365 | 366 | CAMLprim value ocaml_rel_sqlite3_backup_remaining (value b) 367 | { 368 | return Val_int (sqlite3_backup_remaining (Sqlite3_backup_val (b))); 369 | } 370 | 371 | CAMLprim value ocaml_rel_sqlite3_backup_pagecount (value b) 372 | { 373 | return Val_int (sqlite3_backup_pagecount (Sqlite3_backup_val (b))); 374 | } 375 | -------------------------------------------------------------------------------- /src/rel_query.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** Embedded query language. *) 7 | 8 | (** {1:query_lang Query language} 9 | 10 | The expressiveness of the query language is currently limited. 11 | Note that you can always switch to raw SQL statements and 12 | {{!Rel_sql.Stmt}type} them for execution. To define queries you should 13 | open {!Syntax} which has more definitions and operator 14 | overloading. *) 15 | 16 | type 'a value 17 | (** The type for representing values of type ['a]. FIXME 18 | depending on the final open strategy put that in its own module. *) 19 | 20 | (** Booleans. *) 21 | module Bool : sig 22 | 23 | val v : bool -> bool value 24 | (** [v b] is the literal boolean [b]. *) 25 | 26 | val true' : bool value 27 | (** [true'] is [v true]. *) 28 | 29 | val false' : bool value 30 | (** [false'] is [v false]. *) 31 | 32 | val equal : bool value -> bool value -> bool value 33 | (** [equal x y] is boolean equality. *) 34 | 35 | val ( = ) : bool value -> bool value -> bool value 36 | (** [x = y] is boolean equality. *) 37 | 38 | val ( && ) : bool value -> bool value -> bool value 39 | (** [x && y] is logical conjunction. *) 40 | 41 | val ( || ) : bool value -> bool value -> bool value 42 | (** [x || y] is logical disjunction. *) 43 | 44 | val not : bool value -> bool value 45 | (** [not x] is the logical negation of [x]. *) 46 | end 47 | 48 | (** Integers. *) 49 | module Int : sig 50 | 51 | val v : int -> int value 52 | (** [v i] is the literal integer [i]. *) 53 | 54 | val zero : int value 55 | (** [zero] is [v 0]. *) 56 | 57 | val one : int value 58 | (** [one] is [v 1]. *) 59 | 60 | (** {1:cmp Predicates and comparisons} *) 61 | 62 | val equal : int value -> int value -> bool value 63 | (** [equal x y] is integer equality. *) 64 | 65 | val ( = ) : int value -> int value -> bool value 66 | (** [x = y] is integer equality. *) 67 | 68 | val ( <> ) : int value -> int value -> bool value 69 | (** [x <> y] is integer inequality. *) 70 | 71 | val ( < ) : int value -> int value -> bool value 72 | (** [x < y] is true iff [x] is stricly lower than [y]. *) 73 | 74 | val ( <= ) : int value -> int value -> bool value 75 | (** [x <= y] is true iff [x] is lower or equal than [y]. *) 76 | 77 | val ( > ) : int value -> int value -> bool value 78 | (** [x < y] is true iff [x] is stricly lower than [y]. *) 79 | 80 | val ( >= ) : int value -> int value -> bool value 81 | (** [x >= y] is true iff [x] is greater or equal than [y]. *) 82 | 83 | (** {1:arith Arithmetic operators} *) 84 | 85 | val ( ~- ) : int value -> int value 86 | (** [~-x] is the negation of [x]. *) 87 | 88 | val ( + ) : int value -> int value -> int value 89 | (** [x + y] is integer addition. *) 90 | 91 | val ( - ) : int value -> int value -> int value 92 | (** [x + y] is integer subtraction. *) 93 | 94 | val ( * ) : int value -> int value -> int value 95 | (** [x * y] is integer addition. *) 96 | 97 | val ( / ) : int value -> int value -> int value 98 | (** [x / y] is integer division. *) 99 | 100 | (** {1:conv Conversions} *) 101 | 102 | val of_bool : bool value -> int value 103 | (** [of_bool b] is [b] as an integer value. *) 104 | 105 | val of_int64 : int64 value -> int value 106 | (** [of_int64 i] is [i] as an integer value. {b FIXME.} Clarify 107 | conversion. *) 108 | 109 | val of_float : float value -> int value 110 | (** [of_float f] is [f] as an integer value. {b FIXME.} Clarify 111 | conversion. *) 112 | 113 | val of_string : string value -> int value 114 | (** [of_string s] converts [s] to string if [s] can't be parsed 115 | this results in [0]. *) 116 | end 117 | 118 | (** 64-bit integers. *) 119 | module Int64 : sig 120 | 121 | val v : int64 -> int64 value 122 | (** [v i] is the literal integer [i]. *) 123 | 124 | val zero : int64 value 125 | (** [zero] is [v 0L]. *) 126 | 127 | val one : int64 value 128 | (** [one] is [v 1L]. *) 129 | 130 | (** {1:cmp Predicates and comparisons} *) 131 | 132 | val equal : int64 value -> int64 value -> bool value 133 | (** [equal x y] is integer equality. *) 134 | 135 | val ( = ) : int64 value -> int64 value -> bool value 136 | (** [x = y] is integer equality. *) 137 | 138 | (** {1:arith Arithmetic operators} *) 139 | 140 | val ( ~- ) : int64 value -> int64 value 141 | (** [~-x] is the negation of [x]. *) 142 | 143 | val ( + ) : int64 value -> int64 value -> int64 value 144 | (** [x + y] is int64eger addition. *) 145 | 146 | val ( - ) : int64 value -> int64 value -> int64 value 147 | (** [x + y] is int64eger subtraction. *) 148 | 149 | val ( * ) : int64 value -> int64 value -> int64 value 150 | (** [x * y] is int64eger addition. *) 151 | 152 | val ( / ) : int64 value -> int64 value -> int64 value 153 | (** [x / y] is integer division. *) 154 | 155 | (** {1:conv Conversions} *) 156 | 157 | val of_bool : bool value -> int64 value 158 | (** [of_bool b] is [b] as an int64 value. *) 159 | 160 | val of_int : int value -> int64 value 161 | (** [of_int i] is [i] as an int64 value. {b FIXME.} Clarify 162 | conversion. *) 163 | 164 | val of_float : float value -> int64 value 165 | (** [of_float f] is [f] as an int64 value. {b FIXME.} Clarify 166 | conversion. *) 167 | 168 | val of_string : string value -> int64 value 169 | (** [of_string s] converts [s] to string if [s] can't be parsed 170 | this results in [0]. *) 171 | end 172 | 173 | (** Floating point numbers. *) 174 | module Float : sig 175 | 176 | val v : float -> float value 177 | (** [v x] is the literal float [x]. *) 178 | 179 | val zero : float value 180 | (** [zero] is [v 0.0]. *) 181 | 182 | val one : float value 183 | (** [one] is [v 1.0]. *) 184 | 185 | (** {1:cmp Predicates and comparisons} *) 186 | 187 | val equal : float value -> float value -> bool value 188 | (** [equal x y] is floating point equality. *) 189 | 190 | val ( = ) : float value -> float value -> bool value 191 | (** [x = y] is floating point equality. *) 192 | 193 | (** {1:arith Arithmetic operators} *) 194 | 195 | val ( ~-. ) : float value -> float value 196 | (** [~-.x] is the floating point negation of [x]. *) 197 | 198 | val ( +. ) : float value -> float value -> float value 199 | (** [x +. y] is floating point addition. *) 200 | 201 | val ( -. ) : float value -> float value -> float value 202 | (** [x +. y] is floating point subtraction. *) 203 | 204 | val ( *. ) : float value -> float value -> float value 205 | (** [x *. y] is floating point addition. *) 206 | 207 | val ( /. ) : float value -> float value -> float value 208 | (** [x /. y] is floating point division. *) 209 | 210 | (** {1:conv Conversions} *) 211 | 212 | val of_bool : bool value -> float value 213 | (** [of_bool b] is [b] as a float value. *) 214 | 215 | val of_int : int value -> float value 216 | (** [of_int i] is [i] as a float value. *) 217 | 218 | val of_int64 : int64 value -> float value 219 | (** [of_int i] is [i] as a float value. *) 220 | 221 | val of_string : string value -> float value 222 | (** [of_string s] converts [s] to string if [s] can't be parsed 223 | this results in [0]. *) 224 | end 225 | 226 | (** Text. *) 227 | module Text : sig 228 | 229 | val v : string -> string value 230 | (** [v s] is the literal string [s]. *) 231 | 232 | val empty : string value 233 | (** [empty] is [v ""]. *) 234 | 235 | val equal : string value -> string value -> bool value 236 | (** [equal x y] is binary string equality. *) 237 | 238 | val ( = ) : string value -> string value -> bool value 239 | (** [x = y] is binary string equality. *) 240 | 241 | val ( ^ ) : string value -> string value -> string value 242 | (** [x ^ y] appends [y] to [x]. *) 243 | 244 | val like : string value -> string value -> bool value 245 | (** [like s pat] is [true] if pattern [pat] matches [s]. 246 | 247 | {b TODO.} add an escape syntax and automatically use it. *) 248 | 249 | (** {1:conv Conversions} *) 250 | 251 | val of_bool : bool value -> string value 252 | (** [of_bool b] is [b] as text. *) 253 | 254 | val of_int : int value -> string value 255 | (** [of_int i] is [i] as text. *) 256 | 257 | val of_int64 : int64 value -> string value 258 | (** [of_int i] is [i] as text. *) 259 | 260 | val of_float : float value -> string value 261 | (** [of_float f] is [f] as text. {b FIXME.} Clarify 262 | conversion. *) 263 | end 264 | 265 | (** Option. *) 266 | module Option : sig 267 | 268 | val v : 'a Rel.Type.t -> 'a option -> 'a option value 269 | (** [v t o] is an option of type [t]. *) 270 | 271 | val none : 'a Rel.Type.t -> 'a option value 272 | (** [none t] is [v t None]. *) 273 | 274 | val some : 'a Rel.Type.t -> 'a value -> 'a option value 275 | (** [some t v] is [Some v]. *) 276 | 277 | val is_none : 'a option value -> bool value 278 | (** [is_none v] is [true] iff [v] is [None]. *) 279 | 280 | val is_some : 'a option value -> bool value 281 | (** [is_some v] is [true] ifff [v] is [Some _]. *) 282 | 283 | val get : 'a option value -> 'a value 284 | (** [get v] is the value of [v] and an error otherwise. *) 285 | 286 | val has_value : 287 | eq:('a value -> 'a value -> bool value) -> 288 | 'a value -> 'a option value -> bool value 289 | 290 | val equal : 291 | eq:('a value -> 'a value -> bool value) -> 292 | 'a option value -> 'a option value -> bool value 293 | end 294 | 295 | (** Coded. *) 296 | 297 | module Coded : sig 298 | val v : 'a Rel.Type.t -> 'a -> 'a value 299 | val equal : 'a Rel.Type.t -> 'a value -> 'a value -> bool value 300 | end 301 | 302 | 303 | (** Bags specification language. 304 | 305 | Bags are multisets of values (rows). 306 | 307 | {b TODO} 308 | {ul 309 | {- GROUP BY support (in QUEL that's another monad).} 310 | {- LIMIT and ORDER BY support, the effects.} 311 | {- More data type functions} 312 | {- Can we specialize `yield` on `Row.t` with appropriate 313 | {!Bag.row} we could likely get to a scheme where we work directly 314 | with {!Rel.Row} in the language (for now we only work with {!Rel.Col}) 315 | which should help SQL execution boilerplate. What happens to 316 | higher-order ? }} *) 317 | module Bag : sig 318 | 319 | type 'a order 320 | (** The type for order effects. *) 321 | 322 | type unordered = unit order 323 | (** The type for unordered. *) 324 | 325 | type ('a, 'e) t 326 | (** The type for bags, multisets of values o type ['a] and an effect 327 | ['e] that can be applied on it. *) 328 | 329 | (** {1:bag Bag construction} *) 330 | 331 | val empty : ('a, 'e) t 332 | (** [empty] is the empty bag. *) 333 | 334 | val yield : 'a value -> ('a, unordered) t 335 | (** [yield v] is the bag with value [v]. *) 336 | 337 | val union : ('a, 'e) t -> ('a, 'e) t -> ('a, 'e) t 338 | (** [union b0 b1] has the values of [b0] and those of [b1]. *) 339 | 340 | val table : 'a Rel.Table.t -> ('a, unordered) t 341 | (** [table t] is a table from [t]. *) 342 | 343 | (** {1:transf Transforming and filtering} *) 344 | 345 | val foreach : ('a , _) t -> ('a value -> ('b, 'e) t) -> ('b, 'e) t 346 | (** [foreach b f] are the values of [b] mapped by [f] and unioned. *) 347 | 348 | val where : bool value -> ('a, 'e) t -> ('a, 'e) t 349 | (** [where c e] is the bag [e ()] if [b] whenever [c] is [true]. *) 350 | 351 | (** {1:pred Predicates} *) 352 | 353 | val exists : ('a, _) t -> bool value 354 | (** [exists b] is [true] if [b] is non-empty. *) 355 | 356 | val pp : Format.formatter -> ('a, _) t -> unit 357 | 358 | (** {1:proj Projections} 359 | 360 | {b XXX.} Fundamentaly this has nothing to do here. *) 361 | 362 | val proj : 'r value -> ('r, 'a) Rel.Col.t -> 'a value 363 | val row : ('a -> 'r) -> ('a -> 'r) value 364 | val inj : 'a -> 'a value 365 | val tuple : ('a -> 'b) value -> 'a value -> 'b value 366 | val const : 'a Rel.Type.t -> 'a -> 'a value 367 | end 368 | 369 | 370 | (** FIXME can't we merge that into {!Rel_sql.Stmt} ? 371 | FIXME can't we avoid the reverse typing ? *) 372 | module Sql : sig 373 | 374 | type ('a, 'f, 'r) func 375 | val func : (('r, 'e) Bag.t, 'f, 'r) func -> 'f 376 | val arg : 377 | 'a Rel.Type.t -> ('a value -> 'c, 'b, 'r) func -> ('c, 'a -> 'b, 'r) func 378 | 379 | val ( @-> ) : 380 | 'a Rel.Type.t -> ('a value -> 'c, 'b, 'r) func -> ('c, 'a -> 'b, 'r) func 381 | 382 | val ret : 'r Rel.Row.t -> 'a -> ('a, 'r Rel_sql.Stmt.t, 'r) func 383 | 384 | val bool : bool Rel.Type.t 385 | val int : int Rel.Type.t 386 | val int64 : int64 Rel.Type.t 387 | val float : float Rel.Type.t 388 | val text : string Rel.Type.t 389 | val blob : string Rel.Type.t 390 | val option : 'a Rel.Type.t -> 'a option Rel.Type.t 391 | 392 | val normalize : ('a, 'e) Bag.t -> ('a, 'e) Bag.t 393 | 394 | val of_bag : 'a Rel.Row.t -> ('a, 'b) Bag.t -> 'a Rel_sql.Stmt.t 395 | val of_bag' : 'a Rel.Table.t -> ('a, 'b) Bag.t -> 'a Rel_sql.Stmt.t 396 | end 397 | 398 | 399 | (** Query syntax support. 400 | 401 | Open this module to streamline query definition. *) 402 | module Syntax : sig 403 | (* module Type = Rel.Type 404 | module Col = Rel.Col 405 | module Row = Rel.Row 406 | module Index = Rel.Index 407 | module Table = Rel.Table *) 408 | 409 | type nonrec 'a value = 'a value 410 | 411 | module Bool = Bool 412 | module Int = Int 413 | module Int64 = Int64 414 | module Float = Float 415 | module Text = Text 416 | module Option = Option 417 | module Coded = Coded 418 | module Bag = Bag 419 | (* module Sql = Sql *) 420 | 421 | (** {1:boolops Boolean operators} *) 422 | 423 | val ( && ) : bool value -> bool value -> bool value 424 | (** [( && )] is {!Bool.( && )}. *) 425 | 426 | val ( || ) : bool value -> bool value -> bool value 427 | (** [( || )] is {!Bool.( || )}. *) 428 | 429 | val not : bool value -> bool value 430 | (** [not] is {!Bool.not}. *) 431 | 432 | (** {1:intops Integer operators} *) 433 | 434 | val ( ~- ) : int value -> int value 435 | (** [~-x] is the negation of [x]. *) 436 | 437 | val ( + ) : int value -> int value -> int value 438 | (** [x + y] is integer addition. *) 439 | 440 | val ( - ) : int value -> int value -> int value 441 | (** [x + y] is integer subtraction. *) 442 | 443 | val ( * ) : int value -> int value -> int value 444 | (** [x * y] is integer addition. *) 445 | 446 | val ( / ) : int value -> int value -> int value 447 | (** [x / y] is integer division. *) 448 | 449 | (** {1:floatops Float operators} *) 450 | 451 | val ( ~-. ) : float value -> float value 452 | (** [~-.x] is the floating point negation of [x]. *) 453 | 454 | val ( +. ) : float value -> float value -> float value 455 | (** [x +. y] is floating point addition. *) 456 | 457 | val ( -. ) : float value -> float value -> float value 458 | (** [x +. y] is floating point subtraction. *) 459 | 460 | val ( *. ) : float value -> float value -> float value 461 | (** [x *. y] is floating point addition. *) 462 | 463 | val ( /. ) : float value -> float value -> float value 464 | (** [x *. y] is floating point division. *) 465 | 466 | (** {1:row Row operators} *) 467 | 468 | val ( $ ) : ('a -> 'b) value -> 'a value -> 'b value 469 | (** [f $ v] applies [v] to row constructor [f]. *) 470 | 471 | val ( #. ) : 'r value -> ('r, 'a) Rel.Col.t -> 'a value 472 | (** [r #. c] projects [r] on column [c]. *) 473 | 474 | (** {1:bag Bag operators} *) 475 | 476 | val ( ++ ) : ('a, 'e) Bag.t -> ('a, 'e) Bag.t -> ('a, 'e) Bag.t 477 | (** [b0 ++ b1] is the union of bag [b0] and bag [b1]. *) 478 | 479 | (** {1:enum Enumeration} *) 480 | 481 | val ( let* ) : 482 | ('a , _) Bag.t -> ('a value -> ('b, 'e) Bag.t) -> ('b, 'e) Bag.t 483 | (** [let*] binds bag values for {!Bag.foreach}. *) 484 | end 485 | 486 | (** {1:private Private} *) 487 | 488 | (** Low-level private representations. 489 | 490 | For the language extender and backend writer. Subject to change 491 | even between minor versions of the library. *) 492 | module Private : sig 493 | 494 | (** {1:rows Rows} *) 495 | 496 | (** {1:ops Operators} *) 497 | 498 | type ('a, 'b) unop = .. 499 | (** The type for unary operations on base values of type ['a] returning 500 | values of type ['b]. *) 501 | 502 | type ('a, 'b) unop += 503 | | Neg : 'a Rel.Type.Repr.t -> ('a, 'a) unop (** Negation. *) 504 | (** Predefined unary operations. *) 505 | 506 | type ('a, 'b) binop = .. 507 | (** The type for binary operations on base values of type ['a] returning 508 | values of type ['b]. *) 509 | 510 | type arith = Add | Sub | Div | Mul 511 | (** The type for arithmetic operators. *) 512 | 513 | type cmp = Eq | Neq | Lt | Leq | Gt | Geq 514 | (** The type for comparison operators. *) 515 | 516 | type ('a, 'b) binop += 517 | | Arith : arith * 'a Rel.Type.Repr.t -> ('a, 'a) binop 518 | | Cmp : cmp * 'a Rel.Type.Repr.t -> ('a, bool) binop 519 | | And : (bool, bool) binop 520 | | Or : (bool, bool) binop (** *) 521 | (** Predefined binary operations. *) 522 | 523 | (** {1:vals_and_bags Values and bags} *) 524 | 525 | type 'a value' = 'a value 526 | (** See {!Rel_query.value}. *) 527 | 528 | type 'a value = 529 | | Var : string -> 'a value (* only for compiling *) 530 | | Const : 'a Rel.Type.Repr.t * 'a -> 'a value 531 | | Unop : ('a, 'b) unop * 'a value -> 'b value 532 | | Binop : ('a, 'b) binop * 'a value * 'a value -> 'b value 533 | | Proj : 'b value * ('b, 'a) Rel.Col.t -> 'a value 534 | | Row : 'a -> 'a value 535 | | Tuple : ('a -> 'b) value * 'a value -> 'b value 536 | | Exists : ('b, 'e) bag -> bool value (** *) 537 | (** The type for values of type ['a]. This represents an expression 538 | computing a value of type ['a]. *) 539 | 540 | and ('a, 'e) bag = 541 | | Table : 'a Rel.Table.t -> ('a, 'e) bag 542 | | Empty : ('a, 'e) bag 543 | | Yield : 'a value -> ('a, 'e) bag 544 | | Union : ('a, 'e) bag * ('a, 'e) bag -> ('a, 'e) bag 545 | | Foreach : ('a, _) bag * ('a value -> ('b, 'e) bag) -> ('b, 'e) bag 546 | | Where : bool value * ('a, 'e) bag -> ('a, 'e) bag (** *) 547 | (** The type for bags. See {!Bag.t}. *) 548 | 549 | val value_to_value : 'a value' -> 'a value 550 | (** [value_to_value v] is the repressentation of [v]. *) 551 | 552 | val bag_to_bag : ('a, 'e) Bag.t -> ('a, 'e) bag 553 | (** [bag_to_bag b] is the representation of [b]. *) 554 | 555 | (** {1:fmt Formatters} *) 556 | 557 | val pp_value : Format.formatter -> 'a value -> unit 558 | (** [pp_value] formats values. *) 559 | 560 | val pp_bag : Format.formatter -> ('a, 'e) bag -> unit 561 | (** [pp_bag] formats bags. *) 562 | end 563 | -------------------------------------------------------------------------------- /test/schemas.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Rel 7 | open Rel_query.Syntax 8 | 9 | (* TODO rewrite with new convention. Forget about 10 | objects representation. *) 11 | 12 | (* Example from Suzuki et al *) 13 | 14 | (* 15 | module Products_flat_with_objects = struct 16 | module S : sig 17 | type product = 18 | type order = 19 | type sales = 20 | 21 | (* Descriptions. *) 22 | 23 | val product' : int -> string -> int -> product 24 | val order' : int -> int -> int -> order 25 | val sales' : int -> string -> int -> sales 26 | 27 | val name : value -> string value 28 | val price : value -> int value 29 | val pid : value -> int value 30 | val oid : value -> int value 31 | val qty : value -> int value 32 | val sale : value -> int value 33 | 34 | val name' : (, string) Rel.Col.t 35 | val price' : (, int) Rel.Col.t 36 | val pid' : (, int) Rel.Col.t 37 | val oid' : (, int) Rel.Col.t 38 | val qty' : (, int) Rel.Col.t 39 | val sale' : (, int) Rel.Col.t 40 | 41 | val product_table : product Rel.Table.t 42 | val order_table : order Rel.Table.t 43 | val sales_row : sales Rel.Row.t 44 | 45 | end = struct 46 | type product = 47 | type order = 48 | type sales = 49 | 50 | let product' pid name price = 51 | object method pid = pid method name = name; method price = price end 52 | 53 | let order' oid pid qty = 54 | object method oid = oid method pid = pid; method qty = qty end 55 | 56 | let sales' pid name sale = 57 | object method pid = pid method name = name; method sale = sale end 58 | 59 | 60 | let proj o = o # name 61 | let name' = Col.v "name" Type.Text proj 62 | 63 | let proj o = o # price 64 | let price' = Col.v "price" Type.Int proj 65 | 66 | let proj o = o # pid 67 | let pid' = Col.v "pid" Type.Int proj 68 | 69 | let proj o = o # oid 70 | let oid' = Col.v "oid" Type.Int proj 71 | 72 | let proj o = o # qty 73 | let qty' = Col.v "qty" Type.Int proj 74 | 75 | let proj o = o # sale 76 | let sale' = Col.v "sale" Type.Int proj 77 | 78 | 79 | let name r = Bag.proj r name' 80 | let price r = Bag.proj r price' 81 | let pid r = Bag.proj r pid' 82 | let oid r = Bag.proj r oid' 83 | let qty r = Bag.proj r qty' 84 | let sale r = Bag.proj r sale' 85 | 86 | 87 | let product_table = 88 | Table.make "product" Row.(unit product' * pid' * name' * price') 89 | 90 | let order_table = 91 | Table.make "order" Row.(unit order' * oid' * pid' * qty') 92 | 93 | let sales_row = Row.(unit sales' * pid' * name' * sale') 94 | end 95 | module Q : sig 96 | val get_order : int value -> (S.order, Bag.unordered) Bag.t 97 | 98 | val get_order_sales : 99 | < pid : int; qty : int; .. > value -> 100 | (S.sales, Bag.unordered) Bag.t 101 | end = struct 102 | 103 | let get_order oid = 104 | let* o = Bag.table S.order_table in 105 | Bag.where Int.(S.oid o = oid) @@ 106 | Bag.yield o 107 | 108 | let get_order_sales o = 109 | let* p = Bag.table S.product_table in 110 | Bag.where Int.(S.pid p = S.pid o) @@ 111 | Bag.yield @@ S.(Bag.row sales' $ pid p $ name p $ price p * qty o) 112 | 113 | let get_order_sales o = 114 | let* p = Bag.table S.product_table in 115 | Bag.where Int.(S.pid p = S.pid o) @@ 116 | let s = S.(p #. price' * o #. qty') in 117 | Bag.yield @@ S.(Bag.row sales' $ p #. pid' $ p #. name' $ s) 118 | end 119 | 120 | module Data = struct 121 | let products = 122 | [ S.product' 1 "Tablet" 500; 123 | S.product' 2 "Laptop" 1000; 124 | S.product' 3 "Desktop" 1000; 125 | S.product' 4 "Router" 150; 126 | S.product' 5 "HDD" 100; 127 | S.product' 6 "SDD" 500] 128 | 129 | let orders = 130 | [ S.order' 1 1 5; 131 | S.order' 1 2 5; 132 | S.order' 1 4 2; 133 | S.order' 2 5 10; 134 | S.order' 2 6 20; 135 | S.order' 3 2 50; ] 136 | end 137 | end 138 | *) 139 | 140 | module Products_with_adts = struct 141 | module Product : sig 142 | type t 143 | val v : int -> string -> int -> t 144 | val pid : t -> int 145 | val name : t -> string 146 | val price : t -> int 147 | 148 | val pid' : (t, int) Rel.Col.t 149 | val name' : (t, string) Rel.Col.t 150 | val price' : (t, int) Rel.Col.t 151 | val table : t Rel.Table.t 152 | end = struct 153 | type t = { pid : int; name : string; price : int } 154 | let v pid name price = { pid; name; price } 155 | let pid p = p.pid 156 | let name p = p.name 157 | let price p = p.price 158 | 159 | let pid' = Col.make "pid" Type.int pid 160 | let name' = Col.make "name" Type.text name 161 | let price' = Col.make "price" Type.int price 162 | let table = 163 | let primary_key = Table.Primary_key.make [Def pid'] in 164 | let unique_keys = [Table.Unique_key.make [Col.Def name']] in 165 | Table.make "product" ~primary_key ~unique_keys @@ 166 | Row.(unit v * pid' * name' * price') 167 | end 168 | 169 | module Order : sig 170 | type t 171 | val v : int -> int -> int -> t 172 | val oid : t -> int 173 | val pid : t -> int 174 | val qty : t -> int 175 | val oid' : (t, int) Rel.Col.t 176 | val pid' : (t, int) Rel.Col.t 177 | val qty' : (t, int) Rel.Col.t 178 | val table : t Rel.Table.t 179 | end = struct 180 | type t = { oid : int; pid : int; qty : int } 181 | let v oid pid qty = { oid; pid; qty } 182 | let oid o = o.oid 183 | let pid o = o.pid 184 | let qty o = o.qty 185 | 186 | let oid' = Col.make "oid" Type.int oid 187 | let pid' = Col.make "pid" Type.int pid 188 | let qty' = Col.make "qty" Type.int qty 189 | let table = 190 | let fk = 191 | let parent = Product.(Table.Foreign_key.Table (table, [Col.Def pid'])) 192 | in 193 | Table.Foreign_key.make ~cols:[Col.Def pid'] ~parent () 194 | in 195 | Table.make "order" ~foreign_keys:[fk] Row.(unit v * oid' * pid' * qty') 196 | end 197 | 198 | type sales = 199 | let sales pid name sale = 200 | object method pid = pid method name = name; method sale = sale end 201 | 202 | module Q : sig 203 | val get_order : int value -> (Order.t, Bag.unordered) Bag.t 204 | val get_order_sales : Order.t value -> (sales, Bag.unordered) Bag.t 205 | end = struct 206 | let get_order oid = 207 | let* o = Bag.table Order.table in 208 | Bag.where Int.(o #. Order.oid' = oid) @@ 209 | Bag.yield o 210 | 211 | let get_order_sales o = 212 | let* p = Bag.table Product.table in 213 | Bag.where Int.(p #. Product.pid' = o #. Order.pid') @@ 214 | let amount = p #. Product.price' * o #. Order.qty' in 215 | Bag.yield @@ Bag.(row sales $ 216 | p #. Product.pid' $ p #. Product.name' $ amount) 217 | end 218 | 219 | module Data = struct 220 | let products = 221 | [ Product.v 1 "Tablet" 500; 222 | Product.v 2 "Laptop" 1000; 223 | Product.v 3 "Desktop" 1000; 224 | Product.v 4 "Router" 150; 225 | Product.v 5 "HDD" 100; 226 | Product.v 6 "SDD" 500;] 227 | 228 | let orders = 229 | [ Order.v 1 1 5; 230 | Order.v 1 2 5; 231 | Order.v 1 4 2; 232 | Order.v 2 5 10; 233 | Order.v 2 6 20; 234 | Order.v 3 2 50; ] 235 | end 236 | end 237 | 238 | (* Slightly reworded examples of Cheney et al. *) 239 | 240 | module Duos = struct 241 | module Person : sig 242 | type t 243 | val v : string -> int -> t 244 | val name : t -> string 245 | val age : t -> int 246 | 247 | val name' : (t, string) Col.t 248 | val age' : (t, int) Col.t 249 | val table : t Table.t 250 | end = struct 251 | type t = { name : string; age : int } 252 | let v name age = { name; age } 253 | let name p = p.name 254 | let age p = p.age 255 | 256 | let name' = Col.make "name" Type.text name 257 | let age' = Col.make "age" Type.int age 258 | let table = 259 | let primary_key = Table.Primary_key.make [Def name'] in 260 | Table.make "person" Row.(unit v * name' * age') ~primary_key 261 | end 262 | 263 | module Duo : sig 264 | type t 265 | val v : string -> string -> t 266 | val fst : t -> string 267 | val snd : t -> string 268 | 269 | val fst' : (t, string) Col.t 270 | val snd' : (t, string) Col.t 271 | val table : t Table.t 272 | end = struct 273 | type t = string * string 274 | let v fst snd = (fst, snd) 275 | let fst = fst 276 | let snd = snd 277 | 278 | 279 | let fst' = Col.make "fst" Type.text fst 280 | let snd' = Col.make "snd" Type.text snd 281 | let table = Table.make "duo" Row.(unit v * fst' * snd') 282 | end 283 | 284 | module Q = struct 285 | let diff = 286 | let* d = Bag.table Duo.table in 287 | let* fst = Bag.table Person.table in 288 | let* snd = Bag.table Person.table in 289 | let fst_name = fst #. Person.name' and fst_age = fst #. Person.age' in 290 | let snd_name = snd #. Person.name' and snd_age = snd #. Person.age' in 291 | Bag.where (Text.(d #. Duo.fst' = fst_name) && 292 | Text.(d #. Duo.snd' = snd_name) && 293 | Int.(fst_age > snd_age)) @@ 294 | Bag.yield (Bag.row (fun n d -> n, d) $ fst_name $ fst_age - snd_age) 295 | 296 | let persons_in_age_range ~first ~last = 297 | let* p = Bag.table Person.table in 298 | let age = p #. Person.age' in 299 | Bag.where Int.(first <= age && age <= last) @@ 300 | Bag.yield (p #. Person.name') 301 | 302 | let persons_sat ~sat = 303 | let* p = Bag.table Person.table in 304 | Bag.where (sat p) @@ 305 | Bag.yield (p #. Person.name') 306 | 307 | let person_age ~name = 308 | let* p = Bag.table Person.table in 309 | Bag.where Text.(p #. Person.name' = name) @@ 310 | Bag.yield (p #. Person.age') 311 | 312 | type int_predicate = 313 | | Above of int 314 | | Below of int 315 | | And of int_predicate * int_predicate 316 | | Or of int_predicate * int_predicate 317 | | Not of int_predicate 318 | 319 | let rec pred p = match p with 320 | | Above l -> fun i -> Int.(v l <= i) 321 | | Below l -> fun i -> Int.(i < v l) 322 | | And (l, r) -> fun i -> (pred l) i && (pred r) i 323 | | Or (l, r) -> fun i -> (pred l) i || (pred r) i 324 | | Not p -> fun i -> not ((pred p) i) 325 | 326 | let thirties_pred = And (Above 30, Below 40) 327 | let thirties_pred' = Not (Or (Below 30, Above 40)) 328 | end 329 | 330 | module Data = struct 331 | let persons = 332 | [ Person.v "Alex" 60; 333 | Person.v "Bert" 55; 334 | Person.v "Cora" 33; 335 | Person.v "Drew" 31; 336 | Person.v "Edna" 21; 337 | Person.v "Fred" 60; ] 338 | 339 | let duos = 340 | [ Duo.v "Alex" "Bert"; 341 | Duo.v "Cora" "Drew"; 342 | Duo.v "Edna" "Fred" ] 343 | end 344 | end 345 | 346 | module Org = struct 347 | module Department : sig 348 | type t 349 | val v : string -> t 350 | val name : t -> string 351 | val name' : (t, string) Col.t 352 | val table : t Table.t 353 | end = struct 354 | type t = { name : string } 355 | let v name = { name } 356 | let name p = p.name 357 | let name' = Col.make "name" Type.text name 358 | let table = 359 | let primary_key = Table.Primary_key.make [Def name'] in 360 | Table.make "department" Row.(unit v * name') ~primary_key 361 | end 362 | 363 | module Person : sig 364 | type t 365 | val v : string -> string -> t 366 | val name : t -> string 367 | val department : t -> string 368 | val name' : (t, string) Col.t 369 | val department' : (t, string) Col.t 370 | val table : t Table.t 371 | end = struct 372 | type t = { name : string; department : string } 373 | let v name department = { name; department } 374 | let name p = p.name 375 | let department p = p.department 376 | let name' = Col.make "name" Type.text name 377 | let department' = Col.make "department" Type.text department 378 | let table = 379 | let primary_key = Table.Primary_key.make [Def name'] in 380 | Table.make "person" Row.(unit v * name' * department') ~primary_key 381 | end 382 | 383 | module Task : sig 384 | type t 385 | val v : string -> string -> t 386 | val person : t -> string 387 | val task : t -> string 388 | 389 | val person' : (t, string) Col.t 390 | val task' : (t, string) Col.t 391 | val table : t Table.t 392 | end = struct 393 | type t = { person : string; task : string } 394 | let v person task = { person; task } 395 | let person p = p.person 396 | let task p = p.task 397 | 398 | let person' = Col.make "person" Type.text person 399 | let task' = Col.make "task" Type.text task 400 | let table = Table.make "task" Row.(unit v * person' * task') 401 | end 402 | 403 | module Q = struct 404 | 405 | let department_expertise ~task = 406 | let* d = Bag.table Department.table in 407 | let person_can't ~task p = 408 | not @@ Bag.exists @@ 409 | let* t = Bag.table Task.table in 410 | let is_p = Text.(t #. Task.person' = p #. Person.name') in 411 | let is_task = Text.(t #. Task.task' = task) in 412 | Bag.where (is_p && is_task) @@ 413 | Bag.yield (Bool.v true) 414 | in 415 | let some_can't ~task = 416 | let* p = Bag.table Person.table in 417 | let is_dep = Text.(p #. Person.department' = d #. Department.name') 418 | in 419 | Bag.where (is_dep && person_can't ~task p) @@ 420 | Bag.yield (Bool.v true) 421 | in 422 | Bag.where (not (Bag.exists (some_can't ~task))) @@ 423 | Bag.yield (d #. Department.name') 424 | 425 | module N = struct 426 | type member = { name : string; tasks : (string, Bag.unordered) Bag.t } 427 | type dept = { dept : string; members : (member, Bag.unordered) Bag.t } 428 | let member name tasks = { name; tasks} 429 | let dept dept members = { dept; members } 430 | 431 | type 'a Type.Custom.type' += Bag : ('a, 'e) Bag.t Type.Custom.type' 432 | (* XXX loss of polymorphism *) 433 | let bag0 = Type.custom (Type.Custom.make Bag ~name:"bag") 434 | let bag1 = Type.custom (Type.Custom.make Bag ~name:"bag") 435 | let name = Col.make "name" Type.text (fun m -> m.name) 436 | let tasks = Col.make "tasks" bag0 (fun m -> m.tasks) 437 | let dept_name = Col.make "dept" Type.text (fun d -> d.dept) 438 | let members = Col.make "members" bag1 (fun d -> d.members) 439 | end 440 | 441 | let nested_org = 442 | let person_tasks p = 443 | let* task = Bag.table Task.table in 444 | Bag.where Text.(task #. Task.person' = p #. Person.name') @@ 445 | Bag.yield (task #. Task.task') 446 | in 447 | let member p = 448 | let name = p #. Person.name' in 449 | let tasks = person_tasks p in 450 | Bag.row N.member $ name $ Bag.inj tasks 451 | in 452 | let* d = Bag.table Department.table in 453 | let dept = d #. Department.name' in 454 | let members = 455 | let* p = Bag.table Person.table in 456 | Bag.where Text.(p #. Person.department' = dept) @@ 457 | Bag.yield (member p) 458 | in 459 | Bag.yield (Bag.row N.dept $ dept $ Bag.inj members) 460 | 461 | let any ~sat vs = 462 | Bag.exists @@ 463 | let* v = vs in 464 | Bag.where (sat v) @@ Bag.yield (Bool.v true) 465 | 466 | let all ~sat vs = not (any ~sat vs) 467 | let contains ~eq v vs = any ~sat:(fun v' -> eq v v') vs 468 | 469 | (* TODO we can't replicate this. Maybe we have something 470 | wrong in the language. the problem is how to bring back 471 | ('a, 'e) Bag.t value to bags. Bags of bags can't work 472 | but if we manage to eliminate them in the end, they should 473 | not pose problem. 474 | 475 | let expertise' ~task = 476 | let* d = nested_org in 477 | let has_task m = contains ~eq:String.( = ) task (m #. N.tasks) in 478 | Bag.where (all ~sat:has_task (d #. N.members)) @@ 479 | Bag.yield (d #. N.dept_name) 480 | *) 481 | end 482 | 483 | 484 | module Data = struct 485 | let departments = 486 | Department.[v "Product"; v "Quality"; v "Research"; v "Sales"] 487 | 488 | let persons = 489 | Person.[v "Alex" "Product"; 490 | v "Bert" "Product"; 491 | v "Cora" "Research"; 492 | v "Drew" "Research"; 493 | v "Edna" "Research"; 494 | v "Fred" "Sales"; ] 495 | 496 | let tasks = 497 | Task.[v "Alex" "build"; 498 | v "Bert" "build"; 499 | v "Cora" "abstract"; v "Cora" "build"; v "Cora" "design"; 500 | v "Drew" "abstract"; v "Drew" "design"; 501 | v "Edna" "abstract"; v "Edna" "call"; v "Edna" "design"; 502 | v "Fred" "call"; ] 503 | end 504 | end 505 | 506 | (* Here again higher order is needed 507 | 508 | module Xpath = struct 509 | 510 | module Node = struct 511 | type t = { id : int; parent : int; name : string; pre : int; post : int } 512 | let v id parent name pre post = { id; parent; name; pre; post } 513 | let id n = n.id 514 | let parent n = n.parent 515 | let name n = n.name 516 | let pre n = n.pre 517 | let post n = n.post 518 | module C = struct 519 | let id = Col.make "id" Type.Int id ~params:[Sql.Col_primary_key] 520 | let parent = Col.make "parent" Type.Int parent 521 | let name = Col.make "name" Type.Text name 522 | let pre = Col.make "pre" Type.Int pre 523 | let post = Col.make "post" Type.Int post 524 | end 525 | let table = 526 | Table.make "node" 527 | Row.(unit v * C.id * C.parent * C.name * C.pre * C.post) 528 | end 529 | 530 | type axis = 531 | | Self | Child | Descendent | Descendent_or_self | Following 532 | | Following_sibling | Rev of axis 533 | 534 | type path = 535 | | Seq of path * path | Axis of axis | Name of string | Filter of path 536 | 537 | let rec axis = function 538 | | Self -> fun s t -> Int.(s #. Node.C.id = t #. Node.C.id) 539 | | Child -> fun s t -> Int.(s #. Node.C.id = t #. Node.C.parent) 540 | | Descendent -> 541 | fun s t -> 542 | Int.(s #. Node.C.pre < t #. Node.C.pre) && 543 | Int.(t #. Node.C.post <= s #. Node.C.post) 544 | | Descendent_or_self -> failwith "TODO" 545 | | Following -> failwith "TODO" 546 | | Following_sibling -> failwith "TODO" 547 | | Rev a -> fun s t -> axis a t s 548 | 549 | let rec path p = function 550 | | Seq (p, q) -> fun s, u -> any (* XXX see above *) 551 | 552 | 553 | let xp0 = Seq (Axis Child, Axis, Child) (* /*/* *) 554 | 555 | 556 | module Data = struct 557 | let nodes = 558 | Node.[ v 0 (-1) "#doc" 0 13; 559 | v 1 0 "a" 1 12; 560 | v 2 1 "b" 2 5; 561 | v 3 2 "c" 3 4; 562 | v 4 1 "d" 6 11; 563 | v 5 4 "e" 7 8; 564 | v 6 4 "f" 9 10; ] 565 | end 566 | end 567 | *) 568 | -------------------------------------------------------------------------------- /src/sqlite3/rel_sqlite3.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2020 The rel programmers. All rights reserved. 3 | SPDX-License-Identifier: ISC 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** {{:http://sqlite.org}SQLite3} support. 7 | 8 | {b Thread safety.} The connections exposed by this module are not 9 | thread safe. Besides using different connections with different 10 | threads provides proper 11 | {{:https://sqlite.org/isolation.html}isolation}. If you are using 12 | multiple threads {!Rel_pool} the connections. 13 | 14 | {b Concurrency.} Reader and writer concurrency can be improved by 15 | setting your database in {{:https://sqlite.org/wal.html}WAL mode}. 16 | 17 | {b Warning.} Functions of this module may raise [Invalid_argument] 18 | if any string given to C contains null bytes. 19 | 20 | {b References.} 21 | 22 | - SQLite {{:https://sqlite.org/lang.html}SQL reference}. 23 | - SQLite {{:https://sqlite.org/capi3ref.html}C API reference}. 24 | 25 | {b TODO.} 26 | {ul 27 | {- Provide support for the {{:https://sqlite.org/errlog.html} 28 | errorlog}, the blob API.} 29 | {- Have a look again at {{:https://sqlite.org/tclsqlite.html}tcl's binding} 30 | feature set.} 31 | {- [rel-sqlite3] tool, support for indexes} 32 | {- Low-level statement interface provide support for the sql remainder.}} *) 33 | 34 | open Rel 35 | 36 | (** {1:err Errors} *) 37 | 38 | type error 39 | (** The type for errors. *) 40 | 41 | (** Errors. *) 42 | module Error : sig 43 | 44 | (** {1:codes Result codes} *) 45 | 46 | type code 47 | (** The type for result codes. [Rel_sqlite3] database connections 48 | exposes only 49 | {{:https://sqlite.org/rescode.html#primary_result_codes_versus_extended_result_codes}extended result} codes. See {{!Error.cst}constants}. *) 50 | 51 | val code_to_string : code -> string 52 | (** [code_to_string c] is an english message for result code [c]. *) 53 | 54 | (** {1:errors Errors} *) 55 | 56 | type t = error 57 | (** The type for errors. *) 58 | 59 | val code : t -> code 60 | (** [code e] is the result code of [e]. *) 61 | 62 | val message : t -> string 63 | (** [message e] is the error message of [e]. This may be 64 | more precise than {!code_to_string} on [e]'s code, it is the 65 | result of {{:https://sqlite.org/c3ref/errcode.html}[sqlite3_errmsg]} on 66 | the database connection that errored. *) 67 | 68 | (** {1:cst Result code constants} *) 69 | 70 | val abort_rollback : code 71 | (** {{:https://sqlite.org/rescode.html#abort_rollback} 72 | SQLITE_ABORT_ROLLBACK} *) 73 | 74 | val busy_recovery : code 75 | (** {{:https://sqlite.org/rescode.html#busy_recovery}SQLITE_BUSY_RECOVERY} *) 76 | 77 | val busy_snapshot : code 78 | (** {{:https://sqlite.org/rescode.html#busy_snapshot}SQLITE_BUSY_SNAPSHOT} *) 79 | 80 | val busy_timeout : code 81 | (** {{:https://sqlite.org/rescode.html#busy_timeout}SQLITE_BUSY_TIMEOUT} *) 82 | 83 | val cantopen_convpath : code 84 | (** {{:https://sqlite.org/rescode.html#cantopen_convpath} 85 | SQLITE_CANTOPEN_CONVPATH} *) 86 | 87 | val cantopen_dirtywal : code 88 | (** {{:https://sqlite.org/rescode.html#cantopen_dirtywal} 89 | SQLITE_CANTOPEN_DIRTYWAL} *) 90 | 91 | val cantopen_fullpath : code 92 | (** {{:https://sqlite.org/rescode.html#cantopen_fullpath} 93 | SQLITE_CANTOPEN_FULLPATH} *) 94 | 95 | val cantopen_isdir : code 96 | (** {{:https://sqlite.org/rescode.html#cantopen_isdir} 97 | SQLITE_CANTOPEN_ISDIR} *) 98 | 99 | val cantopen_notempdir : code 100 | (** {{:https://sqlite.org/rescode.html#cantopen_notempdir} 101 | SQLITE_CANTOPEN_NOTEMPDIR} *) 102 | 103 | val cantopen_symlink : code 104 | (** {{:https://sqlite.org/rescode.html#cantopen_symlink} 105 | SQLITE_CANTOPEN_SYMLINK} *) 106 | 107 | val constraint_check : code 108 | (** {{:https://sqlite.org/rescode.html#constraint_check} 109 | SQLITE_CONSTRAINT_CHECK} *) 110 | 111 | val constraint_commithook : code 112 | (** {{:https://sqlite.org/rescode.html#constraint_commithook} 113 | SQLITE_CONSTRAINT_COMMITHOOK} *) 114 | 115 | val constraint_foreignkey : code 116 | (** {{:https://sqlite.org/rescode.html#constraint_foreignkey} 117 | SQLITE_CONSTRAINT_FOREIGNKEY} *) 118 | 119 | val constraint_function : code 120 | (** {{:https://sqlite.org/rescode.html#constraint_function} 121 | SQLITE_CONSTRAINT_FUNCTION} *) 122 | 123 | val constraint_notnull : code 124 | (** {{:https://sqlite.org/rescode.html#constraint_notnull} 125 | SQLITE_CONSTRAINT_NOTNULL} *) 126 | 127 | val constraint_pinned : code 128 | (** {{:https://sqlite.org/rescode.html#constraint_pinned} 129 | SQLITE_CONSTRAINT_PINNED} *) 130 | 131 | val constraint_primarykey : code 132 | (** {{:https://sqlite.org/rescode.html#constraint_primarykey} 133 | SQLITE_CONSTRAINT_PRIMARYKEY} *) 134 | 135 | val constraint_rowid : code 136 | (** {{:https://sqlite.org/rescode.html#constraint_rowid} 137 | SQLITE_CONSTRAINT_ROWID} *) 138 | 139 | val constraint_trigger : code 140 | (** {{:https://sqlite.org/rescode.html#constraint_trigger} 141 | SQLITE_CONSTRAINT_TRIGGER} *) 142 | 143 | val constraint_unique : code 144 | (** {{:https://sqlite.org/rescode.html#constraint_unique} 145 | SQLITE_CONSTRAINT_UNIQUE} *) 146 | 147 | val constraint_vtab : code 148 | (** {{:https://sqlite.org/rescode.html#constraint_vtab} 149 | SQLITE_CONSTRAINT_VTAB} *) 150 | 151 | val corrupt_index : code 152 | (** {{:https://sqlite.org/rescode.html#corrupt_index}SQLITE_CORRUPT_INDEX} *) 153 | 154 | val corrupt_sequence : code 155 | (** {{:https://sqlite.org/rescode.html#corrupt_sequence} 156 | SQLITE_CORRUPT_SEQUENCE} *) 157 | 158 | val corrupt_vtab : code 159 | (** {{:https://sqlite.org/rescode.html#corrupt_vtab}SQLITE_CORRUPT_VTAB} *) 160 | 161 | val error_missing_collseq : code 162 | (** {{:https://sqlite.org/rescode.html#error_missing_collseq} 163 | SQLITE_ERROR_MISSING_COLLSEQ} *) 164 | 165 | val error_retry : code 166 | (** {{:https://sqlite.org/rescode.html#error_retry}SQLITE_ERROR_RETRY} *) 167 | 168 | val error_snapshot : code 169 | (** {{:https://sqlite.org/rescode.html#error_snapshot} 170 | SQLITE_ERROR_SNAPSHOT} *) 171 | 172 | val ioerr_access : code 173 | (** {{:https://sqlite.org/rescode.html#ioerr_access}SQLITE_IOERR_ACCESS} *) 174 | 175 | val ioerr_auth : code 176 | (** {{:https://sqlite.org/rescode.html#ioerr_auth}SQLITE_IOERR_AUTH} *) 177 | 178 | val ioerr_begin_atomic : code 179 | (** {{:https://sqlite.org/rescode.html#ioerr_begin_atomic} 180 | SQLITE_IOERR_BEGIN_ATOMIC} *) 181 | 182 | val ioerr_blocked : code 183 | (** {{:https://sqlite.org/rescode.html#ioerr_blocked}SQLITE_IOERR_BLOCKED} *) 184 | 185 | val ioerr_checkreservedlock : code 186 | (** {{:https://sqlite.org/rescode.html#ioerr_checkreservedlock} 187 | SQLITE_IOERR_CHECKRESERVEDLOCK} *) 188 | 189 | val ioerr_close : code 190 | (** {{:https://sqlite.org/rescode.html#ioerr_close}SQLITE_IOERR_CLOSE} *) 191 | 192 | val ioerr_commit_atomic : code 193 | (** {{:https://sqlite.org/rescode.html#ioerr_commit_atomic} 194 | SQLITE_IOERR_COMMIT_ATOMIC} *) 195 | 196 | val ioerr_convpath : code 197 | (** {{:https://sqlite.org/rescode.html#ioerr_convpath} 198 | SQLITE_IOERR_CONVPATH} *) 199 | 200 | val ioerr_data : code 201 | (** {{:https://sqlite.org/rescode.html#ioerr_data}SQLITE_IOERR_DATA} *) 202 | 203 | val ioerr_delete : code 204 | (** {{:https://sqlite.org/rescode.html#ioerr_delete}SQLITE_IOERR_DELETE} *) 205 | 206 | val ioerr_delete_noent : code 207 | (** {{:https://sqlite.org/rescode.html#ioerr_delete_noent} 208 | SQLITE_IOERR_DELETE_NOENT} *) 209 | 210 | val ioerr_dir_close : code 211 | (** {{:https://sqlite.org/rescode.html#ioerr_dir_close} 212 | SQLITE_IOERR_DIR_CLOSE} *) 213 | 214 | val ioerr_dir_fsync : code 215 | (** {{:https://sqlite.org/rescode.html#ioerr_dir_fsync} 216 | SQLITE_IOERR_DIR_FSYNC} *) 217 | 218 | val ioerr_fstat : code 219 | (** {{:https://sqlite.org/rescode.html#ioerr_fstat}SQLITE_IOERR_FSTAT} *) 220 | 221 | val ioerr_fsync : code 222 | (** {{:https://sqlite.org/rescode.html#ioerr_fsync}SQLITE_IOERR_FSYNC} *) 223 | 224 | val ioerr_gettemppath : code 225 | (** {{:https://sqlite.org/rescode.html#ioerr_gettemppath} 226 | SQLITE_IOERR_GETTEMPPATH} *) 227 | 228 | val ioerr_lock : code 229 | (** {{:https://sqlite.org/rescode.html#ioerr_lock}SQLITE_IOERR_LOCK} *) 230 | 231 | val ioerr_mmap : code 232 | (** {{:https://sqlite.org/rescode.html#ioerr_mmap}SQLITE_IOERR_MMAP} *) 233 | 234 | val ioerr_nomem : code 235 | (** {{:https://sqlite.org/rescode.html#ioerr_nomem}SQLITE_IOERR_NOMEM} *) 236 | 237 | val ioerr_rdlock : code 238 | (** {{:https://sqlite.org/rescode.html#ioerr_rdlock}SQLITE_IOERR_RDLOCK} *) 239 | 240 | val ioerr_read : code 241 | (** {{:https://sqlite.org/rescode.html#ioerr_read}SQLITE_IOERR_READ} *) 242 | 243 | val ioerr_rollback_atomic : code 244 | (** {{:https://sqlite.org/rescode.html#ioerr_rollback_atomic} 245 | SQLITE_IOERR_ROLLBACK_ATOMIC} *) 246 | 247 | val ioerr_seek : code 248 | (** {{:https://sqlite.org/rescode.html#ioerr_seek}SQLITE_IOERR_SEEK} *) 249 | 250 | val ioerr_shmlock : code 251 | (** {{:https://sqlite.org/rescode.html#ioerr_shmlock}SQLITE_IOERR_SHMLOCK} *) 252 | 253 | val ioerr_shmmap : code 254 | (** {{:https://sqlite.org/rescode.html#ioerr_shmmap}SQLITE_IOERR_SHMMAP} *) 255 | 256 | val ioerr_shmopen : code 257 | (** {{:https://sqlite.org/rescode.html#ioerr_shmopen}SQLITE_IOERR_SHMOPEN} *) 258 | 259 | val ioerr_shmsize : code 260 | (** {{:https://sqlite.org/rescode.html#ioerr_shmsize}SQLITE_IOERR_SHMSIZE} *) 261 | 262 | val ioerr_short_read : code 263 | (** {{:https://sqlite.org/rescode.html#ioerr_short_read} 264 | SQLITE_IOERR_SHORT_READ} *) 265 | 266 | val ioerr_truncate : code 267 | (** {{:https://sqlite.org/rescode.html#ioerr_truncate} 268 | SQLITE_IOERR_TRUNCATE} *) 269 | 270 | val ioerr_unlock : code 271 | (** {{:https://sqlite.org/rescode.html#ioerr_unlock}SQLITE_IOERR_UNLOCK} *) 272 | 273 | val ioerr_vnode : code 274 | (** {{:https://sqlite.org/rescode.html#ioerr_vnode}SQLITE_IOERR_VNODE} *) 275 | 276 | val ioerr_write : code 277 | (** {{:https://sqlite.org/rescode.html#ioerr_write}SQLITE_IOERR_WRITE} *) 278 | 279 | val locked_sharedcache : code 280 | (** {{:https://sqlite.org/rescode.html#locked_sharedcache} 281 | SQLITE_LOCKED_SHAREDCACHE} *) 282 | 283 | val locked_vtab : code 284 | (** {{:https://sqlite.org/rescode.html#locked_vtab}SQLITE_LOCKED_VTAB} *) 285 | 286 | val notice_recover_rollback : code 287 | (** {{:https://sqlite.org/rescode.html#notice_recover_rollback} 288 | SQLITE_NOTICE_RECOVER_ROLLBACK} *) 289 | 290 | val notice_recover_wal : code 291 | (** {{:https://sqlite.org/rescode.html#notice_recover_wal} 292 | SQLITE_NOTICE_RECOVER_WAL} *) 293 | 294 | val ok_load_permanently : code 295 | (** {{:https://sqlite.org/rescode.html#ok_load_permanently} 296 | SQLITE_OK_LOAD_PERMANENTLY} *) 297 | 298 | val readonly_cantinit : code 299 | (** {{:https://sqlite.org/rescode.html#readonly_cantinit} 300 | SQLITE_READONLY_CANTINIT} *) 301 | 302 | val readonly_cantlock : code 303 | (** {{:https://sqlite.org/rescode.html#readonly_cantlock} 304 | SQLITE_READONLY_CANTLOCK} *) 305 | 306 | val readonly_dbmoved : code 307 | (** {{:https://sqlite.org/rescode.html#readonly_dbmoved} 308 | SQLITE_READONLY_DBMOVED} *) 309 | 310 | val readonly_directory : code 311 | (** {{:https://sqlite.org/rescode.html#readonly_directory} 312 | SQLITE_READONLY_DIRECTORY} *) 313 | 314 | val readonly_recovery : code 315 | (** {{:https://sqlite.org/rescode.html#readonly_recovery} 316 | SQLITE_READONLY_RECOVERY} *) 317 | 318 | val readonly_rollback : code 319 | (** {{:https://sqlite.org/rescode.html#readonly_rollback} 320 | SQLITE_READONLY_ROLLBACK} *) 321 | 322 | val warning_autoindex : code 323 | (** {{:https://sqlite.org/rescode.html#warning_autoindex} 324 | SQLITE_WARNING_AUTOINDEX} *) 325 | end 326 | 327 | val string_error : ('a, error) result -> ('a, string) result 328 | (** [string_error r] is [Result.map_error Error.message r]. *) 329 | 330 | (** {1:library Library configuration and information} *) 331 | 332 | val version : unit -> string 333 | (** [version ()] is the {{:https://sqlite.org/c3ref/libversion.html}version} 334 | of the SQLite library. *) 335 | 336 | (** {1:connections Database connection} *) 337 | 338 | type mode = 339 | | Read 340 | | Read_write 341 | | Read_write_create (** Created if missing (default). *) 342 | | Memory (** In memory. *) 343 | (** The type for connection modes. *) 344 | 345 | type mutex = 346 | | No (** Multi-threaded mode (this is not a typo). *) 347 | | Full (** Serialized mode. *) 348 | (** The type for specifying the 349 | {{:https://sqlite.org/threadsafe.html}threading mode}. *) 350 | 351 | type t 352 | (** The type for SQLite3 connections. {b Warning.} [Rel_sqlite3]'s 353 | abstraction of connections is not thread-safe. *) 354 | 355 | val open' : 356 | ?foreign_keys:bool -> ?stmt_cache_size:int -> ?vfs:string -> ?uri:bool -> 357 | ?mutex:mutex -> mode:mode -> string -> (t, error) result 358 | (** [open' file] opens a connection on file [file]: 359 | {ul 360 | {- [mode] defines the connection mode.} 361 | {- [mutex] defines the threading mode. Defauls to [Full].} 362 | {- [uri], if [true] (default) the 363 | {{:https://sqlite.org/uri.html}URI syntax} is allowed for [file].} 364 | {- [vfs] is the {{:https://sqlite.org/vfs.html}vfs} to use.} 365 | {- [stmt_cache_size] is the connection's statement cache size, 366 | it defaults to [10].} 367 | {- [foreign_keys]'s value is used to immediately invoke the 368 | {{:https://sqlite.org/pragma.html#pragma_foreign_keys}[foreign_keys]} 369 | pragma on the database connection. Defaults to [true] to 370 | enforce constraints, this is not SQLite's default.}} 371 | 372 | See {{:https://sqlite.org/c3ref/open.html}[sqlite3_open_v2]} for more 373 | details about the parameters (except [stmt_cache_size] and 374 | [foreign_keys]). *) 375 | 376 | val close : t -> (unit, error) result 377 | (** [close db] closes the connection to database [db]. 378 | 379 | This will only ever error if there are ressources of [db] that 380 | were not disposed properly. For example if you use the 381 | {{!Rel_sqlite3.Stmt}low-level} statement interface and forget to 382 | dispose the statements before closing the database. *) 383 | 384 | val busy_timeout_ms : t -> int -> (unit, error) result 385 | (** [busy_timout_ms db d] sets 386 | {{:https://sqlite.org/c3ref/busy_timeout.html}the busy timeout} to [d] 387 | milliseconds. If you are planning to perform concurrent writes you 388 | should, {{!page-sqlite3_howto.webapp}among other things}, set this 389 | to a suitable amount. *) 390 | 391 | val changes : t -> int 392 | (** [changes db] is the 393 | {{:https://www.sqlite.org/c3ref/changes.html}number of rows} 394 | modified, inserted or deleted by the last executed statement on 395 | [db]. *) 396 | 397 | val last_insert_rowid : t -> int64 398 | (** [last_insert_rowid db] is 399 | {{:https://sqlite.org/c3ref/last_insert_rowid.html}the rowid} (or 400 | INTEGER PRIMARY KEY) of the most recent successful INSERT into a 401 | rowid table. *) 402 | 403 | (** {2:prep_stmt Prepared statement cache} *) 404 | 405 | val stmt_cache_size : t -> int 406 | (** [stmt_cache_size d] is [d]'s maximal number of cached prepared 407 | statements. *) 408 | 409 | val set_stmt_cache_size : t -> int -> unit 410 | (** [set_stmt_cache_size d max] sets the maximal number of cached prepared 411 | statements to [max] in [d]. Note that this clears the cache. *) 412 | 413 | val clear_stmt_cache : t -> unit 414 | (** [clear_stmt_cache d] clears the cache of prepared statements. *) 415 | 416 | (** {1:query SQL execution} *) 417 | 418 | val exec_sql : t -> string -> (unit, error) result 419 | (** [exec_sql db sql] executes the SQL statements [sql] on [db] and 420 | ignores the result. [sql] is neither prepared nor cached. Use this 421 | to execute SQL scripts. If you are doing lots of inserts or 422 | updates make a {{!Rel_sqlite3.with_transaction}transaction} to 423 | ensure good performance. *) 424 | 425 | val fold : t -> 426 | 'r Rel_sql.Stmt.t -> ('r -> 'c -> 'c) -> 'c -> ('c, error) result 427 | (** [fold db st f acc] folds with [f] over the results of the {e 428 | single} statement [st]. [st] is compiled to a 429 | prepared statement which is cached. If [st] is made of more than 430 | one statement subsequent statements are ignored. *) 431 | 432 | val first : t -> 'r Rel_sql.Stmt.t -> ('r option, error) result 433 | (** [first db st] is the first row (if any) of the result of the {e 434 | single} statement [st]. Subsequent rows are discarded. [st] is 435 | compiled to a prepred statement which is cached. If [st] is made 436 | of more than one statement subsequent statements are ignored. *) 437 | 438 | val exec : t -> unit Rel_sql.Stmt.t -> (unit, error) result 439 | (** [exec db st] is like {!fold} but executes statement [sql] only for 440 | its side effect. *) 441 | 442 | type transaction_kind = [ `Deferred | `Immediate | `Exclusive ] 443 | (** The type for {{:https://www.sqlite.org/lang_transaction.html#deferred_immediate_and_exclusive_transactions} 444 | transaction kinds}. *) 445 | 446 | val with_transaction : 447 | transaction_kind -> t -> (t -> ('a, 'b) result) -> 448 | (('a, 'b) result, error) result 449 | (** [with_transaction kind db f] wraps the call to [f db] in an SQL 450 | transaction of given kind. If [f] raises, returns an error or if 451 | the commit fails (including if the error was {!Error.busy_timeout}, 452 | FIXME should we include a retry parameter ?) the transaction is rollback. 453 | 454 | {b Note.} Nested transactions are not supported so [f] should not call 455 | {!with_transaction} itself (use 456 | {{:https://www.sqlite.org/lang_savepoint.html}savepoints} if you 457 | need nested transactions). *) 458 | 459 | val explain : 460 | ?query_plan:bool -> t -> 'a Rel_sql.Stmt.t -> (string, error) result 461 | (** [explain ~query_plan db st] explains statement [st] or its query plan 462 | if [query_plan] is [true] (defaults to [false]. *) 463 | 464 | 465 | (** {1:low Low-level interface} *) 466 | 467 | 468 | (** Low-level prepared statement interface. *) 469 | module Stmt : sig 470 | 471 | type db = t 472 | (** See {!Rel_sqlite3.t}. *) 473 | 474 | type t 475 | (** The type for pepared statements. *) 476 | 477 | val create : db -> string -> (t, error) result 478 | (** [create db sql] is a statement for sql [sql] in database [db]. This 479 | statement is not part of the cache of [db] you have to 480 | {!finalize} it yourself. All statements should be finalized 481 | before you {!close} [d], otherwise [close d] will error on close. *) 482 | 483 | type 'r step 484 | (** The type for stepping through row results of type ['r]. *) 485 | 486 | val start : t -> 'r Rel_sql.Stmt.t -> ('r step, error) result 487 | (** [start s sb] starts the statement [s] as bound by [sb]. This 488 | {{:https://www.sqlite.org/c3ref/reset.html}resets} the prepared 489 | statement and binds the arguments of [sb]. *) 490 | 491 | val step : 'b step -> ('b option, error) result 492 | (** [step s] is the next result in [s], or [None] if the query has 493 | finished executing. *) 494 | 495 | val finalize : t -> (unit, error) result 496 | (** [inalize s] finalizes statement [st]. *) 497 | end 498 | 499 | (** Low-level backup interface. 500 | 501 | See the {{:https://sqlite.org/c3ref/backup_finish.html}SQLite 502 | backup API}. *) 503 | module Backup : sig 504 | 505 | type db := t 506 | 507 | type t 508 | (** The type for backups. . *) 509 | 510 | val init : 511 | dst:db -> ?dname:string -> src:db -> ?sname:string -> unit -> 512 | (t, error) result 513 | (** [init ~dst ~dname ~src ~sname] backups [sname] of [src] into 514 | [dname] of [dst]. Database names default to [main]. *) 515 | 516 | val finish : t -> (unit, error) result 517 | (** [finish b] finished backup [b]. *) 518 | 519 | val step : t -> ?n:int -> unit -> (bool, error) result 520 | (** [step b ~n ()] copies up to [n] pages. If [n] is unspecified all 521 | remaining pages are copied. Returns [Ok true] when there are no 522 | more pages to be copied. *) 523 | 524 | val remaining : t -> int 525 | (** [remaining b] is the number of pages remaining to be backed up. *) 526 | 527 | val pagecount : t -> int 528 | (** [pagecount b] is the total nubmer of pages to be backed up. *) 529 | end 530 | 531 | (** {1:sql SQL} *) 532 | 533 | module Dialect : Rel_sql.DIALECT 534 | (** [Dialect] implements the sqlite3 SQL dialect. *) 535 | 536 | val dialect : Rel_sql.dialect 537 | (** [dialect] is the sqlite3 dialect. *) 538 | 539 | (** {1:schema Schema} *) 540 | 541 | val schema_of_db : 542 | ?schema:Schema.name -> t -> (Schema.t * string list, error) result 543 | (** [schema_of_db db] derives a best-effort schema value for the 544 | live database [db]. Note that the tables and rows and internal 545 | structure is not functional. It is however sufficient for schema 546 | renderings and computing {{!Rel.Schema.val-changes}schema changes}. 547 | 548 | The returned list of strings is a list of issues to report to the 549 | end-user that indicate that the resulting schema may not 550 | faithfully represent [db]. If empty all is well. *) 551 | -------------------------------------------------------------------------------- /test/chinook.ml: -------------------------------------------------------------------------------- 1 | (* Generated by rel %VERSION% *) 2 | 3 | module Artist : sig 4 | type t 5 | 6 | val row : int -> string option -> t 7 | 8 | val artistId : t -> int 9 | val name : t -> string option 10 | 11 | (** {1:table Table} *) 12 | 13 | val artistId' : (t, int) Rel.Col.t 14 | val name' : (t, string option) Rel.Col.t 15 | 16 | val table : t Rel.Table.t 17 | end = struct 18 | type t = 19 | { artistId : int; 20 | name : string option; } 21 | 22 | let row artistId name = { artistId; name } 23 | 24 | let artistId t = t.artistId 25 | let name t = t.name 26 | 27 | open Rel 28 | 29 | let artistId' = Col.make "ArtistId" Type.int artistId 30 | let name' = Col.make "Name" Type.(option text) name 31 | 32 | let table = 33 | let primary_key = Table.Primary_key.make [Col.Def artistId'] in 34 | Table.make "Artist" ~primary_key @@ 35 | Row.(unit row * artistId' * name') 36 | end 37 | 38 | module Album : sig 39 | type t 40 | 41 | val row : int -> string -> int -> t 42 | 43 | val albumId : t -> int 44 | val title : t -> string 45 | val artistId : t -> int 46 | 47 | (** {1:table Table} *) 48 | 49 | val albumId' : (t, int) Rel.Col.t 50 | val title' : (t, string) Rel.Col.t 51 | val artistId' : (t, int) Rel.Col.t 52 | 53 | val table : t Rel.Table.t 54 | end = struct 55 | type t = 56 | { albumId : int; 57 | title : string; 58 | artistId : int; } 59 | 60 | let row albumId title artistId = { albumId; title; artistId } 61 | 62 | let albumId t = t.albumId 63 | let title t = t.title 64 | let artistId t = t.artistId 65 | 66 | open Rel 67 | 68 | let albumId' = Col.make "AlbumId" Type.int albumId 69 | let title' = Col.make "Title" Type.text title 70 | let artistId' = Col.make "ArtistId" Type.int artistId 71 | 72 | let table = 73 | let primary_key = Table.Primary_key.make [Col.Def albumId'] in 74 | let foreign_keys = 75 | [Table.Foreign_key.make ~cols:[Col.Def artistId'] 76 | ~parent:(Table (Artist.table, [Col.Def Artist.artistId'])) ()] in 77 | let indices = 78 | [Table.Index.make ~name:"IFK_AlbumArtistId" [Col.Def artistId']] in 79 | Table.make "Album" ~primary_key ~foreign_keys ~indices @@ 80 | Row.(unit row * albumId' * title' * artistId') 81 | end 82 | 83 | module Employee : sig 84 | type t 85 | 86 | val row : int -> string -> string -> string option -> int option -> 87 | float option -> float option -> string option -> string option -> 88 | string option -> string option -> string option -> 89 | string option -> string option -> string option -> t 90 | 91 | val employeeId : t -> int 92 | val lastName : t -> string 93 | val firstName : t -> string 94 | val title : t -> string option 95 | val reportsTo : t -> int option 96 | val birthDate : t -> float option 97 | val hireDate : t -> float option 98 | val address : t -> string option 99 | val city : t -> string option 100 | val state : t -> string option 101 | val country : t -> string option 102 | val postalCode : t -> string option 103 | val phone : t -> string option 104 | val fax : t -> string option 105 | val email : t -> string option 106 | 107 | (** {1:table Table} *) 108 | 109 | val employeeId' : (t, int) Rel.Col.t 110 | val lastName' : (t, string) Rel.Col.t 111 | val firstName' : (t, string) Rel.Col.t 112 | val title' : (t, string option) Rel.Col.t 113 | val reportsTo' : (t, int option) Rel.Col.t 114 | val birthDate' : (t, float option) Rel.Col.t 115 | val hireDate' : (t, float option) Rel.Col.t 116 | val address' : (t, string option) Rel.Col.t 117 | val city' : (t, string option) Rel.Col.t 118 | val state' : (t, string option) Rel.Col.t 119 | val country' : (t, string option) Rel.Col.t 120 | val postalCode' : (t, string option) Rel.Col.t 121 | val phone' : (t, string option) Rel.Col.t 122 | val fax' : (t, string option) Rel.Col.t 123 | val email' : (t, string option) Rel.Col.t 124 | 125 | val table : t Rel.Table.t 126 | end = struct 127 | type t = 128 | { employeeId : int; 129 | lastName : string; 130 | firstName : string; 131 | title : string option; 132 | reportsTo : int option; 133 | birthDate : float option; 134 | hireDate : float option; 135 | address : string option; 136 | city : string option; 137 | state : string option; 138 | country : string option; 139 | postalCode : string option; 140 | phone : string option; 141 | fax : string option; 142 | email : string option; } 143 | 144 | let row employeeId lastName firstName title reportsTo birthDate hireDate 145 | address city state country postalCode phone fax email = 146 | { employeeId; lastName; firstName; title; reportsTo; birthDate; hireDate; 147 | address; city; state; country; postalCode; phone; fax; email } 148 | 149 | let employeeId t = t.employeeId 150 | let lastName t = t.lastName 151 | let firstName t = t.firstName 152 | let title t = t.title 153 | let reportsTo t = t.reportsTo 154 | let birthDate t = t.birthDate 155 | let hireDate t = t.hireDate 156 | let address t = t.address 157 | let city t = t.city 158 | let state t = t.state 159 | let country t = t.country 160 | let postalCode t = t.postalCode 161 | let phone t = t.phone 162 | let fax t = t.fax 163 | let email t = t.email 164 | 165 | open Rel 166 | 167 | let employeeId' = Col.make "EmployeeId" Type.int employeeId 168 | let lastName' = Col.make "LastName" Type.text lastName 169 | let firstName' = Col.make "FirstName" Type.text firstName 170 | let title' = Col.make "Title" Type.(option text) title 171 | let reportsTo' = Col.make "ReportsTo" Type.(option int) reportsTo 172 | let birthDate' = Col.make "BirthDate" Type.(option float) birthDate 173 | let hireDate' = Col.make "HireDate" Type.(option float) hireDate 174 | let address' = Col.make "Address" Type.(option text) address 175 | let city' = Col.make "City" Type.(option text) city 176 | let state' = Col.make "State" Type.(option text) state 177 | let country' = Col.make "Country" Type.(option text) country 178 | let postalCode' = Col.make "PostalCode" Type.(option text) postalCode 179 | let phone' = Col.make "Phone" Type.(option text) phone 180 | let fax' = Col.make "Fax" Type.(option text) fax 181 | let email' = Col.make "Email" Type.(option text) email 182 | 183 | let table = 184 | let primary_key = Table.Primary_key.make [Col.Def employeeId'] in 185 | let foreign_keys = 186 | [Table.Foreign_key.make ~cols:[Col.Def reportsTo'] 187 | ~parent:(Self [Col.Def employeeId']) ()] in 188 | let indices = 189 | [Table.Index.make ~name:"IFK_EmployeeReportsTo" [Col.Def reportsTo']] in 190 | Table.make "Employee" ~primary_key ~foreign_keys ~indices @@ 191 | Row.(unit row * employeeId' * lastName' * firstName' * title' * 192 | reportsTo' * birthDate' * hireDate' * address' * city' * state' * 193 | country' * postalCode' * phone' * fax' * email') 194 | end 195 | 196 | module Customer : sig 197 | type t 198 | 199 | val row : int -> string -> string -> string option -> string option -> 200 | string option -> string option -> string option -> 201 | string option -> string option -> string option -> string -> 202 | int option -> t 203 | 204 | val customerId : t -> int 205 | val firstName : t -> string 206 | val lastName : t -> string 207 | val company : t -> string option 208 | val address : t -> string option 209 | val city : t -> string option 210 | val state : t -> string option 211 | val country : t -> string option 212 | val postalCode : t -> string option 213 | val phone : t -> string option 214 | val fax : t -> string option 215 | val email : t -> string 216 | val supportRepId : t -> int option 217 | 218 | (** {1:table Table} *) 219 | 220 | val customerId' : (t, int) Rel.Col.t 221 | val firstName' : (t, string) Rel.Col.t 222 | val lastName' : (t, string) Rel.Col.t 223 | val company' : (t, string option) Rel.Col.t 224 | val address' : (t, string option) Rel.Col.t 225 | val city' : (t, string option) Rel.Col.t 226 | val state' : (t, string option) Rel.Col.t 227 | val country' : (t, string option) Rel.Col.t 228 | val postalCode' : (t, string option) Rel.Col.t 229 | val phone' : (t, string option) Rel.Col.t 230 | val fax' : (t, string option) Rel.Col.t 231 | val email' : (t, string) Rel.Col.t 232 | val supportRepId' : (t, int option) Rel.Col.t 233 | 234 | val table : t Rel.Table.t 235 | end = struct 236 | type t = 237 | { customerId : int; 238 | firstName : string; 239 | lastName : string; 240 | company : string option; 241 | address : string option; 242 | city : string option; 243 | state : string option; 244 | country : string option; 245 | postalCode : string option; 246 | phone : string option; 247 | fax : string option; 248 | email : string; 249 | supportRepId : int option; } 250 | 251 | let row customerId firstName lastName company address city state country 252 | postalCode phone fax email supportRepId = 253 | { customerId; firstName; lastName; company; address; city; state; 254 | country; postalCode; phone; fax; email; supportRepId } 255 | 256 | let customerId t = t.customerId 257 | let firstName t = t.firstName 258 | let lastName t = t.lastName 259 | let company t = t.company 260 | let address t = t.address 261 | let city t = t.city 262 | let state t = t.state 263 | let country t = t.country 264 | let postalCode t = t.postalCode 265 | let phone t = t.phone 266 | let fax t = t.fax 267 | let email t = t.email 268 | let supportRepId t = t.supportRepId 269 | 270 | open Rel 271 | 272 | let customerId' = Col.make "CustomerId" Type.int customerId 273 | let firstName' = Col.make "FirstName" Type.text firstName 274 | let lastName' = Col.make "LastName" Type.text lastName 275 | let company' = Col.make "Company" Type.(option text) company 276 | let address' = Col.make "Address" Type.(option text) address 277 | let city' = Col.make "City" Type.(option text) city 278 | let state' = Col.make "State" Type.(option text) state 279 | let country' = Col.make "Country" Type.(option text) country 280 | let postalCode' = Col.make "PostalCode" Type.(option text) postalCode 281 | let phone' = Col.make "Phone" Type.(option text) phone 282 | let fax' = Col.make "Fax" Type.(option text) fax 283 | let email' = Col.make "Email" Type.text email 284 | let supportRepId' = Col.make "SupportRepId" Type.(option int) supportRepId 285 | 286 | let table = 287 | let primary_key = Table.Primary_key.make [Col.Def customerId'] in 288 | let foreign_keys = 289 | [Table.Foreign_key.make ~cols:[Col.Def supportRepId'] 290 | ~parent:(Table (Employee.table, [Col.Def Employee.employeeId'])) ()] in 291 | let indices = 292 | [Table.Index.make ~name:"IFK_CustomerSupportRepId" 293 | [Col.Def supportRepId']] in 294 | Table.make "Customer" ~primary_key ~foreign_keys ~indices @@ 295 | Row.(unit row * customerId' * firstName' * lastName' * company' * 296 | address' * city' * state' * country' * postalCode' * phone' * fax' * 297 | email' * supportRepId') 298 | end 299 | 300 | module Genre : sig 301 | type t 302 | 303 | val row : int -> string option -> t 304 | 305 | val genreId : t -> int 306 | val name : t -> string option 307 | 308 | (** {1:table Table} *) 309 | 310 | val genreId' : (t, int) Rel.Col.t 311 | val name' : (t, string option) Rel.Col.t 312 | 313 | val table : t Rel.Table.t 314 | end = struct 315 | type t = 316 | { genreId : int; 317 | name : string option; } 318 | 319 | let row genreId name = { genreId; name } 320 | 321 | let genreId t = t.genreId 322 | let name t = t.name 323 | 324 | open Rel 325 | 326 | let genreId' = Col.make "GenreId" Type.int genreId 327 | let name' = Col.make "Name" Type.(option text) name 328 | 329 | let table = 330 | let primary_key = Table.Primary_key.make [Col.Def genreId'] in 331 | Table.make "Genre" ~primary_key @@ 332 | Row.(unit row * genreId' * name') 333 | end 334 | 335 | module Invoice : sig 336 | type t 337 | 338 | val row : int -> int -> float -> string option -> string option -> 339 | string option -> string option -> string option -> float -> t 340 | 341 | val invoiceId : t -> int 342 | val customerId : t -> int 343 | val invoiceDate : t -> float 344 | val billingAddress : t -> string option 345 | val billingCity : t -> string option 346 | val billingState : t -> string option 347 | val billingCountry : t -> string option 348 | val billingPostalCode : t -> string option 349 | val total : t -> float 350 | 351 | (** {1:table Table} *) 352 | 353 | val invoiceId' : (t, int) Rel.Col.t 354 | val customerId' : (t, int) Rel.Col.t 355 | val invoiceDate' : (t, float) Rel.Col.t 356 | val billingAddress' : (t, string option) Rel.Col.t 357 | val billingCity' : (t, string option) Rel.Col.t 358 | val billingState' : (t, string option) Rel.Col.t 359 | val billingCountry' : (t, string option) Rel.Col.t 360 | val billingPostalCode' : (t, string option) Rel.Col.t 361 | val total' : (t, float) Rel.Col.t 362 | 363 | val table : t Rel.Table.t 364 | end = struct 365 | type t = 366 | { invoiceId : int; 367 | customerId : int; 368 | invoiceDate : float; 369 | billingAddress : string option; 370 | billingCity : string option; 371 | billingState : string option; 372 | billingCountry : string option; 373 | billingPostalCode : string option; 374 | total : float; } 375 | 376 | let row invoiceId customerId invoiceDate billingAddress billingCity 377 | billingState billingCountry billingPostalCode total = 378 | { invoiceId; customerId; invoiceDate; billingAddress; billingCity; 379 | billingState; billingCountry; billingPostalCode; total } 380 | 381 | let invoiceId t = t.invoiceId 382 | let customerId t = t.customerId 383 | let invoiceDate t = t.invoiceDate 384 | let billingAddress t = t.billingAddress 385 | let billingCity t = t.billingCity 386 | let billingState t = t.billingState 387 | let billingCountry t = t.billingCountry 388 | let billingPostalCode t = t.billingPostalCode 389 | let total t = t.total 390 | 391 | open Rel 392 | 393 | let invoiceId' = Col.make "InvoiceId" Type.int invoiceId 394 | let customerId' = Col.make "CustomerId" Type.int customerId 395 | let invoiceDate' = Col.make "InvoiceDate" Type.float invoiceDate 396 | let billingAddress' = 397 | Col.make "BillingAddress" Type.(option text) billingAddress 398 | let billingCity' = Col.make "BillingCity" Type.(option text) billingCity 399 | let billingState' = Col.make "BillingState" Type.(option text) billingState 400 | let billingCountry' = 401 | Col.make "BillingCountry" Type.(option text) billingCountry 402 | let billingPostalCode' = 403 | Col.make "BillingPostalCode" Type.(option text) billingPostalCode 404 | let total' = Col.make "Total" Type.float total 405 | 406 | let table = 407 | let primary_key = Table.Primary_key.make [Col.Def invoiceId'] in 408 | let foreign_keys = 409 | [Table.Foreign_key.make ~cols:[Col.Def customerId'] 410 | ~parent:(Table (Customer.table, [Col.Def Customer.customerId'])) ()] in 411 | let indices = 412 | [Table.Index.make ~name:"IFK_InvoiceCustomerId" [Col.Def customerId']] in 413 | Table.make "Invoice" ~primary_key ~foreign_keys ~indices @@ 414 | Row.(unit row * invoiceId' * customerId' * invoiceDate' * 415 | billingAddress' * billingCity' * billingState' * billingCountry' * 416 | billingPostalCode' * total') 417 | end 418 | 419 | module MediaType : sig 420 | type t 421 | 422 | val row : int -> string option -> t 423 | 424 | val mediaTypeId : t -> int 425 | val name : t -> string option 426 | 427 | (** {1:table Table} *) 428 | 429 | val mediaTypeId' : (t, int) Rel.Col.t 430 | val name' : (t, string option) Rel.Col.t 431 | 432 | val table : t Rel.Table.t 433 | end = struct 434 | type t = 435 | { mediaTypeId : int; 436 | name : string option; } 437 | 438 | let row mediaTypeId name = { mediaTypeId; name } 439 | 440 | let mediaTypeId t = t.mediaTypeId 441 | let name t = t.name 442 | 443 | open Rel 444 | 445 | let mediaTypeId' = Col.make "MediaTypeId" Type.int mediaTypeId 446 | let name' = Col.make "Name" Type.(option text) name 447 | 448 | let table = 449 | let primary_key = Table.Primary_key.make [Col.Def mediaTypeId'] in 450 | Table.make "MediaType" ~primary_key @@ 451 | Row.(unit row * mediaTypeId' * name') 452 | end 453 | 454 | module Track : sig 455 | type t 456 | 457 | val row : int -> string -> int option -> int -> int option -> 458 | string option -> int -> int option -> float -> t 459 | 460 | val trackId : t -> int 461 | val name : t -> string 462 | val albumId : t -> int option 463 | val mediaTypeId : t -> int 464 | val genreId : t -> int option 465 | val composer : t -> string option 466 | val milliseconds : t -> int 467 | val bytes : t -> int option 468 | val unitPrice : t -> float 469 | 470 | (** {1:table Table} *) 471 | 472 | val trackId' : (t, int) Rel.Col.t 473 | val name' : (t, string) Rel.Col.t 474 | val albumId' : (t, int option) Rel.Col.t 475 | val mediaTypeId' : (t, int) Rel.Col.t 476 | val genreId' : (t, int option) Rel.Col.t 477 | val composer' : (t, string option) Rel.Col.t 478 | val milliseconds' : (t, int) Rel.Col.t 479 | val bytes' : (t, int option) Rel.Col.t 480 | val unitPrice' : (t, float) Rel.Col.t 481 | 482 | val table : t Rel.Table.t 483 | end = struct 484 | type t = 485 | { trackId : int; 486 | name : string; 487 | albumId : int option; 488 | mediaTypeId : int; 489 | genreId : int option; 490 | composer : string option; 491 | milliseconds : int; 492 | bytes : int option; 493 | unitPrice : float; } 494 | 495 | let row trackId name albumId mediaTypeId genreId composer milliseconds 496 | bytes unitPrice = 497 | { trackId; name; albumId; mediaTypeId; genreId; composer; milliseconds; 498 | bytes; unitPrice } 499 | 500 | let trackId t = t.trackId 501 | let name t = t.name 502 | let albumId t = t.albumId 503 | let mediaTypeId t = t.mediaTypeId 504 | let genreId t = t.genreId 505 | let composer t = t.composer 506 | let milliseconds t = t.milliseconds 507 | let bytes t = t.bytes 508 | let unitPrice t = t.unitPrice 509 | 510 | open Rel 511 | 512 | let trackId' = Col.make "TrackId" Type.int trackId 513 | let name' = Col.make "Name" Type.text name 514 | let albumId' = Col.make "AlbumId" Type.(option int) albumId 515 | let mediaTypeId' = Col.make "MediaTypeId" Type.int mediaTypeId 516 | let genreId' = Col.make "GenreId" Type.(option int) genreId 517 | let composer' = Col.make "Composer" Type.(option text) composer 518 | let milliseconds' = Col.make "Milliseconds" Type.int milliseconds 519 | let bytes' = Col.make "Bytes" Type.(option int) bytes 520 | let unitPrice' = Col.make "UnitPrice" Type.float unitPrice 521 | 522 | let table = 523 | let primary_key = Table.Primary_key.make [Col.Def trackId'] in 524 | let foreign_keys = 525 | [Table.Foreign_key.make ~cols:[Col.Def albumId'] 526 | ~parent:(Table (Album.table, [Col.Def Album.albumId'])) (); 527 | Table.Foreign_key.make ~cols:[Col.Def genreId'] 528 | ~parent:(Table (Genre.table, [Col.Def Genre.genreId'])) (); 529 | Table.Foreign_key.make ~cols:[Col.Def mediaTypeId'] 530 | ~parent:(Table (MediaType.table, [Col.Def MediaType.mediaTypeId'])) ()] in 531 | let indices = 532 | [Table.Index.make ~name:"IFK_TrackAlbumId" [Col.Def albumId']; 533 | Table.Index.make ~name:"IFK_TrackGenreId" [Col.Def genreId']; 534 | Table.Index.make ~name:"IFK_TrackMediaTypeId" [Col.Def mediaTypeId']] in 535 | Table.make "Track" ~primary_key ~foreign_keys ~indices @@ 536 | Row.(unit row * trackId' * name' * albumId' * mediaTypeId' * genreId' * 537 | composer' * milliseconds' * bytes' * unitPrice') 538 | end 539 | 540 | module InvoiceLine : sig 541 | type t 542 | 543 | val row : int -> int -> int -> float -> int -> t 544 | 545 | val invoiceLineId : t -> int 546 | val invoiceId : t -> int 547 | val trackId : t -> int 548 | val unitPrice : t -> float 549 | val quantity : t -> int 550 | 551 | (** {1:table Table} *) 552 | 553 | val invoiceLineId' : (t, int) Rel.Col.t 554 | val invoiceId' : (t, int) Rel.Col.t 555 | val trackId' : (t, int) Rel.Col.t 556 | val unitPrice' : (t, float) Rel.Col.t 557 | val quantity' : (t, int) Rel.Col.t 558 | 559 | val table : t Rel.Table.t 560 | end = struct 561 | type t = 562 | { invoiceLineId : int; 563 | invoiceId : int; 564 | trackId : int; 565 | unitPrice : float; 566 | quantity : int; } 567 | 568 | let row invoiceLineId invoiceId trackId unitPrice quantity = 569 | { invoiceLineId; invoiceId; trackId; unitPrice; quantity } 570 | 571 | let invoiceLineId t = t.invoiceLineId 572 | let invoiceId t = t.invoiceId 573 | let trackId t = t.trackId 574 | let unitPrice t = t.unitPrice 575 | let quantity t = t.quantity 576 | 577 | open Rel 578 | 579 | let invoiceLineId' = Col.make "InvoiceLineId" Type.int invoiceLineId 580 | let invoiceId' = Col.make "InvoiceId" Type.int invoiceId 581 | let trackId' = Col.make "TrackId" Type.int trackId 582 | let unitPrice' = Col.make "UnitPrice" Type.float unitPrice 583 | let quantity' = Col.make "Quantity" Type.int quantity 584 | 585 | let table = 586 | let primary_key = Table.Primary_key.make [Col.Def invoiceLineId'] in 587 | let foreign_keys = 588 | [Table.Foreign_key.make ~cols:[Col.Def invoiceId'] 589 | ~parent:(Table (Invoice.table, [Col.Def Invoice.invoiceId'])) (); 590 | Table.Foreign_key.make ~cols:[Col.Def trackId'] 591 | ~parent:(Table (Track.table, [Col.Def Track.trackId'])) ()] in 592 | let indices = 593 | [Table.Index.make ~name:"IFK_InvoiceLineInvoiceId" [Col.Def invoiceId']; 594 | Table.Index.make ~name:"IFK_InvoiceLineTrackId" [Col.Def trackId']] in 595 | Table.make "InvoiceLine" ~primary_key ~foreign_keys ~indices @@ 596 | Row.(unit row * invoiceLineId' * invoiceId' * trackId' * unitPrice' * 597 | quantity') 598 | end 599 | 600 | module Playlist : sig 601 | type t 602 | 603 | val row : int -> string option -> t 604 | 605 | val playlistId : t -> int 606 | val name : t -> string option 607 | 608 | (** {1:table Table} *) 609 | 610 | val playlistId' : (t, int) Rel.Col.t 611 | val name' : (t, string option) Rel.Col.t 612 | 613 | val table : t Rel.Table.t 614 | end = struct 615 | type t = 616 | { playlistId : int; 617 | name : string option; } 618 | 619 | let row playlistId name = { playlistId; name } 620 | 621 | let playlistId t = t.playlistId 622 | let name t = t.name 623 | 624 | open Rel 625 | 626 | let playlistId' = Col.make "PlaylistId" Type.int playlistId 627 | let name' = Col.make "Name" Type.(option text) name 628 | 629 | let table = 630 | let primary_key = Table.Primary_key.make [Col.Def playlistId'] in 631 | Table.make "Playlist" ~primary_key @@ 632 | Row.(unit row * playlistId' * name') 633 | end 634 | 635 | module PlaylistTrack : sig 636 | type t 637 | 638 | val row : int -> int -> t 639 | 640 | val playlistId : t -> int 641 | val trackId : t -> int 642 | 643 | (** {1:table Table} *) 644 | 645 | val playlistId' : (t, int) Rel.Col.t 646 | val trackId' : (t, int) Rel.Col.t 647 | 648 | val table : t Rel.Table.t 649 | end = struct 650 | type t = 651 | { playlistId : int; 652 | trackId : int; } 653 | 654 | let row playlistId trackId = { playlistId; trackId } 655 | 656 | let playlistId t = t.playlistId 657 | let trackId t = t.trackId 658 | 659 | open Rel 660 | 661 | let playlistId' = Col.make "PlaylistId" Type.int playlistId 662 | let trackId' = Col.make "TrackId" Type.int trackId 663 | 664 | let table = 665 | let primary_key = 666 | Table.Primary_key.make [Col.Def playlistId'; Col.Def trackId'] in 667 | let foreign_keys = 668 | [Table.Foreign_key.make ~cols:[Col.Def playlistId'] 669 | ~parent:(Table (Playlist.table, [Col.Def Playlist.playlistId'])) (); 670 | Table.Foreign_key.make ~cols:[Col.Def trackId'] 671 | ~parent:(Table (Track.table, [Col.Def Track.trackId'])) ()] in 672 | let indices = 673 | [Table.Index.make ~name:"IFK_PlaylistTrackTrackId" [Col.Def trackId']] in 674 | Table.make "PlaylistTrack" ~primary_key ~foreign_keys ~indices @@ 675 | Row.(unit row * playlistId' * trackId') 676 | end 677 | 678 | module Schema : sig 679 | val v : Rel.Schema.t 680 | end = struct 681 | let tables = 682 | [ Rel.Table.Def Artist.table; 683 | Rel.Table.Def Album.table; 684 | Rel.Table.Def Employee.table; 685 | Rel.Table.Def Customer.table; 686 | Rel.Table.Def Genre.table; 687 | Rel.Table.Def Invoice.table; 688 | Rel.Table.Def MediaType.table; 689 | Rel.Table.Def Track.table; 690 | Rel.Table.Def InvoiceLine.table; 691 | Rel.Table.Def Playlist.table; 692 | Rel.Table.Def PlaylistTrack.table; ] 693 | 694 | let v = Rel.Schema.make ~tables () 695 | end 696 | --------------------------------------------------------------------------------