Update feature branch

dune-project

@@ -464,16 +464,16 @@ This package provides an Lwt compatible interface to the library.")
   (homepage "https://github.com/mirage/ocaml-vhd")
   (source (github mirage/ocaml-vhd))
   (depends
-    (ocaml (and (>= "4.02.3") (< "5.0.0")))
+    (ocaml (>= "4.10.0"))
     (alcotest :with-test)
-    (alcotest-lwt :with-test)
-    bigarray-compat
-    (cstruct (< "6.1.0"))
+    (alcotest-lwt (and :with-test (>= "1.0.0")))
+    (bigarray-compat (>= "1.1.0"))
+    (cstruct (>= "6.0.0"))
     cstruct-lwt
     (fmt :with-test)
     (lwt (>= "3.2.0"))
-    (mirage-block (>= "2.0.1"))
-    rresult
+    (mirage-block (>= "3.0.0"))
+    (rresult (>= "0.7.0"))
     (vhd-format (= :version))
     (io-page (and :with-test (>= "2.4.0")))
   )

ocaml/database/db_cache_types.ml

@@ -158,6 +158,7 @@ module Row = struct
     with Not_found -> raise (DBCache_NotFound ("missing field", key, ""))
 
   let add_defaults g (schema : Schema.Table.t) t =
+    let schema = Schema.Table.t'_of_t schema in
     List.fold_left
       (fun t c ->
         if not (mem c.Schema.Column.name t) then

ocaml/database/schema.ml

@@ -96,28 +96,104 @@ module Column = struct
           (** only so we can special case set refs in the interface *)
   }
   [@@deriving sexp]
+
+  let name_of t = t.name
 end
 
+let tabulate ks ~key_fn =
+  let tbl = Hashtbl.create 64 in
+  List.iter (fun c -> Hashtbl.replace tbl (key_fn c) c) ks ;
+  tbl
+
+let values_of_table tbl = Hashtbl.fold (fun _ v vs -> v :: vs) tbl []
+
 module Table = struct
-  type t = {name: string; columns: Column.t list; persistent: bool}
+  type t' = {name: string; columns: Column.t list; persistent: bool}
   [@@deriving sexp]
 
-  let find name t =
-    try List.find (fun col -> col.Column.name = name) t.columns
-    with Not_found ->
-      raise (Db_exn.DBCache_NotFound ("missing column", t.name, name))
+  type t = {
+      name: string
+    ; columns: (string, Column.t) Hashtbl.t
+    ; persistent: bool
+  }
+
+  let t'_of_t : t -> t' =
+   fun (t : t) ->
+    let ({name; columns; persistent} : t) = t in
+    let columns = values_of_table columns in
+    {name; columns; persistent}
+
+  let t_of_t' : t' -> t =
+   fun (t' : t') ->
+    let ({name; columns; persistent} : t') = t' in
+    let columns = tabulate columns ~key_fn:Column.name_of in
+    {name; columns; persistent}
+
+  let sexp_of_t t =
+    let t' = t'_of_t t in
+    sexp_of_t' t'
+
+  let t_of_sexp s =
+    let ({name; columns; persistent} : t') = t'_of_sexp s in
+    let columns = tabulate columns ~key_fn:Column.name_of in
+    ({name; columns; persistent} : t)
+
+  let find name (t : t) =
+    match Hashtbl.find_opt t.columns name with
+    | Some c ->
+        c
+    | _ ->
+        raise (Db_exn.DBCache_NotFound ("missing column", t.name, name))
+
+  let create ~name ~columns ~persistent : t =
+    let columns =
+      let tbl = Hashtbl.create 64 in
+      List.iter (fun c -> Hashtbl.add tbl c.Column.name c) columns ;
+      tbl
+    in
+    {name; columns; persistent}
+
+  let name_of t = t.name
 end
 
 type relationship = OneToMany of string * string * string * string
 [@@deriving sexp]
 
 module Database = struct
-  type t = {tables: Table.t list} [@@deriving sexp]
+  type t' = {tables: Table.t list} [@@deriving sexp]
+
+  type t = {tables: (string, Table.t) Hashtbl.t}
+
+  let t_of_t' : t' -> t =
+   fun (t' : t') ->
+    let ({tables} : t') = t' in
+    let tables = tabulate tables ~key_fn:Table.name_of in
+    {tables}
+
+  let t'_of_t : t -> t' =
+   fun (t : t) ->
+    let ({tables} : t) = t in
+    let tables = values_of_table tables in
+    {tables}
+
+  let sexp_of_t t =
+    let t' = t'_of_t t in
+    sexp_of_t' t'
+
+  let t_of_sexp s =
+    let t' = t'_of_sexp s in
+    t_of_t' t'
 
   let find name t =
-    try List.find (fun tbl -> tbl.Table.name = name) t.tables
-    with Not_found ->
-      raise (Db_exn.DBCache_NotFound ("missing table", name, ""))
+    match Hashtbl.find_opt t.tables name with
+    | Some tbl ->
+        tbl
+    | _ ->
+        raise (Db_exn.DBCache_NotFound ("missing table", name, ""))
+
+  let of_tables tables =
+    let tables = tabulate tables ~key_fn:Table.name_of in
+    {tables}
 end
 
 (** indexed by table name, a list of (this field, foreign table, foreign field) *)
@@ -161,7 +237,7 @@ let empty =
   {
     major_vsn= 0
   ; minor_vsn= 0
-  ; database= {Database.tables= []}
+  ; database= {Database.tables= Hashtbl.create 64}
   ; one_to_many= ForeignMap.empty
   ; many_to_many= ForeignMap.empty
   }
@@ -174,7 +250,8 @@ let is_field_persistent schema tblname fldname =
   tbl.Table.persistent && col.Column.persistent
 
 let table_names schema =
-  List.map (fun t -> t.Table.name) (database schema).Database.tables
+  let tables = (database schema).Database.tables in
+  Hashtbl.fold (fun k _ ks -> k :: ks) tables []
 
 let one_to_many tblname schema =
   (* If there is no entry in the map it means that the table has no one-to-many relationships *)

ocaml/database/test_schemas.ml

@@ -99,22 +99,35 @@ let schema =
     ; issetref= false
     }
   in
-  let vm_table =
-    {
-      Schema.Table.name= "VM"
-    ; columns=
-        [_ref; uuid; name_label; vbds; pp; name_description; tags; other_config]
-    ; persistent= true
-    }
+  let vm_table : Schema.Table.t =
+    Schema.Table.t_of_t'
+      {
+        Schema.Table.name= "VM"
+      ; columns=
+          [
+            _ref
+          ; uuid
+          ; name_label
+          ; vbds
+          ; pp
+          ; name_description
+          ; tags
+          ; other_config
+          ]
+      ; persistent= true
+      }
   in
   let vbd_table =
-    {
-      Schema.Table.name= "VBD"
-    ; columns= [_ref; uuid; vm; type']
-    ; persistent= true
-    }
+    Schema.Table.t_of_t'
+      {
+        Schema.Table.name= "VBD"
+      ; columns= [_ref; uuid; vm; type']
+      ; persistent= true
+      }
+  in
+  let database =
+    Schema.Database.t_of_t' {Schema.Database.tables= [vm_table; vbd_table]}
   in
-  let database = {Schema.Database.tables= [vm_table; vbd_table]} in
   let one_to_many =
     Schema.ForeignMap.add "VBD" [("VM", "VM", "VBDs")] Schema.ForeignMap.empty
   in
@@ -140,12 +153,16 @@ let many_to_many =
   in
   let foo_column = {bar_column with Schema.Column.name= "foos"} in
   let foo_table =
-    {Schema.Table.name= "foo"; columns= [bar_column]; persistent= true}
+    Schema.Table.t_of_t'
+      {Schema.Table.name= "foo"; columns= [bar_column]; persistent= true}
   in
   let bar_table =
-    {Schema.Table.name= "bar"; columns= [foo_column]; persistent= true}
+    Schema.Table.t_of_t'
+      {Schema.Table.name= "bar"; columns= [foo_column]; persistent= true}
+  in
+  let database =
+    Schema.Database.t_of_t' {Schema.Database.tables= [foo_table; bar_table]}
   in
-  let database = {Schema.Database.tables= [foo_table; bar_table]} in
   let many_to_many =
     Schema.ForeignMap.add "foo"
       [("bars", "bar", "foos")]

ocaml/idl/datamodel_lifecycle.ml

@@ -52,7 +52,7 @@ let prototyped_of_field = function
   | "VTPM", "persistence_backend" ->
       Some "22.26.0"
   | "SM", "host_pending_features" ->
-      Some "24.36.0-next"
+      Some "24.37.0"
   | "host", "last_update_hash" ->
       Some "24.10.0"
   | "host", "pending_guidances_full" ->

ocaml/idl/datamodel_schema.ml

@@ -85,14 +85,16 @@ let of_datamodel () =
   in
 
   let table obj =
-    {
-      Table.name= Escaping.escape_obj obj.Datamodel_types.name
-    ; columns=
-        _ref
-        :: List.map (column obj) (flatten_fields obj.Datamodel_types.contents [])
-    ; persistent=
-        obj.Datamodel_types.persist = Datamodel_types.PersistEverything
-    }
+    Table.t_of_t'
+      {
+        Table.name= Escaping.escape_obj obj.Datamodel_types.name
+      ; columns=
+          _ref
+          :: List.map (column obj)
+               (flatten_fields obj.Datamodel_types.contents [])
+      ; persistent=
+          obj.Datamodel_types.persist = Datamodel_types.PersistEverything
+      }
   in
   let is_one_to_many x =
     match Datamodel_utils.Relations.classify Datamodel.all_api x with
@@ -119,7 +121,8 @@ let of_datamodel () =
   in
 
   let database api =
-    {Database.tables= List.map table (Dm_api.objects_of_api api)}
+    let tables = List.map table (Dm_api.objects_of_api api) in
+    Database.of_tables tables
   in
   {
     major_vsn= Datamodel_common.schema_major_vsn

ocaml/idl/ocaml_backend/gen_api.ml

@@ -241,8 +241,8 @@ let gen_record_type ~with_module highapi tys =
             [
               sprintf "let rpc_of_%s_t x = Rpc.Dict (unbox_list [ %s ])"
                 obj_name (map_fields make_of_field)
-            ; sprintf "let %s_t_of_rpc x = on_dict (fun x -> { %s }) x" obj_name
-                (map_fields make_to_field)
+            ; sprintf "let %s_t_of_rpc x = on_dict (fun x assocer -> { %s }) x"
+                obj_name (map_fields make_to_field)
             ; sprintf
                 "type ref_%s_to_%s_t_map = (ref_%s * %s_t) list [@@deriving \
                  rpc]"
@@ -408,10 +408,6 @@ let gen_client_types highapi =
             x | _ -> failwith \"Date.t_of_rpc\""
          ; "end"
          ]
-       ; [
-           "let on_dict f = function | Rpc.Dict x -> f x | _ -> failwith \
-            \"Expected Dictionary\""
-         ]
        ; ["let opt_map f = function | None -> None | Some x -> Some (f x)"]
        ; [
            "let unbox_list = let rec loop aux = function"
@@ -421,14 +417,21 @@ let gen_client_types highapi =
          ; "loop []"
          ]
        ; [
-           "let assocer key map default = "
-         ; "  try"
-         ; "    List.assoc key map"
-         ; "  with Not_found ->"
-         ; "    match default with"
-         ; "    | Some d -> d"
-         ; "    | None -> failwith (Printf.sprintf \"Field %s not present in \
-            rpc\" key)"
+           "let assocer kvs ="
+         ; "let tbl = Hashtbl.create 256 in"
+         ; "List.iter (fun (k, v) -> Hashtbl.replace tbl k v) kvs;"
+         ; "fun key _ default ->"
+         ; "match Hashtbl.find_opt tbl key with"
+         ; "| Some v -> v"
+         ; "| _ ->"
+         ; "   match default with"
+         ; "   | Some d -> d"
+         ; "   | _ -> failwith (Printf.sprintf \"Field %s not present in rpc\" \
+            key)"
+         ]
+       ; [
+           "let on_dict f = function | Rpc.Dict x -> f x (assocer x) | _ -> \
+            failwith \"Expected Dictionary\""
          ]
        ; gen_non_record_type all_types
        ; gen_record_type ~with_module:true highapi