Restore MySQL driver and fix ordering problem

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-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

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