From e4f3453e14338c7c899467a89f472f7e600dc3be Mon Sep 17 00:00:00 2001 From: James Cheney Date: Sun, 14 Jun 2020 17:04:13 +0100 Subject: [PATCH 01/28] progress on resurrecting mysql driver: eveything compiles but dynamic loading fails --- Makefile | 2 +- database/mysql-driver/{jbuild.unsupported => dune} | 13 +++++-------- database/mysql-driver/mysql_database.ml | 4 +++- links-mysql.opam.unsupported => links-mysql.opam | 2 +- 4 files changed, 10 insertions(+), 11 deletions(-) rename database/mysql-driver/{jbuild.unsupported => dune} (51%) rename links-mysql.opam.unsupported => links-mysql.opam (91%) diff --git a/Makefile b/Makefile index b567e8f31..c3786bc8a 100644 --- a/Makefile +++ b/Makefile @@ -45,7 +45,7 @@ BUILD_DIR:=$(ROOT)/_build # The build command and some standard build system flags BUILD=dune build SOURCES=links -DB_SOURCES=links-postgresql,links-sqlite3 +DB_SOURCES=links-postgresql,links-sqlite3,links-mysql # Note: this relies on lazy expansion of `SOURCES'. COMMON_FLAGS=--only-packages $(SOURCES) --build-dir=$(BUILD_DIR) DEV_FLAGS=$(COMMON_FLAGS) --profile=dev diff --git a/database/mysql-driver/jbuild.unsupported b/database/mysql-driver/dune similarity index 51% rename from database/mysql-driver/jbuild.unsupported rename to database/mysql-driver/dune index e07ad42c8..c5a4ed036 100644 --- a/database/mysql-driver/jbuild.unsupported +++ b/database/mysql-driver/dune @@ -1,16 +1,13 @@ -(jbuild_version 1) - (library - ((name links_mysql) + (name links_mysql) (public_name links-mysql) (synopsis "MySQL database backend for Links") - (wrapped false) (optional) (flags (:standard -safe-string -dtypes -w Ae-44-45-60 -g -cclib -lunix -thread)) - (libraries (mysql links)))) + (libraries mysql links.core)) (install - ((section share) - (files (links_mysql_dependencies.json)) - (package links-mysql))) + (section share) + (files links_mysql_dependencies.json) + (package links-mysql)) diff --git a/database/mysql-driver/mysql_database.ml b/database/mysql-driver/mysql_database.ml index 1cd244aea..8cc3c312a 100644 --- a/database/mysql-driver/mysql_database.ml +++ b/database/mysql-driver/mysql_database.ml @@ -1,4 +1,6 @@ open Mysql +open Links_core +open Utility let string_of_error_code = function | Aborting_connection -> "Aborting connection" @@ -259,7 +261,7 @@ class mysql_database spec = object(self) method! make_insert_returning_query : string -> Sql.query -> string list = fun _returning q -> assert (match q with | Sql.Insert _ -> true | _ -> false); - [self#string_of_query None q; "select last_insert_id()"] + [self#string_of_query q; "select last_insert_id()"] method supports_shredding () = false end diff --git a/links-mysql.opam.unsupported b/links-mysql.opam similarity index 91% rename from links-mysql.opam.unsupported rename to links-mysql.opam index f4652e554..58f7fd9a2 100644 --- a/links-mysql.opam.unsupported +++ b/links-mysql.opam @@ -1,5 +1,5 @@ opam-version: "2.0" -maintainer: "Jan Stolarek " +maintainer: "James Cheney " authors: "The Links Team " synopsis: "MySQL database driver for the Links Programming Language" description: "MySQL database driver for the Links Programming Language" From 3f073864a55559eeae3bab1c17fa3c3acac68f99 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 15 Jun 2020 10:50:18 +0100 Subject: [PATCH 02/28] reorganize factorials example to workaroune mysql-dependent behavior add -linkall flag which makes mysql plugin happy again --- bin/links.ml | 1 - core/value.ml | 2 -- dune | 1 + tests/database/factorials.links | 17 +++++++++-------- 4 files changed, 10 insertions(+), 11 deletions(-) diff --git a/bin/links.ml b/bin/links.ml index f69f4cb7f..2c929b572 100644 --- a/bin/links.ml +++ b/bin/links.ml @@ -115,4 +115,3 @@ let _ = | None -> () end; main() - diff --git a/core/value.ml b/core/value.ml index 16e0c0032..b1dd83a04 100644 --- a/core/value.ml +++ b/core/value.ml @@ -1106,5 +1106,3 @@ let row_columns_values v = | v -> raise (type_error ~action:"form query row from" "list" v) in (row_columns v, row_values v) - - diff --git a/dune b/dune index 1489f75aa..a8c13a96b 100644 --- a/dune +++ b/dune @@ -8,6 +8,7 @@ -warn-error -a ;; Do not treat warnings as errors. -w A-4-44-45-48-60-67 ;; Ignores warnings 4, 44, 45, 48, 60, and 67. -g ;; Adds debugging information to the resulting executable / library. + -linkall ))) (release (flags (:standard diff --git a/tests/database/factorials.links b/tests/database/factorials.links index a9e30bbf3..4ab430aca 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -56,6 +56,15 @@ fun unwrappedLookup(n) server { } fun test() { + deleteAll(); + assertEq(lookupFactorials(10), []); + assertEq(insertReturningOne(), 1); + assertEq(lookupFactorials(10), [(f=1,i=1)]); + assertEq(insertReturningTwo(), 2); + assertEq(lookupFactorials(10), [(f=2,i=2),(f=1,i=1)]); + updateTwoThree(); + assertEq(lookupFactorials(10), [(f=3,i=2),(f=1,i=1)]); + deleteAll(); insertOne(); deleteAll(); assertEq(lookupFactorials(10), []); @@ -67,14 +76,6 @@ fun test() { insertTwoThree(); ## The order is wrong. assertEq(lookupFactorials(3), [(i=3, f=6), (i=2, f=2), (f=1,i=1)]); - deleteAll(); - assertEq(lookupFactorials(10), []); - assertEq(insertReturningOne(), 1); - assertEq(lookupFactorials(10), [(f=1,i=1)]); - assertEq(insertReturningTwo(), 2); - assertEq(lookupFactorials(10), [(f=2,i=2),(f=1,i=1)]); - updateTwoThree(); - assertEq(lookupFactorials(10), [(f=3,i=2),(f=1,i=1)]); } test() From e0a8da545ed365c5c797eda19e2bce63bb8527e4 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 15 Jun 2020 10:59:20 +0100 Subject: [PATCH 03/28] whitespace --- bin/links.ml | 1 + core/value.ml | 2 ++ 2 files changed, 3 insertions(+) diff --git a/bin/links.ml b/bin/links.ml index 2c929b572..f69f4cb7f 100644 --- a/bin/links.ml +++ b/bin/links.ml @@ -115,3 +115,4 @@ let _ = | None -> () end; main() + diff --git a/core/value.ml b/core/value.ml index b1dd83a04..16e0c0032 100644 --- a/core/value.ml +++ b/core/value.ml @@ -1106,3 +1106,5 @@ let row_columns_values v = | v -> raise (type_error ~action:"form query row from" "list" v) in (row_columns v, row_values v) + + From 9c239a2914cc14727cf8a06fd41f7c1f5955bba5 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 11:57:13 +0100 Subject: [PATCH 04/28] make the database tests deterministic --- tests/database/xpath-reduced.links | 4 +++- tests/database/xpath.links | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/database/xpath-reduced.links b/tests/database/xpath-reduced.links index 078389543..a3e54e891 100644 --- a/tests/database/xpath-reduced.links +++ b/tests/database/xpath-reduced.links @@ -21,6 +21,7 @@ fun xpath1() { where ( empty(for (t <-- xml) where (x.id == t.parent) [()])) + orderby (x.name) [(name=x.name)] } } @@ -34,12 +35,13 @@ fun xpath2() { query { for (x <-- xml) where ( p(x)) + orderby (x.name) [(name=x.name)] } } fun test() { - assertEq(xpath1(), [(name="f"), (name="e"), (name="c")]); + assertEq(xpath1(), [(name="c"), (name="e"), (name="f")]); assertEq(xpath1(), xpath2()); } diff --git a/tests/database/xpath.links b/tests/database/xpath.links index 12e7897e6..115ca8aea 100644 --- a/tests/database/xpath.links +++ b/tests/database/xpath.links @@ -91,12 +91,13 @@ fun xpath(p) { for (root <-- xml, s <-- xml) where (root.parent == -1 && p(root, s)) + orderby (s.name) [(name=s.name)] } } fun test() { - assertEq(xpath(xp0), [(name="d"), (name="b")]); + assertEq(xpath(xp0), [(name="b"), (name="d")]); } test() From 9f449033b96c0072da7c7bcb8cfc727742342d4f Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 13:57:18 +0100 Subject: [PATCH 05/28] fix inconsistent ordering behavior - still somewhat fragile --- core/value.ml | 6 ++---- database/mysql-driver/mysql_database.ml | 3 ++- database/pg-driver/pg_database.ml | 6 ++++-- database/sqlite3-driver/lite3_database.ml | 8 +++++--- 4 files changed, 13 insertions(+), 10 deletions(-) diff --git a/core/value.ml b/core/value.ml index 16e0c0032..66536c186 100644 --- a/core/value.ml +++ b/core/value.ml @@ -45,7 +45,7 @@ class virtual dbvalue = object (self) do_map (n+1) (f (self#getvalue n)::acc) ) else acc - in do_map 0 [] + in List.rev (do_map 0 []) method map_array : 'a. (string array -> 'a) -> 'a list = fun f -> let max = self#ntuples in let rec do_map n acc = @@ -54,7 +54,7 @@ class virtual dbvalue = object (self) do_map (n+1) (f (self#gettuple n)::acc) ) else acc - in do_map 0 [] + in List.rev (do_map 0 []) method fold_array : 'a. (string array -> 'a -> 'a) -> 'a -> 'a = fun f x -> let max = self#ntuples in let rec do_fold n acc = @@ -1106,5 +1106,3 @@ let row_columns_values v = | v -> raise (type_error ~action:"form query row from" "list" v) in (row_columns v, row_values v) - - diff --git a/database/mysql-driver/mysql_database.ml b/database/mysql-driver/mysql_database.ml index 8cc3c312a..ab6592939 100644 --- a/database/mysql-driver/mysql_database.ml +++ b/database/mysql-driver/mysql_database.ml @@ -236,7 +236,8 @@ class mysql_result (result : result) db = object | Some r -> r method getvalue : int -> int -> string = fun n f -> to_row result (Int64.of_int n); - Utility.val_of ((Utility.val_of (fetch result)).(f)) + let str = Utility.val_of ((Utility.val_of (fetch result)).(f)) in + print_string(str); str method gettuple : int -> string array = fun n -> to_row result (Int64.of_int n); Array.map Utility.val_of (Utility.val_of(fetch result)) diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index 509897116..dc0437c02 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -92,7 +92,10 @@ class pg_dbresult (pgresult:Postgresql.result) = object method ntuples : int = original#ntuples method fname : int -> string = original#fname method get_all_lst : string list list = pgresult#get_all_lst - method getvalue : int -> int -> string = pgresult#getvalue + method getvalue : int -> int -> string = + fun n i -> + let str = pgresult#getvalue n i in + print_string(str); str method gettuple : int -> string array = pgresult#get_tuple method error : string = original#error end @@ -188,4 +191,3 @@ let get_pg_database_by_string args = failwith "Insufficient arguments when establishing postgresql connection" let _ = Value.register_driver (driver_name, get_pg_database_by_string) - diff --git a/database/sqlite3-driver/lite3_database.ml b/database/sqlite3-driver/lite3_database.ml index 7fa88c0db..fb4e379e8 100644 --- a/database/sqlite3-driver/lite3_database.ml +++ b/database/sqlite3-driver/lite3_database.ml @@ -59,10 +59,11 @@ class lite3_result (stmt: stmt) = object | Rc.DONE -> results,`QueryOk | e -> results, `QueryError (error_as_string e) - ) + ) | _ -> (results,status) in - get_results ([],`QueryOk) + let results,status = get_results ([],`QueryOk) in + (List.rev results, status) method status : Value.db_status = snd(result_list_and_status) method nfields : int = column_count stmt @@ -70,7 +71,8 @@ class lite3_result (stmt: stmt) = object method fname n : string = column_name stmt n method get_all_lst : string list list = fst(result_list_and_status) method getvalue : int -> int -> string = fun n i -> - List.nth(List.nth (fst(result_list_and_status)) n) i + let str = List.nth(List.nth (fst(result_list_and_status)) n) i in + print_string(str); str method gettuple : int -> string array = fun n -> Array.of_list(List.nth (fst(result_list_and_status)) n) method error : string = From 3a572cebaab7ad39768be56c86464b8c335c931f Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 14:04:50 +0100 Subject: [PATCH 06/28] add configs for other drivers cleanup fix of ordering --- database/mysql-driver/mysql_database.ml | 3 +-- database/pg-driver/pg_database.ml | 4 +--- database/sqlite3-driver/lite3_database.ml | 3 +-- tests/database/config.mysql | 3 +++ tests/database/config.pgsql | 2 ++ tests/database/config.sample | 1 - tests/database/config.sqlite3 | 2 ++ tests/database/factorials.links | 6 +++--- 8 files changed, 13 insertions(+), 11 deletions(-) create mode 100644 tests/database/config.mysql create mode 100644 tests/database/config.pgsql create mode 100644 tests/database/config.sqlite3 diff --git a/database/mysql-driver/mysql_database.ml b/database/mysql-driver/mysql_database.ml index ab6592939..8cc3c312a 100644 --- a/database/mysql-driver/mysql_database.ml +++ b/database/mysql-driver/mysql_database.ml @@ -236,8 +236,7 @@ class mysql_result (result : result) db = object | Some r -> r method getvalue : int -> int -> string = fun n f -> to_row result (Int64.of_int n); - let str = Utility.val_of ((Utility.val_of (fetch result)).(f)) in - print_string(str); str + Utility.val_of ((Utility.val_of (fetch result)).(f)) method gettuple : int -> string array = fun n -> to_row result (Int64.of_int n); Array.map Utility.val_of (Utility.val_of(fetch result)) diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index dc0437c02..55fab2bd0 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -93,9 +93,7 @@ class pg_dbresult (pgresult:Postgresql.result) = object method fname : int -> string = original#fname method get_all_lst : string list list = pgresult#get_all_lst method getvalue : int -> int -> string = - fun n i -> - let str = pgresult#getvalue n i in - print_string(str); str + pgresult#getvalue method gettuple : int -> string array = pgresult#get_tuple method error : string = original#error end diff --git a/database/sqlite3-driver/lite3_database.ml b/database/sqlite3-driver/lite3_database.ml index fb4e379e8..f990b8935 100644 --- a/database/sqlite3-driver/lite3_database.ml +++ b/database/sqlite3-driver/lite3_database.ml @@ -71,8 +71,7 @@ class lite3_result (stmt: stmt) = object method fname n : string = column_name stmt n method get_all_lst : string list list = fst(result_list_and_status) method getvalue : int -> int -> string = fun n i -> - let str = List.nth(List.nth (fst(result_list_and_status)) n) i in - print_string(str); str + List.nth(List.nth (fst(result_list_and_status)) n) i method gettuple : int -> string array = fun n -> Array.of_list(List.nth (fst(result_list_and_status)) n) method error : string = diff --git a/tests/database/config.mysql b/tests/database/config.mysql new file mode 100644 index 000000000..eddbd91bb --- /dev/null +++ b/tests/database/config.mysql @@ -0,0 +1,3 @@ +database_driver=mysql +database_args=localhost:3306:links:12345 + diff --git a/tests/database/config.pgsql b/tests/database/config.pgsql new file mode 100644 index 000000000..a8ed03b44 --- /dev/null +++ b/tests/database/config.pgsql @@ -0,0 +1,2 @@ +database_driver=postgresql +database_args=localhost:5432::links diff --git a/tests/database/config.sample b/tests/database/config.sample index e987677ce..a8ed03b44 100644 --- a/tests/database/config.sample +++ b/tests/database/config.sample @@ -1,3 +1,2 @@ database_driver=postgresql database_args=localhost:5432::links -show_pre_sugar_typing=off diff --git a/tests/database/config.sqlite3 b/tests/database/config.sqlite3 new file mode 100644 index 000000000..7691e5768 --- /dev/null +++ b/tests/database/config.sqlite3 @@ -0,0 +1,2 @@ +database_driver=sqlite3 + diff --git a/tests/database/factorials.links b/tests/database/factorials.links index 4ab430aca..85216c47a 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -61,9 +61,9 @@ fun test() { assertEq(insertReturningOne(), 1); assertEq(lookupFactorials(10), [(f=1,i=1)]); assertEq(insertReturningTwo(), 2); - assertEq(lookupFactorials(10), [(f=2,i=2),(f=1,i=1)]); + assertEq(lookupFactorials(10), [(f=1,i=1),(f=2,i=2)]); updateTwoThree(); - assertEq(lookupFactorials(10), [(f=3,i=2),(f=1,i=1)]); + assertEq(lookupFactorials(10), [(f=1,i=1),(f=3,i=2)]); deleteAll(); insertOne(); deleteAll(); @@ -75,7 +75,7 @@ fun test() { assertEq(unwrappedLookup(1), [(f=1,i=1)]); insertTwoThree(); ## The order is wrong. - assertEq(lookupFactorials(3), [(i=3, f=6), (i=2, f=2), (f=1,i=1)]); + assertEq(lookupFactorials(3), [(i=1, f=1), (i=2, f=2), (f=6,i=3)]); } test() From f15182b0834f2ac34f7e6ddb6c56ad06d333278f Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 14:51:54 +0100 Subject: [PATCH 07/28] implement insert returning correctly for mysql, sqlite3 --- database/mysql-driver/mysql_database.ml | 9 ++++++--- database/pg-driver/pg_database.ml | 4 ++-- database/sqlite3-driver/lite3_database.ml | 10 +++++++++- 3 files changed, 17 insertions(+), 6 deletions(-) diff --git a/database/mysql-driver/mysql_database.ml b/database/mysql-driver/mysql_database.ml index 8cc3c312a..b1c18a0a5 100644 --- a/database/mysql-driver/mysql_database.ml +++ b/database/mysql-driver/mysql_database.ml @@ -259,9 +259,12 @@ class mysql_database spec = object(self) "`" ^ Str.global_replace (Str.regexp "`") "``" f ^ "`" method! make_insert_returning_query : string -> Sql.query -> string list = - fun _returning q -> - assert (match q with | Sql.Insert _ -> true | _ -> false); - [self#string_of_query q; "select last_insert_id()"] + fun returning q -> + match q with + Sql.Insert ins -> + [self#string_of_query q; + Printf.sprintf "select %s from %s where _rowid = last_insert_id()" returning ins.ins_table] + | _ -> assert false method supports_shredding () = false end diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index 55fab2bd0..509897116 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -92,8 +92,7 @@ class pg_dbresult (pgresult:Postgresql.result) = object method ntuples : int = original#ntuples method fname : int -> string = original#fname method get_all_lst : string list list = pgresult#get_all_lst - method getvalue : int -> int -> string = - pgresult#getvalue + method getvalue : int -> int -> string = pgresult#getvalue method gettuple : int -> string array = pgresult#get_tuple method error : string = original#error end @@ -189,3 +188,4 @@ let get_pg_database_by_string args = failwith "Insufficient arguments when establishing postgresql connection" let _ = Value.register_driver (driver_name, get_pg_database_by_string) + diff --git a/database/sqlite3-driver/lite3_database.ml b/database/sqlite3-driver/lite3_database.ml index f990b8935..dec5fc15f 100644 --- a/database/sqlite3-driver/lite3_database.ml +++ b/database/sqlite3-driver/lite3_database.ml @@ -59,7 +59,7 @@ class lite3_result (stmt: stmt) = object | Rc.DONE -> results,`QueryOk | e -> results, `QueryError (error_as_string e) - ) + ) | _ -> (results,status) in let results,status = get_results ([],`QueryOk) in @@ -116,6 +116,14 @@ class lite3_database file = object(self) | _ -> _supports_shredding <- Some false; false end | _ -> false + method! make_insert_returning_query : string -> Sql.query -> string list = + fun returning q -> + match q with + Sql.Insert ins -> + [self#string_of_query q; + Printf.sprintf "select %s from %s where rowid = last_insert_rowid()" returning ins.ins_table] + | _ -> assert false + end let driver_name = "sqlite3" From d31c20a66e718b73022e35a051845c3d2cc8f212 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 14:57:48 +0100 Subject: [PATCH 08/28] test insert returning when returning any field --- tests/database/factorials.links | 2 +- tests/database/factorials.mysql | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) create mode 100644 tests/database/factorials.mysql diff --git a/tests/database/factorials.links b/tests/database/factorials.links index 85216c47a..c23557241 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -30,7 +30,7 @@ fun insertReturningOne() { fun insertReturningTwo() { insert factorials - values (f,i) [(f=2, i=2)] returning i + values (f,i) [(f=2, i=2)] returning f } fun updateTwoThree() { diff --git a/tests/database/factorials.mysql b/tests/database/factorials.mysql new file mode 100644 index 000000000..2ce8de83c --- /dev/null +++ b/tests/database/factorials.mysql @@ -0,0 +1,7 @@ +DROP TABLE IF EXISTS factorials; + +CREATE TABLE factorials ( + rowid integer PRIMARY KEY AUTO_INCREMENT, + i integer, + f bigint +); From 5d1ae2477de0beeb4f3151f82bfe40eaf62d5638 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 15:42:10 +0100 Subject: [PATCH 09/28] fix relational lens tests --- tests/relational-lenses/01_cds.links | 23 ++++++++++----------- tests/relational-lenses/02_cds.links | 22 ++++++++++---------- tests/relational-lenses/03_cds.links | 31 ++++++++++++++-------------- 3 files changed, 37 insertions(+), 39 deletions(-) diff --git a/tests/relational-lenses/01_cds.links b/tests/relational-lenses/01_cds.links index 55f93ab2c..8eeec561d 100644 --- a/tests/relational-lenses/01_cds.links +++ b/tests/relational-lenses/01_cds.links @@ -25,15 +25,15 @@ fun test() { var filtered = lensget filteredLens; assertEq(filtered, [ - (album = "Wish", quantity = 5, rating = 4, track = "Trust"), + (album = "Show", quantity = 3, rating = 3, track = "Lullaby"), (album = "Paris", quantity = 4, rating = 5, track = "Lovesong"), - (album = "Show", quantity = 3, rating = 3, track = "Lullaby") + (album = "Wish", quantity = 5, rating = 4, track = "Trust") ]); # filter out all tracks named "Trust" and change Lullaby's rating to 4. var newTracks = [ - (album = "Show", quantity = 3, rating = 4, track = "Lullaby"), - (album = "Disintegration", quantity = 7, rating = 5, track = "Lovesong") + (album = "Disintegration", quantity = 7, rating = 5, track = "Lovesong"), + (album = "Show", quantity = 3, rating = 4, track = "Lullaby") ]; lensput filteredLens with newTracks; @@ -41,18 +41,17 @@ fun test() { var new = lensget filteredLens; assertEq(new, newTracks); - assertEq(lensget tracksLens, [ - (album = "Show", date = 1989, rating = 4, track = "Lullaby"), - (album = "Galore", date = 1989, rating = 4, track = "Lullaby"), + assertEq(lensget tracksLens, [(album = "Galore", date = 1989, rating = 5, track = "Lovesong"), (album = "Disintegration", date = 1989, rating = 5, track = "Lovesong"), - (album = "Galore", date = 1989, rating = 5, track = "Lovesong") + (album = "Galore", date = 1989, rating = 4, track = "Lullaby"), + (album = "Show", date = 1989, rating = 4, track = "Lullaby") ]); assertEq(lensget albumsLens, [ - (album = "Disintegration", quantity = 7), - (album = "Wish", quantity = 5), - (album = "Paris", quantity = 4), + (album = "Show", quantity = 3), (album = "Galore", quantity = 1), - (album = "Show", quantity = 3) + (album = "Paris", quantity = 4), + (album = "Wish", quantity = 5), + (album = "Disintegration", quantity = 7) ]); lensput filteredLens with filtered; diff --git a/tests/relational-lenses/02_cds.links b/tests/relational-lenses/02_cds.links index a41c7bb8c..522b7146b 100644 --- a/tests/relational-lenses/02_cds.links +++ b/tests/relational-lenses/02_cds.links @@ -26,15 +26,15 @@ fun test() { var filtered = lensget filteredLens; assertEq(filtered, [ - (album = "Show", quantity = 3, rating = 3, track = "Lullaby"), + (album = "Paris", quantity = 4, rating = 5, track = "Lovesong"), (album = "Wish", quantity = 5, rating = 4, track = "Trust"), - (album = "Paris", quantity = 4, rating = 5, track = "Lovesong") + (album = "Show", quantity = 3, rating = 3, track = "Lullaby") ]); # filter out all tracks named "Trust" and change Lullaby's rating to 4. var newTracks = [ - (album = "Show", quantity = 3, rating = 4, track = "Lullaby"), - (album = "Disintegration", quantity = 7, rating = 5, track = "Lovesong") + (album = "Disintegration", quantity = 7, rating = 5, track = "Lovesong"), + (album = "Show", quantity = 3, rating = 4, track = "Lullaby") ]; lensput filteredLens with newTracks; @@ -43,17 +43,17 @@ fun test() { assertEq(new, newTracks); assertEq(lensget tracksLens, [ - (album = "Show", date = 1989, rating = 4, track = "Lullaby"), - (album = "Galore", date = 1989, rating = 4, track = "Lullaby"), + (album = "Galore", date = 1989, rating = 5, track = "Lovesong"), (album = "Disintegration", date = 1989, rating = 5, track = "Lovesong"), - (album = "Galore", date = 1989, rating = 5, track = "Lovesong") + (album = "Galore", date = 1989, rating = 4, track = "Lullaby"), + (album = "Show", date = 1989, rating = 4, track = "Lullaby") ]); assertEq(lensget albumsLens, [ - (album = "Disintegration", quantity = 7), - (album = "Wish", quantity = 5), - (album = "Paris", quantity = 4), + (album = "Show", quantity = 3), (album = "Galore", quantity = 1), - (album = "Show", quantity = 3) + (album = "Paris", quantity = 4), + (album = "Wish", quantity = 5), + (album = "Disintegration", quantity = 7) ]); lensput filteredLens with filtered; diff --git a/tests/relational-lenses/03_cds.links b/tests/relational-lenses/03_cds.links index 0703ab3b8..2b4a39624 100644 --- a/tests/relational-lenses/03_cds.links +++ b/tests/relational-lenses/03_cds.links @@ -21,33 +21,32 @@ fun test() { var old = lensget joinedLens; var newTracks = [ - (album = "Wish", date = 1992, quantity = 5, rating = 4, track = "Trust"), - (track="It's the end of the world as we know it", - rating=5, album="Eponymous", date=1988, quantity=42), - (album = "Show", date = 1989, quantity = 3, rating = 3, track = "Lullaby"), - (album = "Galore", date = 1989, quantity = 1, rating = 3, track = "Lullaby"), + (album = "Galore", date = 1989, quantity = 1, rating = 5, track = "Lovesong"), (album = "Paris", date = 1989, quantity = 4, rating = 5, track = "Lovesong"), - (album = "Galore", date = 1989, quantity = 1, rating = 5, track = "Lovesong") + (album = "Galore", date = 1989, quantity = 1, rating = 3, track = "Lullaby"), + (album = "Show", date = 1989, quantity = 3, rating = 3, track = "Lullaby"), + (album = "Eponymous", date = 1988, quantity = 42, rating = 5, track = "It's the end of the world as we know it"), + (album = "Wish", date = 1992, quantity = 5, rating = 4, track = "Trust") ]; lensput joinedLens with newTracks; assertEq(lensget joinedLens, newTracks); assertEq(lensget albumsLens, [ - (album = "Eponymous", quantity = 42), - (album = "Disintegration", quantity = 7), - (album = "Wish", quantity = 5), - (album = "Paris", quantity = 4), + (album = "Show", quantity = 3), (album = "Galore", quantity = 1), - (album = "Show", quantity = 3) + (album = "Paris", quantity = 4), + (album = "Wish", quantity = 5), + (album = "Disintegration", quantity = 7), + (album = "Eponymous", quantity = 42) ]); assertEq(lensget tracksLens, [ - (album = "Wish", date = 1992, rating = 4, track = "Trust"), - (album = "Eponymous", date = 1988, rating = 5, track = "It's the end of the world as we know it"), - (album = "Show", date = 1989, rating = 3, track = "Lullaby"), - (album = "Galore", date = 1989, rating = 3, track = "Lullaby"), + (album = "Galore", date = 1989, rating = 5, track = "Lovesong"), (album = "Paris", date = 1989, rating = 5, track = "Lovesong"), - (album = "Galore", date = 1989, rating = 5, track = "Lovesong") + (album = "Galore", date = 1989, rating = 3, track = "Lullaby"), + (album = "Show", date = 1989, rating = 3, track = "Lullaby"), + (album = "Eponymous", date = 1988, rating = 5, track = "It's the end of the world as we know it"), + (album = "Wish", date = 1992, rating = 4, track = "Trust") ]); lensput joinedLens with old; From 7a568f88dc4ebb76d343e332c9359230615ab164 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Wed, 17 Jun 2020 10:02:25 +0100 Subject: [PATCH 10/28] remove last vestiges of CGI script web mode (#849) * remove last vestiges of CGI script web mode * whitespace --- bin/links.ml | 9 +-------- bin/repl.ml | 2 +- core/basicsettings.ml | 9 --------- core/evalir.ml | 2 +- core/typeSugar.ml | 2 +- core/webserver.ml | 1 - 6 files changed, 4 insertions(+), 21 deletions(-) diff --git a/bin/links.ml b/bin/links.ml index f69f4cb7f..d032b9590 100644 --- a/bin/links.ml +++ b/bin/links.ml @@ -108,11 +108,4 @@ let main () = | [], [] -> Repl.interact context'' | _, _ -> () -let _ = - (* Determine whether web mode should be enabled. *) - begin match Utility.getenv "REQUEST_METHOD" with - | Some _ -> Settings.set BS.web_mode true - | None -> () - end; - main() - +let _ = main() diff --git a/bin/repl.ml b/bin/repl.ml index 2b87155f1..2d9d19424 100644 --- a/bin/repl.ml +++ b/bin/repl.ml @@ -48,7 +48,7 @@ let ps1 = "links> " (** Print a value (including its type if `printing_types' is [true]). *) let print_value rtype value = - if Settings.get BS.web_mode || not (Settings.get print_pretty) + if Settings.get Webserver_types.webs_running || not (Settings.get print_pretty) then begin print_string (Value.string_of_value value); print_endline (if Settings.get printing_types then diff --git a/core/basicsettings.ml b/core/basicsettings.ml index 71581a09a..664ea26dc 100644 --- a/core/basicsettings.ml +++ b/core/basicsettings.ml @@ -1,12 +1,3 @@ -(** [true] if we're in web mode *) -let web_mode = - Settings.(flag "web_mode" - |> synopsis "Start Links in web mode" - |> privilege `System - |> convert parse_bool - |> CLI.(add (short 'w' <&> long "web-mode")) - |> sync) - (** [true] if we're in interactive mode *) let interactive_mode = Settings.(flag "interactive_mode" diff --git a/core/evalir.ml b/core/evalir.ml index 96bf87dda..6392322d9 100644 --- a/core/evalir.ml +++ b/core/evalir.ml @@ -128,7 +128,7 @@ struct result = fun req_data name cont args -> - if not(Settings.get Basicsettings.web_mode) then + if not(Settings.get webs_running) then raise (Errors.client_call_outside_webmode name); (*if not(Proc.singlethreaded()) then raise (internal_error "Remaining procs on server at client call!"); *) diff --git a/core/typeSugar.ml b/core/typeSugar.ml index a92d12eff..035add52b 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -422,7 +422,7 @@ end error:Unify.error -> unit - let wm () = Settings.get Basicsettings.web_mode + let wm () = Settings.get Webserver_types.webs_running let code s = if wm () then diff --git a/core/webserver.ml b/core/webserver.ml index 570362509..a0293f3b5 100644 --- a/core/webserver.ml +++ b/core/webserver.ml @@ -352,7 +352,6 @@ struct Debug.print ("Starting server?\n"); Lwt.async_exception_hook := (fun exn -> Debug.print ("Caught asynchronous exception: " ^ (Printexc.to_string exn))); - Settings.set Basicsettings.web_mode true; Settings.set webs_running true; start_server (val_of (Settings.get hostname)) (val_of (Settings.get port)) rt end From e9f7b4f8fd6cf55d2c365764a31c1bdb0ce8f9cb Mon Sep 17 00:00:00 2001 From: James Cheney Date: Wed, 17 Jun 2020 11:58:28 +0100 Subject: [PATCH 11/28] hygienic references to library functions in pattern compilation (fix #24) (#843) * hygienic references to library functions in pattern compilation * removed commented out dead code --- core/compilePatterns.ml | 20 +++++--------------- tests/collections.tests | 1 - 2 files changed, 5 insertions(+), 16 deletions(-) diff --git a/core/compilePatterns.ml b/core/compilePatterns.ml index 00c28ed3f..cbb78b6d9 100644 --- a/core/compilePatterns.ml +++ b/core/compilePatterns.ml @@ -183,23 +183,18 @@ sig end = struct - (* let lookup_type var (_nenv, tenv, _eff) = *) - (* TEnv.lookup tenv var *) - - let lookup_name name (nenv, _tenv, _eff) = - NEnv.find name nenv let lookup_effects (_nenv, _tenv, eff) = eff - let nil env t : value = - TApp (Variable (lookup_name "Nil" env), + let nil _env t : value = + TApp (Variable (NEnv.find "Nil" Lib.nenv), [`Type t]) let list_head env t : value -> tail_computation = fun v -> let eff = lookup_effects env in Apply (TApp - (Variable (lookup_name "hd" env), + (Variable (NEnv.find "hd" Lib.nenv), [`Type t; `Row eff]), [v]) @@ -207,7 +202,7 @@ struct let eff = lookup_effects env in Apply (TApp - (Variable (lookup_name "tl" env), + (Variable (NEnv.find "tl" Lib.nenv), [`Type t; `Row eff]), [v]) end @@ -219,11 +214,6 @@ sig end = struct - (* let lookup_type var (_nenv, tenv, _eff) = *) - (* TEnv.lookup tenv var *) - - let lookup_name name (nenv, _tenv, _eff) = - NEnv.find name nenv let lookup_effects (_nenv, _tenv, eff) = eff @@ -231,7 +221,7 @@ struct let eff = lookup_effects env in ApplyPure (TApp - (Variable (lookup_name "==" env), + (Variable (NEnv.find "==" Lib.nenv), [`Type t; `Row eff]), [v1; v2]) end diff --git a/tests/collections.tests b/tests/collections.tests index 956879f8d..5d5e069ee 100644 --- a/tests/collections.tests +++ b/tests/collections.tests @@ -107,7 +107,6 @@ stdout : 2 : Int Case patterns (with redefined hd) { fun hd(_) { 1 } switch (['a']) { case [y] -> y }} stdout : 'a' : Char -ignore : Known hygiene problem With parentheses: switch ([1]) { case (x::xs) -> 1 case x -> 2 } From 596a872991422e09b88489bec7ec86a3ab9eb73c Mon Sep 17 00:00:00 2001 From: Sam Lindley Date: Wed, 17 Jun 2020 13:39:15 +0100 Subject: [PATCH 12/28] connect doesn't need explicit synchronisation now that End is linear - indeed the old version shouldn't typecheck! --- prelude.links | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/prelude.links b/prelude.links index 0b9380fa0..6ba4ef250 100644 --- a/prelude.links +++ b/prelude.links @@ -1192,27 +1192,15 @@ fun reproduce(ap, f) { reproduce(ap, f) } -# Here we use an additional access point to synchronise on termination -# of communicating threads. This synchronisation can be useful because -# we do not have an explicit close function and by default the -# top-level process does not wait for running threads to terminate. -# -# (In fact, this gymnastics is no longer necessary now that we have -# spawnAngel which allows us to spawn a process that will continue to -# run even if the main process terminates.) #sig connect : forall s::Session,e::Row,a.((s) ~e~> (), (~s) ~e~> a) ~e~> a sig connect : forall s::Session,e::Row,a.((s) {SessionFail:[||]}~> (), (~s) ~e~> a) ~e~> a fun connect(f, g) { var ap = new(); - var done = new(); var _ = spawn { f(accept(ap)); - ignore(send((), accept(done))) }; - var result = g(request(ap)); - ignore(receive(request(done))); - result + g(request(ap)) } ### sessions with split ends ### From 665a0e6a7548f16e8ed5f8cef1c05e411b60db7f Mon Sep 17 00:00:00 2001 From: eman0n Date: Sun, 21 Jun 2020 14:03:25 +0100 Subject: [PATCH 13/28] Fix #154 (#851) * Fix #154 by checking for ajax request data --- core/errors.ml | 8 ++++---- core/errors.mli | 2 +- core/evalir.ml | 4 +++- core/requestData.ml | 10 ++++++++++ core/requestData.mli | 4 ++++ core/utility.ml | 2 -- core/webif.ml | 18 +++--------------- core/webif.mli | 2 -- core/webserver.ml | 2 +- 9 files changed, 26 insertions(+), 26 deletions(-) diff --git a/core/errors.ml b/core/errors.ml index 26a5741d7..b35ad187a 100644 --- a/core/errors.ml +++ b/core/errors.ml @@ -50,7 +50,7 @@ exception DynlinkError of string exception ModuleError of string * Position.t option exception DisabledExtension of Position.t option * (string * bool) option * string option * string exception PrimeAlien of Position.t -exception ClientCallOutsideWebMode of string +exception ForbiddenClientCall of string * string exception MissingBuiltinType of string exception LocateFailure of string @@ -184,8 +184,8 @@ let format_exception = pos_prefix (Printf.sprintf "Error: Cannot load plugin dependency '%s' (link error: %s)\n" file (Dynlink.error_message err)) | LoadFailure (file, err) -> pos_prefix (Printf.sprintf "Error: Cannot load plugin '%s' (link error: %s)\n" file (Dynlink.error_message err)) - | ClientCallOutsideWebMode fn -> - pos_prefix (Printf.sprintf "Error: Cannot call client side function '%s' outside of web mode\n" fn) + | ForbiddenClientCall (fn, reason) -> + pos_prefix (Printf.sprintf "Error: Cannot call client side function '%s' because of %s\n" fn reason) | MissingBuiltinType alias -> Printf.sprintf "Error: Missing builtin type with alias '%s'. Is it defined in the prelude?" alias | Sys.Break -> "Caught interrupt" | exn -> pos_prefix ("Error: " ^ Printexc.to_string exn) @@ -230,4 +230,4 @@ let module_error ?pos message = (ModuleError (message, pos)) let disabled_extension ?pos ?setting ?flag name = DisabledExtension (pos, setting, flag, name) let prime_alien pos = PrimeAlien pos -let client_call_outside_webmode fn = ClientCallOutsideWebMode fn +let forbidden_client_call fn reason = ForbiddenClientCall (fn, reason) diff --git a/core/errors.mli b/core/errors.mli index b5767fa5d..a75b23590 100644 --- a/core/errors.mli +++ b/core/errors.mli @@ -55,5 +55,5 @@ val driver_locate_failure : string -> exn val illformed_plugin_description : string -> exn val dependency_load_failure : string -> Dynlink.error -> exn val load_failure : string -> Dynlink.error -> exn -val client_call_outside_webmode : string -> exn +val forbidden_client_call : string -> string -> exn val rethrow_errors_if_better_position : Position.t -> ('a -> 'b) -> 'a -> 'b diff --git a/core/evalir.ml b/core/evalir.ml index 6392322d9..ab2baf4da 100644 --- a/core/evalir.ml +++ b/core/evalir.ml @@ -129,7 +129,9 @@ struct fun req_data name cont args -> if not(Settings.get webs_running) then - raise (Errors.client_call_outside_webmode name); + raise (Errors.forbidden_client_call name "outside of web mode"); + if not(RequestData.is_ajax_call (RequestData.get_cgi_parameters req_data)) then + raise (Errors.forbidden_client_call name "before server page is ready"); (*if not(Proc.singlethreaded()) then raise (internal_error "Remaining procs on server at client call!"); *) Debug.print("Making client call to " ^ name); diff --git a/core/requestData.ml b/core/requestData.ml index 23c66712d..e73048b8e 100644 --- a/core/requestData.ml +++ b/core/requestData.ml @@ -110,3 +110,13 @@ let decode : string -> string = fun s -> end +(** remote client->server call *) +let is_remote_call params = + List.mem_assoc "__name" params && List.mem_assoc "__args" params + +(** return __result from server->client call with server continuation __continuation *) +let is_client_return params = + List.mem_assoc "__continuation" params && List.mem_assoc "__result" params + +let is_ajax_call cgi_args = + (is_remote_call cgi_args) || (is_client_return cgi_args) diff --git a/core/requestData.mli b/core/requestData.mli index b12bbc7cf..8fd25671a 100644 --- a/core/requestData.mli +++ b/core/requestData.mli @@ -30,3 +30,7 @@ module DecodeRequestHeaders : sig val decode : string -> string end + +val is_remote_call : (string * string) list -> bool +val is_client_return : (string * string) list -> bool +val is_ajax_call : (string * string) list -> bool \ No newline at end of file diff --git a/core/utility.ml b/core/utility.ml index 0b86855fe..7ddbd26b5 100644 --- a/core/utility.ml +++ b/core/utility.ml @@ -1458,5 +1458,3 @@ struct (sequence xs) >>= fun xs -> Lwt.return (x :: xs) end - - diff --git a/core/webif.ml b/core/webif.ml index b5ed59da2..5305381bf 100644 --- a/core/webif.ml +++ b/core/webif.ml @@ -44,14 +44,6 @@ struct (** Boolean tests for cgi parameters *) - (** remote client->server call *) - let is_remote_call params = - mem_assoc "__name" params && mem_assoc "__args" params - - (** return __result from server->client call with server continuation __continuation *) - let is_client_return params = - mem_assoc "__continuation" params && mem_assoc "__result" params - (** invoke server continuation _k (e.g. from a hypertext link or a formlet post) *) @@ -88,14 +80,10 @@ struct body ^ "\n \n" - let is_ajax_call cgi_args = - (is_remote_call cgi_args) || (is_client_return cgi_args) - - (* jcheney: lifted from serve_request, to de-clutter *) let parse_request env cgi_args = - if (is_remote_call cgi_args) + if (RequestData.is_remote_call cgi_args) then parse_remote_call env cgi_args - else if (is_client_return cgi_args) + else if (RequestData.is_client_return cgi_args) then parse_client_return env cgi_args else if (is_server_cont cgi_args) then parse_server_cont env cgi_args @@ -188,7 +176,7 @@ struct Lwt.return (mime_type, error_page (Errors.format_exception_html exc)) in let handle_error e = - if (is_ajax_call cgi_args) then + if (RequestData.is_ajax_call cgi_args) then handle_ajax_error e else handle_html_error e in diff --git a/core/webif.mli b/core/webif.mli index 41c53757c..02888d347 100644 --- a/core/webif.mli +++ b/core/webif.mli @@ -5,8 +5,6 @@ open Webserver_types module WebIf : functor (Webs : WEBSERVER) -> sig - val is_ajax_call : (string * string) list -> bool - val do_request : (Value.env * Ir.var Env.String.t * Types.typing_environment) -> (string * string) list -> diff --git a/core/webserver.ml b/core/webserver.ml index a0293f3b5..4d35615a9 100644 --- a/core/webserver.ml +++ b/core/webserver.ml @@ -162,7 +162,7 @@ struct let get_or_make_client_id cgi_args = - if (Webif.is_ajax_call cgi_args) then + if (RequestData.is_ajax_call cgi_args) then get_client_id_or_die cgi_args else ClientID.create () From b761f2a28985be304fba8a4f643810561260c5ed Mon Sep 17 00:00:00 2001 From: Simon Fowler Date: Mon, 22 Jun 2020 12:36:07 +0100 Subject: [PATCH 14/28] Fix linearity of `End` in presence of duality (#853) As hinted at by a1ffb17, Links was not handling the linearity of the End type correctly. This was because of a very subtle bug in checking linearity of dualised session types. This patch: 1. Fixes the duality bug 2. Ensures `connect` is correct given the asynchronous semantics of `close` 3. Fixes all examples which mistakenly treated `End` as unrestricted --- core/types.ml | 4 ++-- examples/sessions/ap-multi-client.links | 5 +++-- examples/sessions/draggable.links | 16 +++++++++------- examples/sessions/fusegg.links | 8 ++++---- examples/sessions/givengrab.links | 7 ++++--- examples/sessions/gng-client.links | 8 +++++--- examples/webserver/draggable-sessions.links | 16 +++++++++------- prelude.links | 15 ++++++++++++++- tests/session-exceptions/cancel1.links | 8 +++++--- tests/session-exceptions/cancel10.links | 8 +++++--- tests/session-exceptions/cancel11.links | 2 +- tests/session-exceptions/cancel2.links | 16 ++++++++-------- tests/session-exceptions/cancel3.links | 9 +++++---- tests/session-exceptions/cancel4.links | 7 ++++--- tests/session-exceptions/cancel5.links | 8 +++++--- tests/session-exceptions/cancel6.links | 5 +++-- tests/session-exceptions/cancel7.links | 8 ++++---- tests/session-exceptions/cancel8.links | 9 +++++---- tests/session-exceptions/cancel9.links | 5 +++-- 19 files changed, 98 insertions(+), 66 deletions(-) diff --git a/core/types.ml b/core/types.ml index c71d821d5..e0d51522f 100644 --- a/core/types.ml +++ b/core/types.ml @@ -736,7 +736,7 @@ module Unl : Constraint = struct | `Not_typed -> assert false | `Effect _ | `Primitive _ | `Function _ -> true | `Lolli _ -> false - | (`Record _ | `Variant _ | `Alias _ | `MetaTypeVar _ | `ForAll _ | `Dual _) as t + | (`Record _ | `Variant _ | `Alias _ | `MetaTypeVar _ | `ForAll _) as t -> super#type_satisfies vars t | `Table _ -> true | `Lens _sort -> true @@ -752,7 +752,7 @@ module Unl : Constraint = struct * block is unrestricted. With this in hand, we can calculate * linearity information, meaning that (r_linear ()) will return (Some lin). *) OptionUtils.opt_app not true (r_linear ()) - | `End -> false + | `End | `Dual _ -> false | #session_type -> false end diff --git a/examples/sessions/ap-multi-client.links b/examples/sessions/ap-multi-client.links index b3e892c8f..6b577ce79 100644 --- a/examples/sessions/ap-multi-client.links +++ b/examples/sessions/ap-multi-client.links @@ -1,13 +1,14 @@ fun grabber(ap) client { var s = accept(ap); var t = accept(ap); - <| s(x).t(y).s(z).t(w).s[x+y].t[z+w].{()} |>; + <| s(x).t(y).s(z).t(w).s[x+y].t[z+w].{close(s); close(t)} |>; grabber(ap); } fun giver(x, y, a, b) client { var s = request(a); - var z = receive(send(y,send(x,s))).1; + var (z, s) = receive(send(y,send(x,s))); + close(s); var t = accept(b); close(send(z, t)); } diff --git a/examples/sessions/draggable.links b/examples/sessions/draggable.links index 4822d1688..82384b622 100644 --- a/examples/sessions/draggable.links +++ b/examples/sessions/draggable.links @@ -39,22 +39,24 @@ fun draggableList(loc, id, items) fun wait(c) { var s = accept(ap); <|offer s { - case MouseUp -> {wait(c)} + case MouseUp -> {close(s); wait(c)} case MouseDown -> s(elem).{ + close(s); if (isElementNode(elem) && (parentNode(elem) == getNodeById(id))) { <|MouseDown c.c[elem].{drag(c)}|> } else { wait(c) }} - case MouseOut -> s(elem).{wait(c)} + case MouseOut -> s(elem).{close(s); wait(c)} }|> } fun drag(c) { offer(accept(ap)) { - case MouseUp(s) -> <|MouseUp c.{wait(c)}|> - case MouseDown(s) -> <|s(elem).{drag(c)}|> + case MouseUp(s) -> <|MouseUp c.{close(s); wait(c)}|> + case MouseDown(s) -> <|s(elem).{close(s); drag(c)}|> case MouseOut(s) -> <|s(toElem).{ + close(s); if (isElementNode(toElem) && (parentNode(toElem) == getNodeById(id))) { <| MouseOut c.c[toElem].{drag(c)} |> } else { @@ -69,17 +71,17 @@ fun draggableList(loc, id, items) fun mouseUp() { var c = request(ap); - <|MouseUp c.{()}|> + <|MouseUp c.{close(c)}|> } fun mouseDown(elem) { var c = request(ap); - <|MouseDown c.c[elem].{()}|> + <|MouseDown c.c[elem].{close(c)}|> } fun mouseOut(toElem) { var c = request(ap); - <|MouseOut c.c[toElem].{()}|> + <|MouseOut c.c[toElem].{close(c)}|> }
    {wait(c)} + case MouseUp -> {close(s); wait(c)} case MouseDown -> s(elem).{ + close(s); if (isElementNode(elem) && (parentNode(elem) == getNodeById(id))) { <|MouseDown c.c[elem].{drag(c)}|> } else { wait(c) }} - case MouseOut -> s(elem).{wait(c)} + case MouseOut -> s(elem).{close(s); wait(c)} }|> } fun drag(c) { offer(accept(ap)) { - case MouseUp(s) -> <|MouseUp c.{wait(c)}|> - case MouseDown(s) -> <|s(elem).{drag(c)}|> + case MouseUp(s) -> <|MouseUp c.{close(s); wait(c)}|> + case MouseDown(s) -> <|s(elem).{close(s); drag(c)}|> case MouseOut(s) -> <|s(toElem).{ + close(s); if (isElementNode(toElem) && (parentNode(toElem) == getNodeById(id))) { <| MouseOut c.c[toElem].{drag(c)} |> } else { @@ -70,17 +72,17 @@ fun draggableList(id, items) fun mouseUp() { var c = request(ap); - <|MouseUp c|> + <| MouseUp c.{close(c)}|> } fun mouseDown(elem) { var c = request(ap); - <|MouseDown c.c[elem]|> + <|MouseDown c.c[elem].{close(c)}|> } fun mouseOut(toElem) { var c = request(ap); - <|MouseOut c.c[toElem]|> + <|MouseOut c.c[toElem].{close(c)}|> }
      (), (~s) ~e~> a) ~e~> a sig connect : forall s::Session,e::Row,a.((s) {SessionFail:[||]}~> (), (~s) ~e~> a) ~e~> a fun connect(f, g) { var ap = new(); + var done = new(); var _ = spawn { f(accept(ap)); + close(send((), accept(done))) }; - g(request(ap)) + var result = g(request(ap)); + var (_, s) = receive(request(done)); + close(s); + result } ### sessions with split ends ### diff --git a/tests/session-exceptions/cancel1.links b/tests/session-exceptions/cancel1.links index 14b16199c..e37ad5978 100644 --- a/tests/session-exceptions/cancel1.links +++ b/tests/session-exceptions/cancel1.links @@ -1,7 +1,8 @@ fun goAlright() { try { - var s = fork (fun (s) { ignore(send(5, s)) }); - var (res, _) = receive(s); + var s = fork (fun (s) { close(send(5, s)) }); + var (res, s) = receive(s); + close(s); res } as (x) in { "result: " ^^ intToString(x) @@ -13,7 +14,8 @@ fun goAlright() { fun go() { try { var s = fork (fun (s) { cancel(s) }); - var (res, _) = receive(s); + var (res, s) = receive(s); + close(s); res } as (x) in { "result: " ^^ intToString(x) diff --git a/tests/session-exceptions/cancel10.links b/tests/session-exceptions/cancel10.links index 9e0692140..5c10aa58f 100644 --- a/tests/session-exceptions/cancel10.links +++ b/tests/session-exceptions/cancel10.links @@ -1,12 +1,14 @@ fun go() { - var s = fork(fun(s) { ignore(send(5, s)) }); + var s = fork(fun(s) { close(send(5, s)) }); try { raise; 10 } as (x) in { - var (res, _) = receive(s); + var (res, s) = receive(s); + close(s); x + res } otherwise { - var (res, _) = receive(s); + var (res, s) = receive(s); + close(s); res } } diff --git a/tests/session-exceptions/cancel11.links b/tests/session-exceptions/cancel11.links index d4786ddd9..9b617c3a2 100644 --- a/tests/session-exceptions/cancel11.links +++ b/tests/session-exceptions/cancel11.links @@ -2,7 +2,7 @@ fun go() { try { var s = fork (fun (s) { cancel(s) }); offer(s) { - case Foo(s) -> 100 + case Foo(s) -> close(s); 100 } } as (x) in { "result: " ^^ intToString(x) diff --git a/tests/session-exceptions/cancel2.links b/tests/session-exceptions/cancel2.links index 32dd4558a..bab81b340 100644 --- a/tests/session-exceptions/cancel2.links +++ b/tests/session-exceptions/cancel2.links @@ -4,12 +4,12 @@ fun goAlright() { var ap = new(); # Yay synchronisation! try { var s = fork (fun (s) { - # cancel(s); - ignore(request(ap)); - ignore(receive(s)); + close(request(ap)); + var (_, s) = receive(s); + close(s) }); - ignore(accept(ap)); - ignore(send(5, s)) + close(accept(ap)); + close(send(5, s)) } as (_) in { "send successful" } otherwise { @@ -23,10 +23,10 @@ fun go() { try { var s = fork (fun (s) { cancel(s); - ignore(request(ap)) + close(request(ap)) }); - ignore(accept(ap)); - ignore(send(5, s)) + close(accept(ap)); + close(send(5, s)) } as (_) in { "send successful" } otherwise { diff --git a/tests/session-exceptions/cancel3.links b/tests/session-exceptions/cancel3.links index 80011383a..fbad35d87 100644 --- a/tests/session-exceptions/cancel3.links +++ b/tests/session-exceptions/cancel3.links @@ -5,13 +5,14 @@ fun go() { var t = fork(fun(t) { var carried = request(ap); # Ensure the send takes place before cancellation - var _ = send(carried, t); - ignore(request(syncAP)) + close(send(carried, t)); + close(request(syncAP)) }); var carried = accept(ap); - ignore(accept(syncAP)); + close(accept(syncAP)); cancel(t); - var (res, _) = receive(carried); + var (res, s) = receive(carried); + close(s); res } as (x) in { "received from carried: " ^^ intToString(x) diff --git a/tests/session-exceptions/cancel4.links b/tests/session-exceptions/cancel4.links index 08de7e86b..36a78c1de 100644 --- a/tests/session-exceptions/cancel4.links +++ b/tests/session-exceptions/cancel4.links @@ -1,12 +1,13 @@ fun go() { var ap = new(); - var s = fork(fun(s) { cancel(s); ignore(request(ap)) }); + var s = fork(fun(s) { cancel(s); close(request(ap)) }); try { var x = try { - var _ = accept(ap); - var (res, _) = receive(s); + close(accept(ap)); + var (res, s) = receive(s); + close(s); res } as (x) in { x diff --git a/tests/session-exceptions/cancel5.links b/tests/session-exceptions/cancel5.links index c72af9391..83e6e1727 100644 --- a/tests/session-exceptions/cancel5.links +++ b/tests/session-exceptions/cancel5.links @@ -3,12 +3,14 @@ fun go() { try { var s = fork(fun(s) { var t = request(ap); - ignore(receive(s)); - ignore(send(5, t)) + var (_, s) = receive(s); + close(s); + close(send(5, t)) }); cancel(s); var t = accept(ap); - var (x, _) = receive(t); + var (x, t) = receive(t); + close(t); x } as (x) in { intToString(x) diff --git a/tests/session-exceptions/cancel6.links b/tests/session-exceptions/cancel6.links index d533d12e5..a738db137 100644 --- a/tests/session-exceptions/cancel6.links +++ b/tests/session-exceptions/cancel6.links @@ -5,10 +5,11 @@ fun go() { var s = fork (fun(s) { var t = accept(ap); raise; - ignore(send(linfun() { send(5, t) }, s)) + close(send(linfun() { send(5, t) }, s)) }); var t = request(ap); - var (res, _) = receive(t); + var (res, t) = receive(t); + close(t); cancel(s); res } as (x) in { diff --git a/tests/session-exceptions/cancel7.links b/tests/session-exceptions/cancel7.links index 680272494..6b0b863d2 100644 --- a/tests/session-exceptions/cancel7.links +++ b/tests/session-exceptions/cancel7.links @@ -4,13 +4,13 @@ fun go() { try { var s = fork (fun(s) { var t = accept(ap); - var clos = linfun() { send(5, t) }; + var clos = linfun() { close(send(5, t)) }; raise; - ignore(send(clos, s)) + close(send(clos, s)) }); var t = request(ap); - var (res, _) = receive(t); - #cancel(t); + var (res, t) = receive(t); + close(t); cancel(s); 1 } as (x) in { diff --git a/tests/session-exceptions/cancel8.links b/tests/session-exceptions/cancel8.links index 446909c81..b002e7c2d 100644 --- a/tests/session-exceptions/cancel8.links +++ b/tests/session-exceptions/cancel8.links @@ -6,13 +6,14 @@ fun go() { var s = fork (fun(s) { var t = accept(ap); var clos = linfun() { send(5, t) }; - ignore(send(clos, s)); - ignore(request(syncAP)) + close(send(clos, s)); + close(request(syncAP)) }); var t = request(ap); - ignore(accept(syncAP)); + close(accept(syncAP)); cancel(s); - var (res, _) = receive(t); + var (res, t) = receive(t); + close(t); res } as (x) in { "success: " ^^ intToString(x) diff --git a/tests/session-exceptions/cancel9.links b/tests/session-exceptions/cancel9.links index a091561db..2515d4eb0 100644 --- a/tests/session-exceptions/cancel9.links +++ b/tests/session-exceptions/cancel9.links @@ -6,10 +6,11 @@ fun go() { var t = accept(ap); raise; var clos = linfun() { send(5, t) }; - ignore(send(clos, s)) + close(send(clos, s)) }); var t = request(ap); - var (res, _) = receive(t); + var (res, t) = receive(t); + close(t); cancel(s); res } as (x) in { From bca616b9a66cfbb18c9191e1b330b85d5cc51827 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 12:36:38 +0100 Subject: [PATCH 15/28] fix #754 (#852) * fix 754 by passing regular expressions through let insertion and flattening stages * whitespace * whitespace * add genuinely nested query test --- core/query/evalNestedQuery.ml | 6 ++++++ tests/shredding/jrules.links | 17 +++++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/core/query/evalNestedQuery.ml b/core/query/evalNestedQuery.ml index a02dbe493..e0fd5cdbb 100644 --- a/core/query/evalNestedQuery.ml +++ b/core/query/evalNestedQuery.ml @@ -383,6 +383,9 @@ struct end | Apply (Primitive "Empty", [e]) -> Apply (Primitive "Empty", [lins_inner_query (z, z_fields) ys e]) | Apply (Primitive "length", [e]) -> Apply (Primitive "length", [lins_inner_query (z, z_fields) ys e]) + | Apply (Primitive "tilde", [s; r]) as e -> + Debug.print ("Applying lins_inner to tilde expression: " ^ QL.show e); + Apply (Primitive "tilde", [lins_inner (z, z_fields) ys s; r]) | Apply (Primitive f, es) -> Apply (Primitive f, List.map (lins_inner (z, z_fields) ys) es) | Record fields -> @@ -489,6 +492,9 @@ struct | Primitive p -> Primitive p | Apply (Primitive "Empty", [e]) -> Apply (Primitive "Empty", [flatten_inner_query e]) | Apply (Primitive "length", [e]) -> Apply (Primitive "length", [flatten_inner_query e]) + | Apply (Primitive "tilde", [s; r]) as e -> + Debug.print ("Applying flatten_inner to tilde expression: " ^ QL.show e); + Apply (Primitive "tilde", [flatten_inner s; r]) | Apply (Primitive f, es) -> Apply (Primitive f, List.map flatten_inner es) | If (c, t, e) -> If (flatten_inner c, flatten_inner t, flatten_inner e) diff --git a/tests/shredding/jrules.links b/tests/shredding/jrules.links index 56c79ee3d..3fdafa349 100644 --- a/tests/shredding/jrules.links +++ b/tests/shredding/jrules.links @@ -42,8 +42,25 @@ fun u () { } } +sig v : () -> [(name:String)] +fun v () { + query nested { + for (x <-- marketers_names) + where (x.name =~ /a/) + [x] + } +} + +sig marketers2 : () -> [(name:String, clients:[Int])] +fun marketers2 () { + for (m <-- marketers_names) + [(name=m.name, clients = for (x <-- mc) where (x.m == m.name && x.m =~ /a/) [x.c])] +} + fun test() { assertEq(u(), [((id=1), ["a", "c"]), ((id=2), ["c"]), ((id=3), ["c"]), ((id=42), [])]); + assertEq(v(), [(name = "a")]); + assertEq(marketers2(), [(clients = [1], name = "a"), (clients = [], name = "b"), (clients = [], name = "c")]); } test() From 89950b491b0aec750de1d560fe860c860a3ebdca Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 12:37:28 +0100 Subject: [PATCH 16/28] Require <-- and asList to be in query blocks * comment out is_query checks in Iteration * add newly needed query keyword * tab * remove relax_query_type_constraint * remove relax_query_type_constraint * remove commented out code * newline * added test for #835 * tab * Initial attempt at #841 for discussion * whitespace argh * remove dead code --- core/database.ml | 5 -- core/database.mli | 1 - core/evalir.ml | 21 ++--- core/frontend.ml | 1 - core/irCheck.ml | 9 +- core/typeSugar.ml | 44 +++++----- core/wrapTableIterators.ml | 56 ------------ core/wrapTableIterators.mli | 1 - examples/filter.links | 30 ++++--- examples/initialise-list.links | 2 +- examples/wine.links | 145 ++++++++++++++++++-------------- prelude.links | 1 + tests/database/factorials.links | 12 ++- tests/database/xpath.links | 2 +- tests/records.tests | 2 +- tests/shredding/config.sample | 1 - tests/shredding/jrules.links | 4 +- 17 files changed, 157 insertions(+), 180 deletions(-) delete mode 100644 core/wrapTableIterators.ml delete mode 100644 core/wrapTableIterators.mli diff --git a/core/database.ml b/core/database.ml index e87813f5a..123f1c92b 100644 --- a/core/database.ml +++ b/core/database.ml @@ -9,11 +9,6 @@ let connection_info |> convert Utility.some |> sync) -let relax_query_type_constraint = - Settings.(flag "relax_query_type_constraint" - |> convert parse_bool - |> sync) - let shredding = Settings.(flag "shredding" |> synopsis "Enables database query shredding" diff --git a/core/database.mli b/core/database.mli index 4ee7ba6d1..58fdc6789 100644 --- a/core/database.mli +++ b/core/database.mli @@ -1,7 +1,6 @@ (** A generic interface for SQL-style databases. Vendor-specific implementations are elsewhere *) val connection_info : string option Settings.setting -val relax_query_type_constraint : bool Settings.setting val shredding : bool Settings.setting class virtual db_args : string -> object diff --git a/core/evalir.ml b/core/evalir.ml index ab2baf4da..2620577bc 100644 --- a/core/evalir.ml +++ b/core/evalir.ml @@ -701,13 +701,6 @@ struct value env offset >>= fun offset -> Lwt.return (Some (Value.unbox_int limit, Value.unbox_int offset)) end >>= fun range -> - let evaluator = - let open QueryPolicy in - match policy with - | Flat -> `Flat - | Nested -> `Nested - | Default -> - if Settings.get Database.shredding then `Nested else `Flat in let evaluate_standard () = match EvalQuery.compile env (range, e) with @@ -757,11 +750,15 @@ struct in raise (Errors.runtime_error error_msg) in - begin - match evaluator with - | `Flat -> evaluate_standard () - | `Nested -> evaluate_nested () - end + let evaluator = + let open QueryPolicy in + match policy with + | Flat -> evaluate_standard + | Nested -> evaluate_nested + | Default -> + if Settings.get Database.shredding then evaluate_nested else evaluate_standard in + evaluator() + | InsertRows (source, rows) -> begin value env source >>= fun source -> diff --git a/core/frontend.ml b/core/frontend.ml index 3187e5752..cdc087650 100644 --- a/core/frontend.ml +++ b/core/frontend.ml @@ -204,7 +204,6 @@ module Typeability_preserving = struct Basicsettings.Sessions.exceptions_enabled (module DesugarSessionExceptions) ; (module DesugarProcesses) - ; (module WrapTableIterators) ; (module DesugarFors) ; (module DesugarRegexes) ; (module DesugarFormlets) diff --git a/core/irCheck.ml b/core/irCheck.ml index ea71e6bef..86ee28080 100644 --- a/core/irCheck.ml +++ b/core/irCheck.ml @@ -768,7 +768,14 @@ struct (* The type of the body must match the type the query is annotated with *) o#check_eq_types original_t t (SSpec special); - (if Settings.get Database.relax_query_type_constraint then + let check_flat_result = + let open QueryPolicy in + match policy with + | Flat -> true + | Nested -> false + | Default -> not(Settings.get Database.shredding) in + + (if not(check_flat_result) then () (* Discussion pending about how to type-check here. Currently same as frontend *) else let list_content_type = TypeUtils.element_type ~overstep_quantifiers:false t in diff --git a/core/typeSugar.ml b/core/typeSugar.ml index 035add52b..4430574e7 100644 --- a/core/typeSugar.ml +++ b/core/typeSugar.ml @@ -328,6 +328,7 @@ sig val form_binding_pattern : griper val iteration_unl_effect : griper + val iteration_ambient_effect : griper val iteration_list_body : griper val iteration_list_pattern : griper val iteration_table_body : griper @@ -335,7 +336,6 @@ sig val iteration_body : griper val iteration_where : griper val iteration_base_order : griper - val iteration_base_body : griper val escape : griper val escape_outer : griper @@ -960,7 +960,7 @@ end let query_base_row ~pos ~t1:(lexpr, lt) ~t2:_ ~error:_ = build_tyvar_names [lt]; - with_but pos ("Query blocks must have LOROB type") (lexpr, lt) + with_but pos ("Flat query blocks must return a list of records of base type") (lexpr, lt) let receive_mailbox ~pos ~t1:(_, lt) ~t2:(_, rt) ~error:_ = build_tyvar_names [lt; rt]; @@ -1111,6 +1111,16 @@ end "but the currently allowed effects are" ^ nli () ^ code ppr_lt) + let iteration_ambient_effect ~pos ~t1:(_, lt) ~t2:(_, rt) ~error:_ = + build_tyvar_names [lt; rt]; + let ppr_rt = show_type rt in + let ppr_lt = show_type lt in + die pos ("Iterations over tables are only allowed in tame contexts." ^ nli () ^ + "This iteration has ambient effect" ^ nli () ^ + code ppr_rt ^ nl () ^ + "but the currently allowed effects are" ^ nli () ^ + code ppr_lt) + let iteration_list_body ~pos ~t1:l ~t2:(_,t) ~error:_ = build_tyvar_names [snd l; t]; fixed_type pos "The body of a list generator" t l @@ -1149,12 +1159,6 @@ end ("An orderby clause must return a list of records of base type") (expr, t) - let iteration_base_body ~pos ~t1:(expr,t) ~t2:_ ~error:_ = - build_tyvar_names [t]; - with_but pos - ("A database comprehension must return a list of records of base type") - (expr, t) - let escape ~pos ~t1:l ~t2:(_,t) ~error:_ = build_tyvar_names [snd l; t]; fixed_type pos "The argument to escape" t l @@ -3425,18 +3429,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = (* various expressions *) | Iteration (generators, body, where, orderby) -> - let is_query = - List.exists (function - | List _ -> false - | Table _ -> true) generators in - let context = - if is_query - then { context with effect_row = Types.make_empty_closed_row () } - else begin - unify ~handle:Gripers.iteration_unl_effect (no_pos (`Effect context.effect_row), no_pos (`Effect (Types.make_empty_open_row default_effect_subkind))); - context - end - in + begin + unify ~handle:Gripers.iteration_unl_effect + (no_pos (`Effect context.effect_row), + no_pos (`Effect (Types.make_empty_open_row default_effect_subkind))) + end; let generators, generator_usages, environments = List.fold_left (fun (generators, generator_usages, environments) -> @@ -3453,6 +3450,9 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = usages e :: generator_usages, pattern_env pattern :: environments) | Table (pattern, e) -> + unify ~handle:Gripers.iteration_ambient_effect + (no_pos (`Effect context.effect_row), + no_pos (`Effect (Types.make_empty_closed_row ()))); let a = `Record (Types.make_empty_open_row (lin_unl, res_base)) in let b = `Record (Types.make_empty_open_row (lin_unl, res_base)) in let c = `Record (Types.make_empty_open_row (lin_unl, res_base)) in @@ -3483,10 +3483,6 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t = (fun order -> unify ~handle:Gripers.iteration_base_order (pos_and_typ order, no_pos (`Record (Types.make_empty_open_row (lin_unl, res_base))))) orderby in - let () = - if is_query && not (Settings.get Database.relax_query_type_constraint) then - unify ~handle:Gripers.iteration_base_body - (pos_and_typ body, no_pos (Types.make_list_type (`Record (Types.make_empty_open_row (lin_unl, res_base))))) in let e = Iteration (generators, erase body, opt_map erase where, opt_map erase orderby) in let vs = List.fold_left StringSet.union StringSet.empty (List.map Env.domain environments) in let us = Usage.combine_many diff --git a/core/wrapTableIterators.ml b/core/wrapTableIterators.ml deleted file mode 100644 index d7b84c719..000000000 --- a/core/wrapTableIterators.ml +++ /dev/null @@ -1,56 +0,0 @@ -open Utility -open CommonTypes -open Sugartypes -(* - * Ensures that table iterators are wrapped in a query block: - * - * for (x <-- y) M - * ---> - * query { for (x <-- y) M } - * - * Note that since we can't "break out" of a query block, we - * do not have to perform the pass inside query blocks. - *) -class wrap_iterators env = - let open TransformSugar in - object (o : 'self_type) - inherit (TransformSugar.transform env) as super - - method! phrasenode = function - | Query (_, _, _, Some t) as q -> - (* We don't need to perform this pass inside a query block. - * Indeed, if we do, it results in nontermination. *) - (o, q, t) - | Iteration (gens, body, cond, orderby) -> - let envs = o#backup_envs in - let dp = SourceCode.WithPos.dummy in - let (o, gens) = listu o (fun o -> o#iterpatt) gens in - let (o, body, t) = o#phrase body in - let (o, cond, _) = option o (fun o -> o#phrase) cond in - let (o, orderby, _) = option o (fun o -> o#phrase) orderby in - let is_query = List.exists - (function - | List _ -> false - | Table _ -> true) gens in - let iter = Iteration (gens, body, cond, orderby) in - let node = - if is_query then - Query (None, QueryPolicy.Default, dp iter, Some t) - else - iter in - let o = o#restore_envs envs in - (o, node, t) - | p -> super#phrasenode p - end - - -let wrap_iterators env = - ((new wrap_iterators env) : wrap_iterators :> TransformSugar.transform) - -module Typeable - = Transform.Typeable.Make(struct - let name = "wrap table iterators" - let obj env = - (wrap_iterators env : TransformSugar.transform :> - Transform.Typeable.sugar_transformer) - end) diff --git a/core/wrapTableIterators.mli b/core/wrapTableIterators.mli deleted file mode 100644 index 43d025216..000000000 --- a/core/wrapTableIterators.mli +++ /dev/null @@ -1 +0,0 @@ -include Transform.Typeable.S diff --git a/examples/filter.links b/examples/filter.links index 40123e34f..cd888c404 100644 --- a/examples/filter.links +++ b/examples/filter.links @@ -133,13 +133,15 @@ fun fetchResults(pred) server { region_id : Int) from db; - for (w <-- wineTable, i <-- inventoryTable, t <-- wineTypeTable, r <-- regionTable, y <-- wineryTable) - where (w.wine_id == i.wine_id && - w.wine_type == t.wine_type_id && - w.winery_id == y.winery_id && - y.region_id == r.region_id && - pred((price=i.cost, year=w.year, wine_type=t.wine_type_id, region=r.region_id))) + query { + for (w <-- wineTable, i <-- inventoryTable, t <-- wineTypeTable, r <-- regionTable, y <-- wineryTable) + where (w.wine_id == i.wine_id && + w.wine_type == t.wine_type_id && + w.winery_id == y.winery_id && + y.region_id == r.region_id && + pred((price=i.cost, year=w.year, wine_type=t.wine_type_id, region=r.region_id))) [(name=w.wine_name, wine_type=t.wine_type, region=r.region_name, year=w.year, price=i.cost)] + } } @@ -317,14 +319,18 @@ fun fetchTypesAndRegions() server { from db; var wineTypes = - for (t <-- wineTypeTable) - where (t.wine_type <> "All") - [(id=t.wine_type_id, name=t.wine_type)]; + query { + for (t <-- wineTypeTable) + where (t.wine_type <> "All") + [(id=t.wine_type_id, name=t.wine_type)] + }; var regions = - for (r <-- regionTable) - where (r.region_name <> "All") - [(id=r.region_id, name=r.region_name)]; + query { + for (r <-- regionTable) + where (r.region_name <> "All") + [(id=r.region_id, name=r.region_name)] + }; (wineTypes, regions) } diff --git a/examples/initialise-list.links b/examples/initialise-list.links index 3c0db4979..f44e0bdda 100644 --- a/examples/initialise-list.links +++ b/examples/initialise-list.links @@ -79,7 +79,7 @@ fun insertItems(itemsTable, itemsList) { itemsList)); delete (itemEntry <-- itemsTable) where (itemEntry.i < 0 || n < itemEntry.i); - var indexes = for (itemEntry <- asList(itemsTable)) [itemEntry.i]; + var indexes = query { for (itemEntry <- asList(itemsTable)) [itemEntry.i] }; insert itemsTable values (i, name) for (i <- upto(0,n-1) `diff` indexes) [(i=i, name=sel(itemsList, i))]; diff --git a/examples/wine.links b/examples/wine.links index 4cd6ef267..749ea3994 100644 --- a/examples/wine.links +++ b/examples/wine.links @@ -116,9 +116,11 @@ fun assocd(x, l, d) { sig firstField : (TableHandle ((|r::Base), (|w::Base), (|n::Base)), ((|r)) {}-> Bool, ((|r)) {}-> a) ~e~> (a::Base) fun firstField(t, p, body) { var matches = - for (r <-- t) - where (p(r)) - [(v=body(r))]; + query { + for (r <-- t) + where (p(r)) + [(v=body(r))] + }; hd(matches).v } @@ -132,17 +134,21 @@ fun wineTypeName(wine_type_id) { fun wine_name(wine_id) { var matches = - for (wine <-- wineTable) - where (wine.wine_id == wine_id) - [(name=wine.wine_name)]; + query { + for (wine <-- wineTable) + where (wine.wine_id == wine_id) + [(name=wine.wine_name)] + }; hd(matches).name } fun get_region_name(region_id) { var matches = - for (region <-- regionTable) - where (region_id == region.region_id) - [(region=region.region_name)]; + query { + for (region <-- regionTable) + where (region_id == region.region_id) + [(region=region.region_name)] + }; hd(matches).region } @@ -156,8 +162,8 @@ fun get_wine_price(wine_id) { fun cust_id_next() { # WARNING: race condition here var ids = map((.1), - for (u <-- usersTable) - [(1=u.cust_id)]); + query { for (u <-- usersTable) + [(1=u.cust_id)]}); maximum(0, ids) + 1 } @@ -218,10 +224,12 @@ mutual { fun sign_in(order_id, username, password) { var cust_id = - for (u <-- usersTable) - where (u.user_name == username && - u.password == password) - [(1=u.cust_id)]; + query { + for (u <-- usersTable) + where (u.user_name == username && + u.password == password) + [(1=u.cust_id)] + }; if (cust_id == []) errorPage("Incorrect username/password combination") @@ -324,10 +332,12 @@ mutual { { var items = - for (item <-- cartItemsTable) + query { + for (item <-- cartItemsTable) for (wine <-- wineTable) - where (item.wine_id == wine.wine_id && item.order_id == order_id) - [(name=wine.wine_name, qty=item.qty, price=item.price)]; + where (item.wine_id == wine.wine_id && item.order_id == order_id) + [(name=wine.wine_name, qty=item.qty, price=item.price)] + }; for (item <- items) {intToXml(item.qty)} @@ -354,16 +364,19 @@ mutual { fun order_total(cust_id, order_id) { sum_float( map ((.1), - for (item <-- cartItemsTable) - where (item.cust_id == cust_id && item.order_id == order_id) - [(1=item.price *. intToFloat(item.qty))])) + query { + for (item <-- cartItemsTable) + where (item.cust_id == cust_id && item.order_id == order_id) + [(1=item.price *. intToFloat(item.qty))]})) } fun getOrder(cust_id, order_id) { var the_orders = - for (x <-- orderTable ) + query { + for (x <-- orderTable ) where (cust_id == x.cust_id && order_id == x.order_id) - [x]; + [x] + }; switch (the_orders) { case [] -> None case (order::_) -> Some(order) @@ -465,18 +478,20 @@ mutual { debug("starting cart_itemlist"); var cart_items = - for (cart_item <-- cartItemsTable) - where (cart_item.order_id == order_id && - cart_item.cust_id == cust_id) - { - for (wine <-- wineTable) - where (wine.wine_id == cart_item.wine_id) - { + query { + for (cart_item <-- cartItemsTable) + where (cart_item.order_id == order_id && + cart_item.cust_id == cust_id) + { + for (wine <-- wineTable) + where (wine.wine_id == cart_item.wine_id) + { for (cost_rec <-- inventoryTable) where (cost_rec.wine_id == wine.wine_id) [(id=cart_item.item_id, qty=cart_item.qty, name=wine.wine_name, cost=cost_rec.cost)] } + } }; debug("got results in cart_items"); @@ -565,15 +580,17 @@ mutual { sig cartStats : (Int, Int) ~> (Float, Int) fun cartStats(cust_id, order_id) { var cart_items = - for (cart_item <-- cartItemsTable) - where (cart_item.order_id == order_id && - cart_item.cust_id == cust_id) - { - for (wine <-- wineTable) - where (wine.wine_id == cart_item.wine_id) - for (cost_rec <-- inventoryTable) - where (wine.wine_id == cost_rec.wine_id) - [(cart_item.qty, cost_rec.cost)] + query { + for (cart_item <-- cartItemsTable) + where (cart_item.order_id == order_id && + cart_item.cust_id == cust_id) + { + for (wine <-- wineTable) + where (wine.wine_id == cart_item.wine_id) + for (cost_rec <-- inventoryTable) + where (wine.wine_id == cost_rec.wine_id) + [(cart_item.qty, cost_rec.cost)] + } }; var total_cost = sum_float(map(fun ((q, c)) {intToFloat(q) *. c}, cart_items)); var total_items = sum_int(map(fst, cart_items)); @@ -585,10 +602,12 @@ mutual { var price = get_wine_price(wine_id); var max_item_id = maximum(0, map ((.1), - for (cart_item <-- cartItemsTable) - where (cart_item.order_id == order_id - && cart_item.cust_id == cust_id) - [(1=cart_item.item_id)]) + query { + for (cart_item <-- cartItemsTable) + where (cart_item.order_id == order_id + && cart_item.cust_id == cust_id) + [(1=cart_item.item_id)] + }) ); var new_item_id = max_item_id + 1; @@ -613,8 +632,10 @@ mutual { # create_cart: make a new cart fun create_cart(cust_id) { var orders = - for (cart <-- shortOrderTable) - [(1=cart.order_id)]; + query { + for (cart <-- shortOrderTable) + [(1=cart.order_id)] + }; var order_id = 1 + maximum(0, map ((.1), orders)); insert (shortOrderTable) values [(cust_id = cust_id, order_id = order_id)]; @@ -665,18 +686,20 @@ mutual { fun wine_count(region_id, wine_type) { var result = - for (wine <-- wineTable) - where (wine_type == 1 || wine.wine_type == wine_type) - { - for (winery <-- wineryTable) - where (winery.winery_id == wine.winery_id - && (region_id == 1 || winery.region_id == region_id)) - { - for (cost_rec <-- inventoryTable) - where (wine.wine_id == cost_rec.wine_id) - [(wine.wine_id, wine.wine_name, cost_rec.cost, - wine.year, winery.winery_name)] - } + query { + for (wine <-- wineTable) + where (wine_type == 1 || wine.wine_type == wine_type) + { + for (winery <-- wineryTable) + where (winery.winery_id == wine.winery_id + && (region_id == 1 || winery.region_id == region_id)) + { + for (cost_rec <-- inventoryTable) + where (wine.wine_id == cost_rec.wine_id) + [(wine.wine_id, wine.wine_name, cost_rec.cost, + wine.year, winery.winery_name)] + } + } }; length(result) } @@ -711,15 +734,15 @@ mutual { diff --git a/prelude.links b/prelude.links index 081f76a06..0c3848386 100644 --- a/prelude.links +++ b/prelude.links @@ -481,6 +481,7 @@ fun isInt (x) { x =~ /-?[0-9]+$/ } sig isFloat : (String) -> Bool fun isFloat (x) { x =~ /-?[0-9]+(\.[0-9]+)?$/ } +sig asList : (TableHandle((|a::Base),(|_::Base),(|_::Base))) {}-> [(|a::Base)] fun asList(t) server { for (x <-- t) [x] } diff --git a/tests/database/factorials.links b/tests/database/factorials.links index c23557241..280a1bfdd 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -55,6 +55,14 @@ fun unwrappedLookup(n) server { [(i=row.i, f=row.f)] } +fun trivialNested1() server { + query { for (y <- for (x <-- factorials) [(b=[])]) [(a=0)]} +} + +fun trivialNested2() server { + query { for (y <- for (x <- asList( factorials)) [(b=[])]) [(a=0)]} +} + fun test() { deleteAll(); assertEq(lookupFactorials(10), []); @@ -72,10 +80,12 @@ fun test() { assertEq(lookupFactorials(10), []); insertOne(); assertEq(lookupFactorials(1), [(f=1,i=1)]); - assertEq(unwrappedLookup(1), [(f=1,i=1)]); + assertEq(query{unwrappedLookup(1)}, [(f=1,i=1)]); insertTwoThree(); ## The order is wrong. assertEq(lookupFactorials(3), [(i=1, f=1), (i=2, f=2), (f=6,i=3)]); + assertEq(trivialNested1(),[(a=0),(a=0)]); + assertEq(trivialNested2(),[(a=0),(a=0)]); } test() diff --git a/tests/database/xpath.links b/tests/database/xpath.links index 115ca8aea..277693f8f 100644 --- a/tests/database/xpath.links +++ b/tests/database/xpath.links @@ -42,7 +42,7 @@ fun axis(ax) { } } -sig path : (Path) ~> (Node, Node) -> Bool +sig path : (Path) ~> (Node, Node) {}-> Bool fun path(p: Path) { switch (p) { case Seq(p, q) -> diff --git a/tests/records.tests b/tests/records.tests index 8edce7b4e..9786ed216 100644 --- a/tests/records.tests +++ b/tests/records.tests @@ -70,7 +70,7 @@ exit : 1 Tables must have table type. fun (t) { for (x <-- t) [(a=x.y)] } -stdout : @fun : \(TableHandle\(.*\)\) -> .* +stdout : @fun : \(TableHandle\(.*\)\) {}-> .* Duplicate fields (x=3,x=3) diff --git a/tests/shredding/config.sample b/tests/shredding/config.sample index 926d0bb8c..b8b88d7f9 100644 --- a/tests/shredding/config.sample +++ b/tests/shredding/config.sample @@ -1,5 +1,4 @@ database_driver=postgresql database_args=localhost:5432::links show_pre_sugar_typing=off -relax_query_type_constraint=on shredding=on diff --git a/tests/shredding/jrules.links b/tests/shredding/jrules.links index 3fdafa349..e431f3a23 100644 --- a/tests/shredding/jrules.links +++ b/tests/shredding/jrules.links @@ -28,8 +28,10 @@ var mc = sig marketers : () -> [(name:String, clients:[Int])] fun marketers () { - for (m <-- marketers_names) + query { + for (m <-- marketers_names) [(name=m.name, clients = for (x <-- mc) where (x.m == m.name) [x.c])] + } } sig u : () -> [((id:Int), [String])] From eade47f840d331d56fa4281eb593d716d5f41210 Mon Sep 17 00:00:00 2001 From: Simon Fowler Date: Mon, 22 Jun 2020 14:04:12 +0100 Subject: [PATCH 17/28] Fix CI (#857) (Bad Simon.) --- tests/shredding/jrules.links | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/shredding/jrules.links b/tests/shredding/jrules.links index e431f3a23..75e439bb3 100644 --- a/tests/shredding/jrules.links +++ b/tests/shredding/jrules.links @@ -55,8 +55,10 @@ fun v () { sig marketers2 : () -> [(name:String, clients:[Int])] fun marketers2 () { - for (m <-- marketers_names) - [(name=m.name, clients = for (x <-- mc) where (x.m == m.name && x.m =~ /a/) [x.c])] + query { + for (m <-- marketers_names) + [(name=m.name, clients = for (x <-- mc) where (x.m == m.name && x.m =~ /a/) [x.c])] + } } fun test() { From 108062620afb6c4a48479a61028c1ee0e606cdc1 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 15 Jun 2020 10:50:18 +0100 Subject: [PATCH 18/28] reorganize factorials example to workaroune mysql-dependent behavior add -linkall flag which makes mysql plugin happy again --- tests/database/factorials.links | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/database/factorials.links b/tests/database/factorials.links index 280a1bfdd..31899a365 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -69,9 +69,15 @@ fun test() { assertEq(insertReturningOne(), 1); assertEq(lookupFactorials(10), [(f=1,i=1)]); assertEq(insertReturningTwo(), 2); +<<<<<<< HEAD assertEq(lookupFactorials(10), [(f=1,i=1),(f=2,i=2)]); updateTwoThree(); assertEq(lookupFactorials(10), [(f=1,i=1),(f=3,i=2)]); +======= + assertEq(lookupFactorials(10), [(f=2,i=2),(f=1,i=1)]); + updateTwoThree(); + assertEq(lookupFactorials(10), [(f=3,i=2),(f=1,i=1)]); +>>>>>>> reorganize factorials example to workaroune mysql-dependent behavior deleteAll(); insertOne(); deleteAll(); From 1f77cc331a8afe55b517b6fbaa344d89cf6bc0dc Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 15 Jun 2020 10:59:20 +0100 Subject: [PATCH 19/28] whitespace --- core/value.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/value.ml b/core/value.ml index 66536c186..30ae8ce86 100644 --- a/core/value.ml +++ b/core/value.ml @@ -1106,3 +1106,5 @@ let row_columns_values v = | v -> raise (type_error ~action:"form query row from" "list" v) in (row_columns v, row_values v) + + From 2918736974888c615bba895dab7cf16b2fac6a29 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 14:04:50 +0100 Subject: [PATCH 20/28] add configs for other drivers cleanup fix of ordering --- database/pg-driver/pg_database.ml | 1 - tests/database/factorials.links | 6 ------ 2 files changed, 7 deletions(-) diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index 509897116..f7364abcd 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -188,4 +188,3 @@ let get_pg_database_by_string args = failwith "Insufficient arguments when establishing postgresql connection" let _ = Value.register_driver (driver_name, get_pg_database_by_string) - diff --git a/tests/database/factorials.links b/tests/database/factorials.links index 31899a365..280a1bfdd 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -69,15 +69,9 @@ fun test() { assertEq(insertReturningOne(), 1); assertEq(lookupFactorials(10), [(f=1,i=1)]); assertEq(insertReturningTwo(), 2); -<<<<<<< HEAD assertEq(lookupFactorials(10), [(f=1,i=1),(f=2,i=2)]); updateTwoThree(); assertEq(lookupFactorials(10), [(f=1,i=1),(f=3,i=2)]); -======= - assertEq(lookupFactorials(10), [(f=2,i=2),(f=1,i=1)]); - updateTwoThree(); - assertEq(lookupFactorials(10), [(f=3,i=2),(f=1,i=1)]); ->>>>>>> reorganize factorials example to workaroune mysql-dependent behavior deleteAll(); insertOne(); deleteAll(); From af7104f1f84cf1c2fca2eb837e0b01d228229b5a Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 17:02:00 +0100 Subject: [PATCH 21/28] update factorial example remove relax query type constraint flag --- examples/relational_lenses/config | 1 - examples/relational_lenses/config.sample | 1 - tests/database/factorials.links | 4 ++-- tests/relational-lenses/config.sample | 1 - 4 files changed, 2 insertions(+), 5 deletions(-) diff --git a/examples/relational_lenses/config b/examples/relational_lenses/config index ea0bb44ee..4e1505bc0 100644 --- a/examples/relational_lenses/config +++ b/examples/relational_lenses/config @@ -1,5 +1,4 @@ database_args=localhost:5432:links:links database_driver=postgresql -relax_query_type_constraint=on shredding=on relational_lenses=on diff --git a/examples/relational_lenses/config.sample b/examples/relational_lenses/config.sample index 0062db4d9..15c9a3120 100644 --- a/examples/relational_lenses/config.sample +++ b/examples/relational_lenses/config.sample @@ -1,5 +1,4 @@ database_args=localhost:5432::links database_driver=postgresql -relax_query_type_constraint=on shredding=on relational_lenses=on diff --git a/tests/database/factorials.links b/tests/database/factorials.links index 280a1bfdd..0438c3be3 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -84,8 +84,8 @@ fun test() { insertTwoThree(); ## The order is wrong. assertEq(lookupFactorials(3), [(i=1, f=1), (i=2, f=2), (f=6,i=3)]); - assertEq(trivialNested1(),[(a=0),(a=0)]); - assertEq(trivialNested2(),[(a=0),(a=0)]); + assertEq(trivialNested1(),[(a=0),(a=0),(a=0)]); + assertEq(trivialNested2(),[(a=0),(a=0),(a=0)]); } test() diff --git a/tests/relational-lenses/config.sample b/tests/relational-lenses/config.sample index 2264904bd..9a6880148 100644 --- a/tests/relational-lenses/config.sample +++ b/tests/relational-lenses/config.sample @@ -1,5 +1,4 @@ database_driver=postgresql database_args=localhost:5432::links show_pre_sugar_typing=off -relax_query_type_constraint=on relational_lenses=on From 00e63c53ae2a1d44fede1362ac978728c93d2028 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Mon, 22 Jun 2020 17:04:49 +0100 Subject: [PATCH 22/28] remove comment documenting ordering problem that is now fixed --- tests/database/factorials.links | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/database/factorials.links b/tests/database/factorials.links index 0438c3be3..2264d237c 100644 --- a/tests/database/factorials.links +++ b/tests/database/factorials.links @@ -82,7 +82,6 @@ fun test() { assertEq(lookupFactorials(1), [(f=1,i=1)]); assertEq(query{unwrappedLookup(1)}, [(f=1,i=1)]); insertTwoThree(); - ## The order is wrong. assertEq(lookupFactorials(3), [(i=1, f=1), (i=2, f=2), (f=6,i=3)]); assertEq(trivialNested1(),[(a=0),(a=0),(a=0)]); assertEq(trivialNested2(),[(a=0),(a=0),(a=0)]); From 900ac1eb36d0ea8d24f072fc278b757ae04cb51c Mon Sep 17 00:00:00 2001 From: James Cheney Date: Tue, 23 Jun 2020 15:59:04 +0100 Subject: [PATCH 23/28] clear away dead code add efficient polymorphic append-only buffers avoid need for extra list reverse in sqlite3 add test that large database results can be obtained (constructing lists whose length > OCaml's stack bound) fix performance bug in mysql driver --- core/database.ml | 17 +++--- core/database.mli | 3 +- core/utility.ml | 63 +++++++++++++++++++++++ core/value.ml | 38 ++++++++------ core/value.mli | 2 +- database/mysql-driver/mysql_database.ml | 45 ++++++++++++++-- database/pg-driver/pg_database.ml | 2 +- database/sqlite3-driver/lite3_database.ml | 34 ++++++------ tests/database/config.mysql | 1 - tests/database/testsuite.config | 1 + 10 files changed, 156 insertions(+), 50 deletions(-) diff --git a/core/database.ml b/core/database.ml index 123f1c92b..0de6f96b5 100644 --- a/core/database.ml +++ b/core/database.ml @@ -1,4 +1,4 @@ -open List +(* XXX open List*) open CommonTypes open Utility @@ -91,13 +91,10 @@ let execute_insert_returning returning q db = begin match result#status with | `QueryOk -> - let rows = result#get_all_lst in - begin - match rows with - | [[id]] -> Value.box_int (int_of_string id) - | _ -> - raise (runtime_error ("Returned the wrong number of results executing " ^ q)) - end + if result#nfields == 1 && result#ntuples == 1 + then (* returning field has to be of type int *) + Value.box_int (int_of_string (result#getvalue 0 0)) + else raise (runtime_error ("Returned the wrong number of results executing " ^ q)) | `QueryError msg -> raise (runtime_error ("An error occurred executing the query " ^ q ^ ": " ^ msg)) end @@ -149,8 +146,6 @@ let result_signature field_types result = in build rs [] -(* BUG: Lists can be too big for List.map; need to be careful about recursion *) - let execute_select_result (field_types:(string * Types.datatype) list) (query:string) (db: database) = let _ = Debug.print ("Running query: \n" ^ query) in @@ -176,6 +171,7 @@ let execute_select build_result (result,rs) +(* XXX let execute_untyped_select (query:string) (db: database) : Value.t = let result = (db#exec query) in (match result#status with @@ -183,3 +179,4 @@ let execute_untyped_select (query:string) (db: database) : Value.t = `List (map (fun row -> `List (map Value.box_string row)) result#get_all_lst) | `QueryError msg -> raise (runtime_error ("An error occurred executing the query " ^ query ^ ": " ^ msg))) +*) \ No newline at end of file diff --git a/core/database.mli b/core/database.mli index 58fdc6789..0e75e223d 100644 --- a/core/database.mli +++ b/core/database.mli @@ -23,7 +23,6 @@ val build_result : Value.dbvalue * (string * (Types.datatype * int)) list -> Val fieldname -> fieldtype. *) val execute_select : (string * Types.datatype) list -> string -> Value.database -> Value.t -val execute_untyped_select : string -> Value.database -> Value.t +(* XXX val execute_untyped_select : string -> Value.database -> Value.t*) val execute_insert_returning : string -> Sql.query -> Value.database -> Value.t - diff --git a/core/utility.ml b/core/utility.ml index 7ddbd26b5..f245e80bb 100644 --- a/core/utility.ml +++ b/core/utility.ml @@ -1458,3 +1458,66 @@ struct (sequence xs) >>= fun xs -> Lwt.return (x :: xs) end + + +(* efficient polymorphic buffers *) +(* builds an array of n pages of size m, with some initial dummy value *) +(* allows random access reading/writing and appending at the end *) +module PolyBuffer : sig + type 'a buf + val init : int -> int -> 'a -> 'a buf + val length : 'a buf -> int + val get : 'a buf -> int -> 'a + val set : 'a buf -> int -> 'a -> unit + val append : 'a buf -> 'a -> unit + val to_list : 'a buf -> 'a list +end = +struct + type 'a buf = {mutable numpages: int; + pagesize: int; + default: 'a; + mutable currpage: int; + mutable nextitem: int; + mutable pages:'a + array array} + + let init n m x = {numpages = n; + pagesize = m; + default = x; + currpage = 0; + nextitem = 0; + pages = Array.init n (fun _ -> Array.init m (fun _ -> x)) } + + let length buf = buf.currpage*buf.pagesize + buf.nextitem + + let set buf i x = + if 0 <= i && i < buf.currpage*buf.pagesize + buf.nextitem + then Array.set (Array.get buf.pages (i/buf.pagesize)) (i mod buf.pagesize) x + else raise Not_found + + let get buf i = + if 0 <= i && i < buf.currpage*buf.pagesize + buf.nextitem + then Array.get (Array.get buf.pages (i/buf.pagesize)) (i mod buf.pagesize) + else raise Not_found + + let append buf x = + (* first, check if there is enough space or allocation is needed *) + if (buf.nextitem == buf.pagesize) + then begin + buf.nextitem <- 0; + buf.currpage <- buf.currpage+1; + if (buf.currpage == buf.numpages) + then begin (* need to allocate a new page and copy over *) + buf.numpages <- buf.numpages+1; + let newpages = Array.init buf.numpages (fun i -> + if i < Array.length(buf.pages) + then Array.get buf.pages i + else Array.init buf.pagesize (fun _ -> buf.default)) in + buf.pages <- newpages + end + end; + Array.set (Array.get buf.pages buf.currpage) buf.nextitem x; + buf.nextitem <- buf.nextitem + 1 + + let to_list buf = List.init (length buf) (get buf) +end diff --git a/core/value.ml b/core/value.ml index 30ae8ce86..69f5a0a98 100644 --- a/core/value.ml +++ b/core/value.ml @@ -36,34 +36,38 @@ class virtual dbvalue = object (self) method virtual nfields : int method virtual ntuples : int method virtual fname : int -> string - method virtual get_all_lst : string list list + (* XXXmethod virtual get_all_lst : string list list*) method map : 'a. ((int -> string) -> 'a) -> 'a list = fun f -> + (* XXX let max = self#ntuples in let rec do_map n acc = - if n < max - then ( - do_map (n+1) (f (self#getvalue n)::acc) - ) - else acc + if n < max + then ( + do_map (n+1) (f (self#getvalue n)::acc) + ) + else acc in List.rev (do_map 0 []) + *) + List.init (self#ntuples) (fun i -> f (self#getvalue i)) method map_array : 'a. (string array -> 'a) -> 'a list = fun f -> let max = self#ntuples in let rec do_map n acc = - if n < max - then ( - do_map (n+1) (f (self#gettuple n)::acc) - ) - else acc + if n < max + then ( + do_map (n+1) (f (self#gettuple n)::acc) + ) + else acc in List.rev (do_map 0 []) method fold_array : 'a. (string array -> 'a -> 'a) -> 'a -> 'a = fun f x -> let max = self#ntuples in let rec do_fold n acc = - if n < max - then ( - do_fold (n+1) (f (self#gettuple n) acc) - ) - else acc - in do_fold 0 x method virtual map : 'a. ((int -> string) -> 'a) -> 'a list + if n < max + then ( + do_fold (n+1) (f (self#gettuple n) acc) + ) + else acc + in do_fold 0 x + method virtual map : 'a. ((int -> string) -> 'a) -> 'a list method virtual getvalue : int -> int -> string method virtual gettuple : int -> string array method virtual error : string diff --git a/core/value.mli b/core/value.mli index afed159ac..c22fb2e03 100644 --- a/core/value.mli +++ b/core/value.mli @@ -11,7 +11,7 @@ class virtual dbvalue : object method virtual error : string method virtual fname : int -> string - method virtual get_all_lst : string list list + (* XXX method virtual get_all_lst : string list list *) method virtual nfields : int method virtual ntuples : int method map : 'a. ((int -> string) -> 'a) -> 'a list diff --git a/database/mysql-driver/mysql_database.ml b/database/mysql-driver/mysql_database.ml index b1c18a0a5..dd918faf6 100644 --- a/database/mysql-driver/mysql_database.ml +++ b/database/mysql-driver/mysql_database.ml @@ -203,6 +203,45 @@ object method show = pretty_type thing end +let iterUntilNone (fn : unit -> 'b option) (g : 'b -> unit) : unit = + let rec iterate () = + match fn () with + | None -> () + | Some value -> g value; iterate() + in + iterate () + + +class mysql_result (result : result) db = object + inherit Value.dbvalue + val result_buf = + if size result > Int64.of_int(0) + then let buf = PolyBuffer.init 1 1024 (Array.init 0 (fun _ -> None)) in + iterUntilNone (fun () -> fetch result) (PolyBuffer.append buf); + buf + else PolyBuffer.init 0 1 (Array.init 0 (fun _ -> None)) + method status : Value.db_status = + match status db with + | StatusOK | StatusEmpty -> `QueryOk + | StatusError c -> `QueryError (string_of_error_code c) + method nfields : int = + fields result + method ntuples : int = + Int64.to_int(size result) + method fname n : string = + (Utility.val_of (fetch_field_dir result n)).name + method getvalue : int -> int -> string = fun n f -> + let row = PolyBuffer.get result_buf n in + Utility.val_of (row.(f)) + method gettuple : int -> string array = fun n -> + let row = PolyBuffer.get result_buf n in + Array.map Utility.val_of row + method error : string = + Utility.val_of (errmsg db) +end + +(* XXX + let slurp (fn : 'a -> 'b option) (source : 'a) : 'b list = let rec obtain output = match fn source with @@ -224,7 +263,7 @@ class mysql_result (result : result) db = object Int64.to_int(size result) method fname n : string = (Utility.val_of (fetch_field_dir result n)).name - method get_all_lst : string list list = + (* XXX method get_all_lst : string list list = match !rows with | None -> let toList row = @@ -233,7 +272,7 @@ class mysql_result (result : result) db = object in rows := Some r; r - | Some r -> r + | Some r -> r*) method getvalue : int -> int -> string = fun n f -> to_row result (Int64.of_int n); Utility.val_of ((Utility.val_of (fetch result)).(f)) @@ -242,7 +281,7 @@ class mysql_result (result : result) db = object Array.map Utility.val_of (Utility.val_of(fetch result)) method error : string = Utility.val_of (errmsg db) -end +end *) class mysql_database spec = object(self) inherit Value.database diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index f7364abcd..cb5540be6 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -91,7 +91,7 @@ class pg_dbresult (pgresult:Postgresql.result) = object method nfields : int = original#nfields method ntuples : int = original#ntuples method fname : int -> string = original#fname - method get_all_lst : string list list = pgresult#get_all_lst + (*method get_all_lst : string list list = pgresult#get_all_lst*) method getvalue : int -> int -> string = pgresult#getvalue method gettuple : int -> string array = pgresult#get_tuple method error : string = original#error diff --git a/database/sqlite3-driver/lite3_database.ml b/database/sqlite3-driver/lite3_database.ml index dec5fc15f..c958bfe5a 100644 --- a/database/sqlite3-driver/lite3_database.ml +++ b/database/sqlite3-driver/lite3_database.ml @@ -45,37 +45,41 @@ let data_to_string data = | Data.TEXT s | Data.BLOB s -> s ;; + + class lite3_result (stmt: stmt) = object inherit Value.dbvalue - val result_list_and_status = - let rec get_results (results,status) = + + val result_buf_and_status = + let result_buf = PolyBuffer.init 1 1024 [] in + let rec get_results (status) = match status with `QueryOk -> ( match step stmt with Rc.OK|Rc.ROW -> let data = Array.to_list (row_data stmt) in let row = List.map data_to_string data in - get_results (row::results,`QueryOk ) + PolyBuffer.append result_buf row; + get_results `QueryOk | Rc.DONE -> - results,`QueryOk - | e -> results, `QueryError (error_as_string e) + `QueryOk + | e -> `QueryError (error_as_string e) ) - | _ -> (results,status) + | _ -> (status) in - let results,status = get_results ([],`QueryOk) in - (List.rev results, status) + (result_buf,get_results (`QueryOk)) - method status : Value.db_status = snd(result_list_and_status) - method nfields : int = column_count stmt - method ntuples : int = List.length (fst result_list_and_status) + method status : Value.db_status = snd(result_buf_and_status) + method nfields : int = column_count stmt + method ntuples : int = PolyBuffer.length (fst result_buf_and_status) method fname n : string = column_name stmt n - method get_all_lst : string list list = fst(result_list_and_status) + (*method get_all_lst : string list list = PolyBuffer.to_list (fst result_buf_and_status)*) method getvalue : int -> int -> string = fun n i -> - List.nth(List.nth (fst(result_list_and_status)) n) i + List.nth(PolyBuffer.get (fst result_buf_and_status) n) i method gettuple : int -> string array = fun n -> - Array.of_list(List.nth (fst(result_list_and_status)) n) + Array.of_list(PolyBuffer.get (fst result_buf_and_status) n) method error : string = - match snd(result_list_and_status) with + match (snd result_buf_and_status) with `QueryError(msg) -> msg | `QueryOk -> "OK" end diff --git a/tests/database/config.mysql b/tests/database/config.mysql index eddbd91bb..8a8dcc5f2 100644 --- a/tests/database/config.mysql +++ b/tests/database/config.mysql @@ -1,3 +1,2 @@ database_driver=mysql database_args=localhost:3306:links:12345 - diff --git a/tests/database/testsuite.config b/tests/database/testsuite.config index a7b5edf32..833331eb5 100644 --- a/tests/database/testsuite.config +++ b/tests/database/testsuite.config @@ -1,4 +1,5 @@ factorials +factorials-large empty emptyfun unit From 2d33be8e559fdbc3157c82b5574b38d21cb006f5 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Tue, 23 Jun 2020 16:22:35 +0100 Subject: [PATCH 24/28] remove dead code and whitespace --- core/database.ml | 16 ++------- core/database.mli | 2 -- core/utility.ml | 22 ++++++------- core/value.ml | 4 +-- core/value.mli | 1 - database/mysql-driver/mysql_database.ml | 43 ------------------------- database/pg-driver/pg_database.ml | 1 - 7 files changed, 15 insertions(+), 74 deletions(-) diff --git a/core/database.ml b/core/database.ml index 0de6f96b5..676d7cbda 100644 --- a/core/database.ml +++ b/core/database.ml @@ -1,4 +1,3 @@ -(* XXX open List*) open CommonTypes open Utility @@ -91,9 +90,9 @@ let execute_insert_returning returning q db = begin match result#status with | `QueryOk -> - if result#nfields == 1 && result#ntuples == 1 + if result#nfields == 1 && result#ntuples == 1 then (* returning field has to be of type int *) - Value.box_int (int_of_string (result#getvalue 0 0)) + Value.box_int (int_of_string (result#getvalue 0 0)) else raise (runtime_error ("Returned the wrong number of results executing " ^ q)) | `QueryError msg -> raise (runtime_error ("An error occurred executing the query " ^ q ^ ": " ^ msg)) @@ -169,14 +168,3 @@ let execute_select : Value.t = let result,rs = execute_select_result field_types query db in build_result (result,rs) - - -(* XXX -let execute_untyped_select (query:string) (db: database) : Value.t = - let result = (db#exec query) in - (match result#status with - | `QueryOk -> - `List (map (fun row -> `List (map Value.box_string row)) result#get_all_lst) - | `QueryError msg -> - raise (runtime_error ("An error occurred executing the query " ^ query ^ ": " ^ msg))) -*) \ No newline at end of file diff --git a/core/database.mli b/core/database.mli index 0e75e223d..730a6321b 100644 --- a/core/database.mli +++ b/core/database.mli @@ -23,6 +23,4 @@ val build_result : Value.dbvalue * (string * (Types.datatype * int)) list -> Val fieldname -> fieldtype. *) val execute_select : (string * Types.datatype) list -> string -> Value.database -> Value.t -(* XXX val execute_untyped_select : string -> Value.database -> Value.t*) - val execute_insert_returning : string -> Sql.query -> Value.database -> Value.t diff --git a/core/utility.ml b/core/utility.ml index f245e80bb..1f4c4be76 100644 --- a/core/utility.ml +++ b/core/utility.ml @@ -1463,7 +1463,7 @@ end (* efficient polymorphic buffers *) (* builds an array of n pages of size m, with some initial dummy value *) (* allows random access reading/writing and appending at the end *) -module PolyBuffer : sig +module PolyBuffer : sig type 'a buf val init : int -> int -> 'a -> 'a buf val length : 'a buf -> int @@ -1471,14 +1471,14 @@ module PolyBuffer : sig val set : 'a buf -> int -> 'a -> unit val append : 'a buf -> 'a -> unit val to_list : 'a buf -> 'a list -end = +end = struct type 'a buf = {mutable numpages: int; pagesize: int; default: 'a; - mutable currpage: int; - mutable nextitem: int; - mutable pages:'a + mutable currpage: int; + mutable nextitem: int; + mutable pages:'a array array} let init n m x = {numpages = n; @@ -1494,23 +1494,23 @@ struct if 0 <= i && i < buf.currpage*buf.pagesize + buf.nextitem then Array.set (Array.get buf.pages (i/buf.pagesize)) (i mod buf.pagesize) x else raise Not_found - - let get buf i = + + let get buf i = if 0 <= i && i < buf.currpage*buf.pagesize + buf.nextitem then Array.get (Array.get buf.pages (i/buf.pagesize)) (i mod buf.pagesize) else raise Not_found - let append buf x = + let append buf x = (* first, check if there is enough space or allocation is needed *) if (buf.nextitem == buf.pagesize) - then begin + then begin buf.nextitem <- 0; buf.currpage <- buf.currpage+1; - if (buf.currpage == buf.numpages) + if (buf.currpage == buf.numpages) then begin (* need to allocate a new page and copy over *) buf.numpages <- buf.numpages+1; let newpages = Array.init buf.numpages (fun i -> - if i < Array.length(buf.pages) + if i < Array.length(buf.pages) then Array.get buf.pages i else Array.init buf.pagesize (fun _ -> buf.default)) in buf.pages <- newpages diff --git a/core/value.ml b/core/value.ml index 69f5a0a98..a89655acc 100644 --- a/core/value.ml +++ b/core/value.ml @@ -66,8 +66,8 @@ class virtual dbvalue = object (self) do_fold (n+1) (f (self#gettuple n) acc) ) else acc - in do_fold 0 x - method virtual map : 'a. ((int -> string) -> 'a) -> 'a list + in do_fold 0 x +(* method virtual map : 'a. ((int -> string) -> 'a) -> 'a list*) method virtual getvalue : int -> int -> string method virtual gettuple : int -> string array method virtual error : string diff --git a/core/value.mli b/core/value.mli index c22fb2e03..c8234d4e8 100644 --- a/core/value.mli +++ b/core/value.mli @@ -11,7 +11,6 @@ class virtual dbvalue : object method virtual error : string method virtual fname : int -> string - (* XXX method virtual get_all_lst : string list list *) method virtual nfields : int method virtual ntuples : int method map : 'a. ((int -> string) -> 'a) -> 'a list diff --git a/database/mysql-driver/mysql_database.ml b/database/mysql-driver/mysql_database.ml index dd918faf6..16ea6e088 100644 --- a/database/mysql-driver/mysql_database.ml +++ b/database/mysql-driver/mysql_database.ml @@ -240,49 +240,6 @@ class mysql_result (result : result) db = object Utility.val_of (errmsg db) end -(* XXX - -let slurp (fn : 'a -> 'b option) (source : 'a) : 'b list = - let rec obtain output = - match fn source with - | None -> output - | Some value -> obtain (value :: output) - in - List.rev (obtain []) - -class mysql_result (result : result) db = object - inherit Value.dbvalue - val rows = ref None - method status : Value.db_status = - match status db with - | StatusOK | StatusEmpty -> `QueryOk - | StatusError c -> `QueryError (string_of_error_code c) - method nfields : int = - fields result - method ntuples : int = - Int64.to_int(size result) - method fname n : string = - (Utility.val_of (fetch_field_dir result n)).name - (* XXX method get_all_lst : string list list = - match !rows with - | None -> - let toList row = - List.map (Utility.from_option "!!NULL!!") (Array.to_list row) in - let r = List.map toList (slurp fetch result) - in - rows := Some r; - r - | Some r -> r*) - method getvalue : int -> int -> string = fun n f -> - to_row result (Int64.of_int n); - Utility.val_of ((Utility.val_of (fetch result)).(f)) - method gettuple : int -> string array = fun n -> - to_row result (Int64.of_int n); - Array.map Utility.val_of (Utility.val_of(fetch result)) - method error : string = - Utility.val_of (errmsg db) -end *) - class mysql_database spec = object(self) inherit Value.database val connection = connect spec diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index cb5540be6..939980199 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -91,7 +91,6 @@ class pg_dbresult (pgresult:Postgresql.result) = object method nfields : int = original#nfields method ntuples : int = original#ntuples method fname : int -> string = original#fname - (*method get_all_lst : string list list = pgresult#get_all_lst*) method getvalue : int -> int -> string = pgresult#getvalue method gettuple : int -> string array = pgresult#get_tuple method error : string = original#error From 3b5bc128dd782c4ef3dfc61c642b56efe12151b3 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Tue, 23 Jun 2020 16:47:05 +0100 Subject: [PATCH 25/28] whitespace and additional dead code removal add missing test file --- core/database.mli | 1 + core/value.ml | 21 +--------------- database/mysql-driver/mysql_database.ml | 12 ++++----- database/sqlite3-driver/lite3_database.ml | 2 ++ tests/database/factorials-large.links | 30 +++++++++++++++++++++++ 5 files changed, 40 insertions(+), 26 deletions(-) create mode 100644 tests/database/factorials-large.links diff --git a/core/database.mli b/core/database.mli index 730a6321b..98f6d0e79 100644 --- a/core/database.mli +++ b/core/database.mli @@ -24,3 +24,4 @@ val build_result : Value.dbvalue * (string * (Types.datatype * int)) list -> Val val execute_select : (string * Types.datatype) list -> string -> Value.database -> Value.t val execute_insert_returning : string -> Sql.query -> Value.database -> Value.t + diff --git a/core/value.ml b/core/value.ml index a89655acc..5db08e45b 100644 --- a/core/value.ml +++ b/core/value.ml @@ -36,28 +36,10 @@ class virtual dbvalue = object (self) method virtual nfields : int method virtual ntuples : int method virtual fname : int -> string - (* XXXmethod virtual get_all_lst : string list list*) method map : 'a. ((int -> string) -> 'a) -> 'a list = fun f -> - (* XXX - let max = self#ntuples in - let rec do_map n acc = - if n < max - then ( - do_map (n+1) (f (self#getvalue n)::acc) - ) - else acc - in List.rev (do_map 0 []) - *) List.init (self#ntuples) (fun i -> f (self#getvalue i)) method map_array : 'a. (string array -> 'a) -> 'a list = fun f -> - let max = self#ntuples in - let rec do_map n acc = - if n < max - then ( - do_map (n+1) (f (self#gettuple n)::acc) - ) - else acc - in List.rev (do_map 0 []) + List.init (self#ntuples) (fun i -> f (self#gettuple i)) method fold_array : 'a. (string array -> 'a -> 'a) -> 'a -> 'a = fun f x -> let max = self#ntuples in let rec do_fold n acc = @@ -67,7 +49,6 @@ class virtual dbvalue = object (self) ) else acc in do_fold 0 x -(* method virtual map : 'a. ((int -> string) -> 'a) -> 'a list*) method virtual getvalue : int -> int -> string method virtual gettuple : int -> string array method virtual error : string diff --git a/database/mysql-driver/mysql_database.ml b/database/mysql-driver/mysql_database.ml index 16ea6e088..13c403e40 100644 --- a/database/mysql-driver/mysql_database.ml +++ b/database/mysql-driver/mysql_database.ml @@ -211,7 +211,6 @@ let iterUntilNone (fn : unit -> 'b option) (g : 'b -> unit) : unit = in iterate () - class mysql_result (result : result) db = object inherit Value.dbvalue val result_buf = @@ -221,9 +220,9 @@ class mysql_result (result : result) db = object buf else PolyBuffer.init 0 1 (Array.init 0 (fun _ -> None)) method status : Value.db_status = - match status db with - | StatusOK | StatusEmpty -> `QueryOk - | StatusError c -> `QueryError (string_of_error_code c) + match status db with + | StatusOK | StatusEmpty -> `QueryOk + | StatusError c -> `QueryError (string_of_error_code c) method nfields : int = fields result method ntuples : int = @@ -232,10 +231,11 @@ class mysql_result (result : result) db = object (Utility.val_of (fetch_field_dir result n)).name method getvalue : int -> int -> string = fun n f -> let row = PolyBuffer.get result_buf n in - Utility.val_of (row.(f)) +(* TODO: Handle nulls better *) + Utility.from_option "" (row.(f)) method gettuple : int -> string array = fun n -> let row = PolyBuffer.get result_buf n in - Array.map Utility.val_of row + Array.map (Utility.from_option "") row method error : string = Utility.val_of (errmsg db) end diff --git a/database/sqlite3-driver/lite3_database.ml b/database/sqlite3-driver/lite3_database.ml index c958bfe5a..bf5970d95 100644 --- a/database/sqlite3-driver/lite3_database.ml +++ b/database/sqlite3-driver/lite3_database.ml @@ -36,6 +36,8 @@ let error_as_string = function | Rc.DONE -> "done" | Rc.UNKNOWN e -> "unknown: "^ string_of_int (Rc.int_of_unknown e) + +(* TODO: Better NULL handling *) let data_to_string data = match data with Data.NONE -> "" diff --git a/tests/database/factorials-large.links b/tests/database/factorials-large.links new file mode 100644 index 000000000..450ae1243 --- /dev/null +++ b/tests/database/factorials-large.links @@ -0,0 +1,30 @@ +var db = database "links"; +var factorials = table "factorials" with (i : Int, f : Int) from db; + +fun fact (n) { + if (n == 0) {1} + else {if (n == 1) {1} + else {n*fact(n-1)} + } +} + +fun insertL(l) { + delete (x <-- factorials); + for (i <- l) { + insert factorials + values (f, i) + [(i=i,f=fact(i))]; + [] + } +} + +var asdf = insertL([0..511]); + +fun double (l) { + for (x <- l, y <- l) + [(a=1)] +} +# build a result larger than ocaml stack bound +assertEq( + length(query { double(asList(factorials))}), + 262144) \ No newline at end of file From 02af3b803446bfe19817406ca2cd2d7808888fc9 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Tue, 23 Jun 2020 16:57:19 +0100 Subject: [PATCH 26/28] Comment signposting NULL handling --- database/pg-driver/pg_database.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index 939980199..707fcca9b 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -91,6 +91,7 @@ class pg_dbresult (pgresult:Postgresql.result) = object method nfields : int = original#nfields method ntuples : int = original#ntuples method fname : int -> string = original#fname + (*TODO: better handling of NULLs *) method getvalue : int -> int -> string = pgresult#getvalue method gettuple : int -> string array = pgresult#get_tuple method error : string = original#error From 13c3e5f0599d1aadc5d6f2e4dae819fd90fe7fc2 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Tue, 23 Jun 2020 17:39:13 +0100 Subject: [PATCH 27/28] add test for null integer handling --- database/pg-driver/pg_database.ml | 1 + tests/database/config.mysql | 2 ++ tests/database/config.pgsql | 2 ++ tests/database/config.sample | 2 ++ tests/database/config.sqlite3 | 3 ++- tests/database/null.links | 4 ++++ tests/database/null.sql | 9 +++++++++ tests/database/testsuite.config | 1 + 8 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 tests/database/null.links create mode 100644 tests/database/null.sql diff --git a/database/pg-driver/pg_database.ml b/database/pg-driver/pg_database.ml index 707fcca9b..feb95a1f5 100644 --- a/database/pg-driver/pg_database.ml +++ b/database/pg-driver/pg_database.ml @@ -188,3 +188,4 @@ let get_pg_database_by_string args = failwith "Insufficient arguments when establishing postgresql connection" let _ = Value.register_driver (driver_name, get_pg_database_by_string) + diff --git a/tests/database/config.mysql b/tests/database/config.mysql index 8a8dcc5f2..35680006c 100644 --- a/tests/database/config.mysql +++ b/tests/database/config.mysql @@ -1,2 +1,4 @@ database_driver=mysql database_args=localhost:3306:links:12345 +coerce_null_integers=on +null_integer=-1 diff --git a/tests/database/config.pgsql b/tests/database/config.pgsql index a8ed03b44..31d8377d0 100644 --- a/tests/database/config.pgsql +++ b/tests/database/config.pgsql @@ -1,2 +1,4 @@ database_driver=postgresql database_args=localhost:5432::links +coerce_null_integers=on +null_integer=-1 diff --git a/tests/database/config.sample b/tests/database/config.sample index a8ed03b44..31d8377d0 100644 --- a/tests/database/config.sample +++ b/tests/database/config.sample @@ -1,2 +1,4 @@ database_driver=postgresql database_args=localhost:5432::links +coerce_null_integers=on +null_integer=-1 diff --git a/tests/database/config.sqlite3 b/tests/database/config.sqlite3 index 7691e5768..8e9a04199 100644 --- a/tests/database/config.sqlite3 +++ b/tests/database/config.sqlite3 @@ -1,2 +1,3 @@ database_driver=sqlite3 - +coerce_null_integers=on +null_integer=-1 diff --git a/tests/database/null.links b/tests/database/null.links new file mode 100644 index 000000000..45a84fd4d --- /dev/null +++ b/tests/database/null.links @@ -0,0 +1,4 @@ +var db = database "links"; +var nulltable = table "nulltable" with (i : Int, f : Int) from db; + +assertEq(query {for (x <-- nulltable) [x]},[(i=1,f= -1)]) diff --git a/tests/database/null.sql b/tests/database/null.sql new file mode 100644 index 000000000..90bdfa57c --- /dev/null +++ b/tests/database/null.sql @@ -0,0 +1,9 @@ +DROP TABLE IF EXISTS nulltable; + +CREATE TABLE nulltable ( + i integer, + f bigint +); + + +INSERT INTO nulltable VALUES (1,null); diff --git a/tests/database/testsuite.config b/tests/database/testsuite.config index 833331eb5..e31878e7c 100644 --- a/tests/database/testsuite.config +++ b/tests/database/testsuite.config @@ -2,6 +2,7 @@ factorials factorials-large empty emptyfun +null unit xpath xpath-reduced From 4147f34f00c20777ac6cb89930c2ed9a9b6387d7 Mon Sep 17 00:00:00 2001 From: James Cheney Date: Wed, 24 Jun 2020 12:39:45 +0100 Subject: [PATCH 28/28] address @dhil's suggestions --- core/database.ml | 2 +- core/utility.ml | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/database.ml b/core/database.ml index 676d7cbda..2b06ec928 100644 --- a/core/database.ml +++ b/core/database.ml @@ -90,7 +90,7 @@ let execute_insert_returning returning q db = begin match result#status with | `QueryOk -> - if result#nfields == 1 && result#ntuples == 1 + if result#nfields = 1 && result#ntuples = 1 then (* returning field has to be of type int *) Value.box_int (int_of_string (result#getvalue 0 0)) else raise (runtime_error ("Returned the wrong number of results executing " ^ q)) diff --git a/core/utility.ml b/core/utility.ml index 1f4c4be76..4c225eba2 100644 --- a/core/utility.ml +++ b/core/utility.ml @@ -1498,15 +1498,15 @@ struct let get buf i = if 0 <= i && i < buf.currpage*buf.pagesize + buf.nextitem then Array.get (Array.get buf.pages (i/buf.pagesize)) (i mod buf.pagesize) - else raise Not_found + else raise (Invalid_argument "index out of bounds") let append buf x = (* first, check if there is enough space or allocation is needed *) - if (buf.nextitem == buf.pagesize) + if (buf.nextitem = buf.pagesize) then begin buf.nextitem <- 0; buf.currpage <- buf.currpage+1; - if (buf.currpage == buf.numpages) + if (buf.currpage = buf.numpages) then begin (* need to allocate a new page and copy over *) buf.numpages <- buf.numpages+1; let newpages = Array.init buf.numpages (fun i ->
      Region: - {choiceDefault(for (region <-- regionTable) - [(region.region_id, region.region_name)], + {choiceDefault(query { for (region <-- regionTable) + [(region.region_id, region.region_name)] }, region_id) -> search_region_id}
      Wine type: - {choiceDefault(for (type <-- wineTypeTable) - [(type.wine_type_id, type.wine_type)], + {choiceDefault(query { for (type <-- wineTypeTable) + [(type.wine_type_id, type.wine_type)] }, wine_type) -> search_wine_type}