Restore MySQL driver and fix ordering problem (links-lang#858)

add -linkall flag which makes mysql plugin happy

make the database tests deterministic

fix inconsistent ordering behavior

add configs for other drivers

cleanup fix of ordering

implement insert returning correctly for mysql, sqlite3

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

add test for null integer handling

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

core/database.ml

@@ -1,4 +1,3 @@
-open List
 open CommonTypes
 open Utility
 
@@ -91,13 +90,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 +145,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
@@ -174,12 +168,3 @@ let execute_select
     : Value.t =
   let result,rs = execute_select_result field_types query db in
   build_result (result,rs)
-
-
-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)))

core/database.mli

@@ -23,7 +23,5 @@ 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
-
 val execute_insert_returning : string -> Sql.query ->  Value.database -> Value.t
 

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 (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)
+    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

core/value.ml

@@ -36,34 +36,19 @@ 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
   method map : 'a. ((int -> string) -> '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#getvalue n)::acc)
-     )
-    else acc
-      in 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 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 =
-    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 getvalue : int -> int -> string
   method virtual gettuple : int -> string array
   method virtual error : string

core/value.mli

@@ -11,7 +11,6 @@ class virtual dbvalue :
   object
     method virtual error : string
     method virtual fname : int -> string
-    method virtual get_all_lst : string list list
     method virtual nfields : int
     method virtual ntuples : int
     method map : 'a. ((int -> string) -> 'a) -> 'a list

database/mysql-driver/jbuild.unsupported → 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))

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"
@@ -201,18 +203,23 @@ object
   method show = pretty_type thing
 end
 
-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)
+let iterUntilNone (fn : unit -> 'b option) (g : 'b -> unit) : unit =
+  let rec iterate () =
+    match fn () with
+      | None -> ()
+      | Some value -> g value; iterate()
   in
-    List.rev (obtain [])
+    iterate ()
 
 class mysql_result (result : result) db = object
   inherit Value.dbvalue
-  val rows = ref None
-  method status : Value.db_status =
+  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)
@@ -222,22 +229,13 @@ 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 =
-    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))
+    let row = PolyBuffer.get result_buf n in
+(* TODO: Handle nulls better *)
+    Utility.from_option "" (row.(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))
+    let row = PolyBuffer.get result_buf n in
+    Array.map (Utility.from_option "") row
   method error : string =
     Utility.val_of (errmsg db)
 end
@@ -257,9 +255,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 None 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

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
+  (*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

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 -> ""
@@ -45,36 +47,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
-    get_results ([],`QueryOk)
+    (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
@@ -115,6 +122,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"

dune

@@ -8,6 +8,7 @@
           -warn-error -a      ;; Do not treat warnings as errors.
           -w A-4-42-44-45-48-60-67  ;; Ignores warnings 4, 42, 44, 45, 48, 60, and 67.
           -g                  ;; Adds debugging information to the resulting executable / library.
+          -linkall
  )))
  (release
   (flags (:standard

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

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