From 5099b9af6050f50e5907b2bce51da48f9d7f4d5e Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 11:24:22 +0000 Subject: [PATCH 01/21] Database: add a 'type' to each column The types are: - String: most fields - Set: all Set(_) - Pairs: all Map(_,_) This allows a database implementation to avoid serialising sets and maps to strings all the time. This patch also adds 'with sexp' to the schema so it can be easily read and written. Eventually we will be able to separate the datamodel and the schema and have the database load the schema at runtime. Signed-off-by: David Scott --- ocaml/database/OMakefile | 1 + ocaml/database/db_cache_types.ml | 10 +++--- ocaml/database/schema.ml | 59 ++++++++++++++++++++++++-------- ocaml/database/test_schemas.ml | 20 ++++++++--- ocaml/idl/datamodel_schema.ml | 24 ++++++++++--- 5 files changed, 85 insertions(+), 29 deletions(-) diff --git a/ocaml/database/OMakefile b/ocaml/database/OMakefile index 0a46c00a49f..7224860a7ad 100644 --- a/ocaml/database/OMakefile +++ b/ocaml/database/OMakefile @@ -5,6 +5,7 @@ OCAMLPACKS = xml-light2 stdext stunnel http-svr xcp sexpr rpclib uuid gzip xc #OCAMLDEPFLAGS = -pp "camlp4o" UseCamlp4(rpclib.syntax, db_rpc_common_v2 db_cache_types db_filter_types) +UseCamlp4(sexplib.syntax, schema) OCamlGeneratedFiles(db_filter_parse.ml db_filter_parse.mli db_filter_lex.ml) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 3ecb52796db..c6daf2b68c4 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -287,7 +287,7 @@ module Database = struct x.tables KeyMap.empty in (* For each of the one-to-many relationships, recompute the many end *) let tables = - Schema.StringMap.fold + Schema.ForeignMap.fold (fun one_tblname rels tables -> List.fold_left (fun tables (one_fldname, many_tblname, many_fldname) -> (* VBD.VM : Ref(VM) -> VM.VBDs : Set(Ref(VBD)) *) @@ -307,10 +307,10 @@ module Database = struct let vm_to_vbds = Table.fold (fun vbd _ _ row acc -> let vm = Row.find one_fldname row in - let existing = if Schema.StringMap.mem vm acc then Schema.StringMap.find vm acc else [] in - Schema.StringMap.add vm (vbd :: existing) acc) - one_tbl Schema.StringMap.empty in - let many_tbl'' = Schema.StringMap.fold + let existing = if Schema.ForeignMap.mem vm acc then Schema.ForeignMap.find vm acc else [] in + Schema.ForeignMap.add vm (vbd :: existing) acc) + one_tbl Schema.ForeignMap.empty in + let many_tbl'' = Schema.ForeignMap.fold (fun vm vbds acc -> if not(Table.mem vm acc) then acc diff --git a/ocaml/database/schema.ml b/ocaml/database/schema.ml index 96e710c8c9e..92c0766d7db 100644 --- a/ocaml/database/schema.ml +++ b/ocaml/database/schema.ml @@ -11,6 +11,15 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) +open Sexplib.Std + +module Type = struct + type t = + | String + | Set (* of strings *) + | Pairs (* of string * string *) + with sexp +end module Column = struct type t = { @@ -18,9 +27,9 @@ module Column = struct persistent: bool; (** see is_field_persistent *) empty: string; (** fresh value used when loading non-persistent fields *) default: string option; (** if column is missing, this is default value is used *) - + ty: Type.t; (** the type of the value in the column *) issetref: bool; (** only so we can special case set refs in the interface *) - } + } with sexp end module Table = struct @@ -28,33 +37,53 @@ module Table = struct name: string; columns: Column.t list; persistent: bool; - } + } with sexp let find name t = List.find (fun col -> col.Column.name = name) t.columns end type relationship = | OneToMany of string * string * string * string + with sexp module Database = struct type t = { tables: Table.t list; - } + } with sexp + let find name t = List.find (fun tbl -> tbl.Table.name = name) t.tables end -module StringMap = Map.Make(struct - type t = string - let compare = Pervasives.compare -end) +(** indexed by table name, a list of (this field, foreign table, foreign field) *) +type foreign = (string * string * string) list +with sexp + +module ForeignMap = struct + include Map.Make(struct + type t = string + let compare = Pervasives.compare + end) + + type t' = (string * foreign) list + with sexp + + type m = foreign t + let sexp_of_m t : Sexplib.Sexp.t = + let t' = fold (fun key foreign acc -> (key, foreign) :: acc) t [] in + sexp_of_t' t' + + let m_of_sexp sexp : m = + let t' = t'_of_sexp sexp in + List.fold_left (fun acc (key, foreign) -> add key foreign acc) empty t' +end type t = { major_vsn: int; minor_vsn: int; database: Database.t; (** indexed by table name, a list of (this field, foreign table, foreign field) *) - one_to_many: ((string * string * string) list) StringMap.t; - many_to_many: ((string * string * string) list) StringMap.t; -} + one_to_many: ForeignMap.m; + many_to_many: ForeignMap.m; +} with sexp let database x = x.database @@ -69,8 +98,8 @@ let empty = { major_vsn = 0; minor_vsn = 0; database = { Database.tables = [] }; - one_to_many = StringMap.empty; - many_to_many = StringMap.empty; + one_to_many = ForeignMap.empty; + many_to_many = ForeignMap.empty; } let is_table_persistent schema tblname = @@ -89,12 +118,12 @@ open D 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 *) try - StringMap.find tblname schema.one_to_many + ForeignMap.find tblname schema.one_to_many with Not_found -> [] let many_to_many tblname schema = (* If there is no entry in the map it means that the table has no many-to-many relationships *) try - StringMap.find tblname schema.many_to_many + ForeignMap.find tblname schema.many_to_many with Not_found -> [] diff --git a/ocaml/database/test_schemas.ml b/ocaml/database/test_schemas.ml index 2831a6fe799..1c7c436cc12 100644 --- a/ocaml/database/test_schemas.ml +++ b/ocaml/database/test_schemas.ml @@ -4,6 +4,7 @@ let schema = persistent = true; empty = ""; default = None; + ty = Schema.Type.String; issetref = false; } in let uuid = { @@ -11,6 +12,7 @@ let schema = persistent = true; empty = ""; default = None; + ty = Schema.Type.String; issetref = false; } in let name_label = { @@ -18,6 +20,7 @@ let schema = persistent = true; empty = ""; default = None; + ty = Schema.Type.String; issetref = false; } in let name_description = { @@ -25,6 +28,7 @@ let schema = persistent = true; empty = ""; default = None; + ty = Schema.Type.String; issetref = false; } in let vbds = { @@ -32,6 +36,7 @@ let schema = persistent = false; empty = "()"; default = Some("()"); + ty = Schema.Type.Set; issetref = true; } in let other_config = { @@ -39,6 +44,7 @@ let schema = persistent = false; empty = "()"; default = Some("()"); + ty = Schema.Type.Pairs; issetref = false; } in let pp = { @@ -46,6 +52,7 @@ let schema = persistent = true; empty = ""; default = Some("OpaqueRef:NULL"); + ty = Schema.Type.String; issetref = false; } in let tags = { @@ -53,6 +60,7 @@ let schema = persistent = true; empty = ""; default = Some("()"); + ty = Schema.Type.Set; issetref = false; } in let vm = { @@ -60,6 +68,7 @@ let schema = persistent = true; empty = ""; default = None; + ty = Schema.Type.String; issetref = false; } in @@ -76,7 +85,7 @@ let schema = let database = { Schema.Database.tables = [ vm_table; vbd_table ]; } in - let one_to_many = Schema.StringMap.add "VBD" [ "VM", "VM", "VBDs" ] (Schema.StringMap.empty) in + let one_to_many = Schema.ForeignMap.add "VBD" [ "VM", "VM", "VBDs" ] (Schema.ForeignMap.empty) in { Schema.major_vsn = 1; @@ -84,7 +93,7 @@ let schema = database = database; (** indexed by table name, a list of (this field, foreign table, foreign field) *) one_to_many = one_to_many; - many_to_many = Schema.StringMap.empty; + many_to_many = Schema.ForeignMap.empty; } @@ -93,6 +102,7 @@ let many_to_many = persistent = false; empty = "()"; default = None; + ty = Schema.Type.Pairs; issetref = false; } in let foo_column = { bar_column with Schema.Column.name = "foos" } in @@ -101,9 +111,9 @@ let many_to_many = let database = { Schema.Database.tables = [ foo_table; bar_table ] } in let many_to_many = - Schema.StringMap.add "foo" [ "bars", "bar", "foos" ] - (Schema.StringMap.add "bar" [ "foos", "foo", "bars" ] - Schema.StringMap.empty) in + Schema.ForeignMap.add "foo" [ "bars", "bar", "foos" ] + (Schema.ForeignMap.add "bar" [ "foos", "foo", "bars" ] + Schema.ForeignMap.empty) in let schema = { Schema.empty with Schema.database = database; many_to_many = many_to_many diff --git a/ocaml/idl/datamodel_schema.ml b/ocaml/idl/datamodel_schema.ml index 17119bced14..f560cf8b065 100644 --- a/ocaml/idl/datamodel_schema.ml +++ b/ocaml/idl/datamodel_schema.ml @@ -30,6 +30,10 @@ let of_datamodel () = let this = obj.Datamodel_types.name, f.Datamodel_types.field_name in Datamodel_utils.Relations.is_in_relation api this && (Datamodel_utils.Relations.classify api (this,(Datamodel_utils.Relations.other_end_of api this)) = (`Many, `Many)) in + let ty = match f.Datamodel_types.ty with + | Datamodel_types.Set _ -> Type.Set + | Datamodel_types.Map(_,_) -> Type.Pairs + | _ -> Type.String in { Column.name = Escaping.escape_id f.Datamodel_types.full_name; (* NB we always regenerate one-to-many Set(Ref _) fields *) @@ -40,6 +44,7 @@ let of_datamodel () = if issetref then Some (SExpr.string_of (SExpr.Node [])) else Opt.map Datamodel_values.to_db_string f.Datamodel_types.default_value ; + ty = ty; issetref = issetref; } in @@ -49,6 +54,7 @@ let of_datamodel () = persistent = true; empty = ""; default = None; + ty = Type.String; issetref = false; } in @@ -66,9 +72,9 @@ let of_datamodel () = | `Many, `Many -> true | _ -> false in let add_relation p t (((one_tbl, one_fld), (many_tbl, many_fld)) as r) = - let l = if StringMap.mem one_tbl t then StringMap.find one_tbl t else [] in + let l = if ForeignMap.mem one_tbl t then ForeignMap.find one_tbl t else [] in if p r - then StringMap.add one_tbl ((one_fld, many_tbl, many_fld) :: l) t + then ForeignMap.add one_tbl ((one_fld, many_tbl, many_fld) :: l) t else t in let database api = { @@ -78,6 +84,16 @@ let of_datamodel () = major_vsn = Datamodel.schema_major_vsn; minor_vsn = Datamodel.schema_minor_vsn; database = database Datamodel.all_api; - one_to_many = List.fold_left (add_relation is_one_to_many) StringMap.empty (Dm_api.relations_of_api Datamodel.all_api); - many_to_many = List.fold_left (add_relation is_many_to_many) StringMap.empty (Dm_api.relations_of_api Datamodel.all_api); + one_to_many = List.fold_left (add_relation is_one_to_many) ForeignMap.empty (Dm_api.relations_of_api Datamodel.all_api); + many_to_many = List.fold_left (add_relation is_many_to_many) ForeignMap.empty (Dm_api.relations_of_api Datamodel.all_api); } + +(* For now this is a convenience debugging function. Eventually we should + separate the datamodel from the database and load the schema from disk. *) +let write_schema_to_file filename = + let t = of_datamodel () in + let sexp = Schema.sexp_of_t t in + let oc = open_out filename in + let txt = Sexplib.Sexp.to_string_hum sexp in + output_string oc txt; + close_out oc From ca4588fef48efdec3872f14d158d59799c00fea6 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 14:18:36 +0000 Subject: [PATCH 02/21] Database: rename MAP2 to MAP, Map2 to Make and extract a common signature Names like "MAP2" beg the question, "what happened to MAP1?" This patch also factorises the ROW, TABLE, TABLESET signatures into a shared common portion, with specific extensions on top. Signed-off-by: David Scott --- ocaml/database/database_test.ml | 14 +++--- ocaml/database/db_cache_types.ml | 73 +++++++++++++++------------- ocaml/database/db_cache_types.mli | 81 +++++++++++++++---------------- ocaml/xenops/xn_cfg_parser.mly | 17 +++++++ 4 files changed, 102 insertions(+), 83 deletions(-) create mode 100644 ocaml/xenops/xn_cfg_parser.mly diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index f6afc22e91c..8973e021986 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -183,13 +183,13 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let row = Db_cache_types.Table.find r table in let s = Db_cache_types.Row.fold_over_recent g (fun c u d k v acc -> - Printf.sprintf "%s %s=%s" acc k v) row "" in + Printf.sprintf "%s %s=%s" acc k v) (fun () -> ()) row "" in s with _ -> "(deleted)" in Printf.printf "%s(%s): (%Ld %Ld %Ld) %s\n" name r c u d s; ()) - (fun () -> ()) table ()) tables () + (fun () -> ()) table ()) (fun () -> ()) tables () in let get_created db g = @@ -199,7 +199,7 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct Db_cache_types.Table.fold_over_recent g (fun c u d r acc -> if c>=g then (name,r)::acc else acc) ignore table acc - ) tables [] + ) (fun () -> ()) tables [] in let get_updated db g = @@ -211,8 +211,8 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let row = Db_cache_types.Table.find r table in Db_cache_types.Row.fold_over_recent g (fun c u d k v acc -> - (r,(k,v))::acc) row acc) - ignore table acc) tables [] + (r,(k,v))::acc) (fun () -> ()) row acc) + ignore table acc) (fun () -> ()) tables [] in let get_deleted db g = @@ -222,14 +222,14 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct Db_cache_types.Table.fold_over_recent g (fun c u d r acc -> if d > g then r::acc else acc) - ignore table acc) tables [] + ignore table acc) (fun () -> ()) tables [] in let get_max db = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent (-1L) (fun c u d _ _ largest -> - max c (max u (max d largest))) tables (-1L) + max c (max u (max d largest))) (fun () -> ()) tables (-1L) in let db = Db_ref.get_database t in diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index c6daf2b68c4..c5d0623c4e0 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -1,5 +1,10 @@ open Db_exn +(** The values stored in the database *) +module Value = struct + type t = string +end + (** Database tables, columns and rows are all indexed by string, each using a specialised StringMap *) module StringMap = struct @@ -16,8 +21,20 @@ module type VAL = sig type v end +module type MAP = sig + type t + type value + val add: int64 -> string -> value -> t -> t + val empty : t + val fold : (string -> int64 -> int64 -> value -> 'b -> 'b) -> t -> 'b -> 'b + val find : string -> t -> value + val mem : string -> t -> bool + val iter : (string -> value -> unit) -> t -> unit + val update : int64 -> string -> value -> (value -> value) -> t -> t +end + (** A specialised StringMap whose range type is V.v, and which keeps a record of when records are created/updated *) -module Map2 = functor(V: VAL) -> struct +module Make = functor(V: VAL) -> struct type x = { created : int64; updated : int64; @@ -43,28 +60,24 @@ module Map2 = functor(V: VAL) -> struct else updatefn () else updatefn () - let fold_over_recent since f = StringMap.fold (fun x y z -> if y.updated > since then f y.created y.updated 0L x y.v z else z) + let fold_over_recent since f _ t initial = StringMap.fold (fun x y z -> if y.updated > since then f y.created y.updated 0L x y.v z else z) t initial end -module StringStringMap = Map2(struct type v = string end) +module StringStringMap = Make(struct type v = string end) module type ROW = sig - type t - val add: int64 -> string -> string -> t -> t + include MAP + with type value = Value.t + val add_defaults: int64 -> Schema.Table.t -> t -> t - val empty : t - val fold : (string -> int64 -> int64 -> string -> 'b -> 'b) -> t -> 'b -> 'b - val find : string -> t -> string - val mem : string -> t -> bool - val iter : (string -> string -> unit) -> t -> unit val remove : string -> t -> t - val update : int64 -> string -> string -> (string -> string) -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> string -> 'b -> 'b) -> t -> 'b -> 'b + val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Row : ROW = struct include StringStringMap type t=map_t + type value = Value.t let find key t = try find key t with Not_found -> raise (DBCache_NotFound ("missing field", key, "")) @@ -77,28 +90,23 @@ module Row : ROW = struct else t) t schema.Schema.Table.columns end -module StringRowMap = Map2(struct type v = Row.t end) +module StringRowMap = Make(struct type v = Row.t end) module type TABLE = sig - type t - val add: int64 -> string -> Row.t -> t -> t - val empty : t - val fold : (string -> int64 -> int64 -> Row.t -> 'b -> 'b) -> t -> 'b -> 'b - val find_exn : string -> string -> t -> Row.t - val find : string -> t -> Row.t - val mem : string -> t -> bool - val iter : (string -> Row.t -> unit) -> t -> unit - val remove : int64 -> string -> t -> t + include MAP + with type value = Row.t val update_generation : int64 -> string -> Row.t -> (Row.t -> Row.t) -> t -> t - val update : int64 -> string -> Row.t -> (Row.t -> Row.t) -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val rows : t -> Row.t list + val remove : int64 -> string -> t -> t + val find_exn : string -> string -> t -> Row.t + val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : TABLE = struct type t = { rows : StringRowMap.map_t; deleted_len : int; deleted : (int64 * int64 * string) list } + type value = Row.t let add g key value t = {t with rows=StringRowMap.add g key value t.rows} let empty = {rows=StringRowMap.empty; deleted_len = 1; deleted=[(0L,0L,"")] } let fold f t acc = StringRowMap.fold f t.rows acc @@ -124,7 +132,7 @@ module Table : TABLE = struct let update_generation g key default f t = {t with rows = StringRowMap.update_generation g key default f t.rows } let update g key default f t = {t with rows = StringRowMap.update g key default f t.rows} let fold_over_recent since f errf t acc = - let acc = StringRowMap.fold_over_recent since (fun c u d x _ z -> f c u d x z) t.rows acc in + let acc = StringRowMap.fold_over_recent since (fun c u d x _ z -> f c u d x z) errf t.rows acc in let rec fold_over_deleted deleted acc = match deleted with | (created,destroyed,r)::xs -> @@ -142,24 +150,19 @@ module Table : TABLE = struct fold (fun _ _ _ r rs -> r :: rs) t [] end -module StringTableMap = Map2(struct type v = Table.t end) +module StringTableMap = Make(struct type v = Table.t end) module type TABLESET = sig - type t - val add: int64 -> string -> Table.t -> t -> t - val empty : t - val fold : (string -> int64 -> int64 -> Table.t -> 'b -> 'b) -> t -> 'b -> 'b - val find : string -> t -> Table.t - val mem : string -> t -> bool - val iter : (string -> Table.t -> unit) -> t -> unit + include MAP + with type value = Table.t + val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t - val update : int64 -> string -> Table.t -> (Table.t -> Table.t) -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> Table.t -> 'b -> 'b) -> t -> 'b -> 'b end module TableSet : TABLESET = struct include StringTableMap type t=map_t + type value = Table.t let find key t = try find key t with Not_found -> raise (DBCache_NotFound ("missing table", key, "")) diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index b15d2079061..81ead25abff 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -1,45 +1,45 @@ -module Row : - sig - type t - val add : int64 -> string -> string -> t -> t - val add_defaults : int64 -> Schema.Table.t -> t -> t - val empty : t - val fold : (string -> int64 -> int64 -> string -> 'a -> 'a) -> t -> 'a -> 'a - val find : string -> t -> string - val iter : (string -> string -> unit) -> t -> unit - val remove : string -> t -> t - val update : int64 -> string -> string -> (string -> string) -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> string -> 'b -> 'b) -> t -> 'b -> 'b - end +(** The values stored in the database *) +module Value : sig + type t = string +end -module Table : - sig - type t - val add : int64 -> string -> Row.t -> t -> t - val empty : t - val fold : (string -> int64 -> int64 -> Row.t -> 'a -> 'a) -> t -> 'a -> 'a - val find_exn : string -> string -> t -> Row.t - val find : string -> t -> Row.t - val mem : string -> t -> bool - val iter : (string -> Row.t -> unit) -> t -> unit - val remove : int64 -> string -> t -> t - val update : int64 -> string -> Row.t -> (Row.t -> Row.t) -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b - val rows : t -> Row.t list - end +module type MAP = sig + type t + type value + val add: int64 -> string -> value -> t -> t + val empty : t + val fold : (string -> int64 -> int64 -> value -> 'b -> 'b) -> t -> 'b -> 'b + val find : string -> t -> value + val mem : string -> t -> bool + val iter : (string -> value -> unit) -> t -> unit + val update : int64 -> string -> value -> (value -> value) -> t -> t +end -module TableSet : - sig - type t - val add : int64 -> string -> Table.t -> t -> t - val empty : t - val fold : (string -> int64 -> int64 -> Table.t -> 'a -> 'a) -> t -> 'a -> 'a - val find : string -> t -> Table.t - val iter : (string -> Table.t -> unit) -> t -> unit - val remove : string -> t -> t - val update : int64 -> string -> Table.t -> (Table.t -> Table.t) -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> Table.t -> 'b -> 'b) -> t -> 'b -> 'b - end +module Row : sig + include MAP + with type value = Value.t + + val add_defaults: int64 -> Schema.Table.t -> t -> t + val remove : string -> t -> t + val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b +end + +module Table : sig + include MAP + with type value = Row.t + val update_generation : int64 -> string -> value -> (value -> value) -> t -> t + val rows : t -> value list + val remove : int64 -> string -> t -> t + val find_exn : string -> string -> t -> value + val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b +end + +module TableSet : sig + include MAP + with type value = Table.t + val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val remove : string -> t -> t +end module Manifest : sig @@ -112,4 +112,3 @@ type structured_op_t = | RemoveMap val structured_op_t_of_rpc: Rpc.t -> structured_op_t val rpc_of_structured_op_t: structured_op_t -> Rpc.t - diff --git a/ocaml/xenops/xn_cfg_parser.mly b/ocaml/xenops/xn_cfg_parser.mly new file mode 100644 index 00000000000..3c549fb2614 --- /dev/null +++ b/ocaml/xenops/xn_cfg_parser.mly @@ -0,0 +1,17 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(** Takes a function which is supplied with an fd representing the input to the + sha1sum and returns the checksum as a string *) +val sha1sum: (Unix.file_descr -> unit) -> string From 0369d63ded3f55b43d960a0027efcf159f35d2d4 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 14:55:10 +0000 Subject: [PATCH 03/21] Database: replace the raw 'int64' with a 'Time.t' (= Generation.t) This means that - if you read the type, you realise this isn't just any old int64 - we are closer to making it fully abstract Signed-off-by: David Scott --- ocaml/database/db_cache_types.ml | 27 +++++++++++++++------------ ocaml/database/db_cache_types.mli | 23 ++++++++++++++--------- ocaml/database/db_xml.ml | 2 +- 3 files changed, 30 insertions(+), 22 deletions(-) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index c5d0623c4e0..9f155384530 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -1,10 +1,13 @@ open Db_exn -(** The values stored in the database *) module Value = struct type t = string end +module Time = struct + type t = Generation.t +end + (** Database tables, columns and rows are all indexed by string, each using a specialised StringMap *) module StringMap = struct @@ -24,9 +27,9 @@ end module type MAP = sig type t type value - val add: int64 -> string -> value -> t -> t + val add: Time.t -> string -> value -> t -> t val empty : t - val fold : (string -> int64 -> int64 -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold : (string -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -36,8 +39,8 @@ end (** A specialised StringMap whose range type is V.v, and which keeps a record of when records are created/updated *) module Make = functor(V: VAL) -> struct type x = { - created : int64; - updated : int64; + created : Time.t; + updated : Time.t; v : V.v } type map_t = x StringMap.t let empty = StringMap.empty @@ -69,9 +72,9 @@ module type ROW = sig include MAP with type value = Value.t - val add_defaults: int64 -> Schema.Table.t -> t -> t + val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Row : ROW = struct @@ -95,17 +98,17 @@ module StringRowMap = Make(struct type v = Row.t end) module type TABLE = sig include MAP with type value = Row.t - val update_generation : int64 -> string -> Row.t -> (Row.t -> Row.t) -> t -> t + val update_generation : Time.t -> string -> Row.t -> (Row.t -> Row.t) -> t -> t val rows : t -> Row.t list - val remove : int64 -> string -> t -> t + val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> Row.t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : TABLE = struct type t = { rows : StringRowMap.map_t; deleted_len : int; - deleted : (int64 * int64 * string) list } + deleted : (Time.t * Time.t * string) list } type value = Row.t let add g key value t = {t with rows=StringRowMap.add g key value t.rows} let empty = {rows=StringRowMap.empty; deleted_len = 1; deleted=[(0L,0L,"")] } @@ -155,7 +158,7 @@ module StringTableMap = Make(struct type v = Table.t end) module type TABLESET = sig include MAP with type value = Table.t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 81ead25abff..3d9fb600545 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -3,41 +3,46 @@ module Value : sig type t = string end +(** A timestamp *) +module Time : sig + type t = Generation.t +end + module type MAP = sig type t type value - val add: int64 -> string -> value -> t -> t + val add: Time.t -> string -> value -> t -> t val empty : t - val fold : (string -> int64 -> int64 -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold : (string -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit - val update : int64 -> string -> value -> (value -> value) -> t -> t + val update : Time.t -> string -> value -> (value -> value) -> t -> t end module Row : sig include MAP with type value = Value.t - val add_defaults: int64 -> Schema.Table.t -> t -> t + val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : sig include MAP with type value = Row.t - val update_generation : int64 -> string -> value -> (value -> value) -> t -> t + val update_generation : Time.t -> string -> value -> (value -> value) -> t -> t val rows : t -> value list - val remove : int64 -> string -> t -> t + val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> value - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module TableSet : sig include MAP with type value = Table.t - val fold_over_recent : int64 -> (int64 -> int64 -> int64 -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end diff --git a/ocaml/database/db_xml.ml b/ocaml/database/db_xml.ml index 33baa98c657..63730b1cc50 100644 --- a/ocaml/database/db_xml.ml +++ b/ocaml/database/db_xml.ml @@ -46,7 +46,7 @@ module To = struct let record rf ctime mtime (row: Row.t) _ = let preamble = if persist_generation_counts - then [("__mtime",Int64.to_string mtime); ("__ctime",Int64.to_string ctime); ("ref",rf)] + then [("__mtime",Generation.to_string mtime); ("__ctime",Generation.to_string ctime); ("ref",rf)] else [("ref",rf)] in let (tag: Xmlm.tag) = make_tag "row" (List.rev (Row.fold (fun k _ _ v acc -> (k, Xml_spaces.protect v) :: acc) row preamble)) in From e6ebd3064d4f564704e8e2b215e6763e6575e42b Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 17:27:07 +0000 Subject: [PATCH 04/21] Database: every function which takes Time.t -> Time.t has the third Time.t Some of the functions omitted the third Time.t (the deleted time), because the object could not have been deleted yet. Elsewhere we have the convention that a live object has deleted = 0L. This patch makes all the Time.t -> Time.t (-> Time.t) functions consistent. Signed-off-by: David Scott --- ocaml/database/db_backend.ml | 6 +++--- ocaml/database/db_cache_impl.ml | 18 +++++++++--------- ocaml/database/db_cache_types.ml | 14 +++++++------- ocaml/database/db_cache_types.mli | 2 +- ocaml/database/db_upgrade.ml | 4 ++-- ocaml/database/db_xml.ml | 4 ++-- ocaml/db_process/xapi_db_process.ml | 2 +- ocaml/xapi/xapi_event.ml | 4 ++-- opam | 1 - 9 files changed, 27 insertions(+), 28 deletions(-) diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index 364fc8d227a..96071358bea 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -42,7 +42,7 @@ let blow_away_non_persistent_fields (schema: Schema.t) db = (* Generate a new row given a table schema *) let row schema row : Row.t * int64 = Row.fold - (fun name created updated v (acc,max_upd) -> + (fun name created updated _ v (acc,max_upd) -> try let col = Schema.Table.find name schema in let v',updated' = if col.Schema.Column.persistent then v,updated else col.Schema.Column.empty,g in @@ -54,13 +54,13 @@ let blow_away_non_persistent_fields (schema: Schema.t) db = let table tblname tbl : Table.t = let schema = Schema.Database.find tblname schema.Schema.database in Table.fold - (fun objref created updated r acc -> + (fun objref created updated _ r acc -> let (r,updated) = row schema r in Table.update updated objref Row.empty (fun _ -> r) (Table.add created objref r acc)) tbl Table.empty in Database.update (fun ts -> TableSet.fold - (fun tblname created updated tbl acc -> + (fun tblname created updated _ tbl acc -> let tbl' = table tblname tbl in TableSet.add updated tblname tbl' acc) ts TableSet.empty) db diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index 63618d871c8..011f6933f7a 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -111,7 +111,7 @@ let read_set_ref t rcd = Printf.printf "Illegal read_set_ref query { table = %s; where_field = %s; where_value = %s; return = %s }; falling back to linear scan\n%!" rcd.table rcd.where_field rcd.where_value rcd.return; let tbl = TableSet.find rcd.table (Database.tableset db) in Table.fold - (fun rf _ _ row acc -> + (fun rf _ _ _ row acc -> if Row.find rcd.where_field row = rcd.where_value then Row.find rcd.return row :: acc else acc) tbl [] @@ -127,7 +127,7 @@ let read_set_ref t rcd = let read_record_internal db tblname objref = let tbl = TableSet.find tblname (Database.tableset db) in let row = Table.find_exn tblname objref tbl in - let fvlist = Row.fold (fun k _ _ d env -> (k,d)::env) row [] in + let fvlist = Row.fold (fun k _ _ _ d env -> (k,d)::env) row [] in (* Unfortunately the interface distinguishes between Set(Ref _) types and ordinary fields *) let schema = Schema.table tblname (Database.schema db) in @@ -155,7 +155,7 @@ let delete_row_locked t tblname objref = let db = get_database t in Database.notify (PreDelete(tblname, objref)) db; update_database t (remove_row tblname objref); - Database.notify (Delete(tblname, objref, Row.fold (fun k _ _ v acc -> (k, v) :: acc) row [])) (get_database t) + Database.notify (Delete(tblname, objref, Row.fold (fun k _ _ _ v acc -> (k, v) :: acc) row [])) (get_database t) let delete_row t tblname objref = with_lock (fun () -> delete_row_locked t tblname objref) @@ -176,7 +176,7 @@ let create_row_locked t tblname kvs' new_objref = let row = Row.add_defaults g schema row in W.debug "create_row %s (%s) [%s]" tblname new_objref (String.concat "," (List.map (fun (k,v)->"("^k^","^"v"^")") kvs')); update_database t (add_row tblname new_objref row); - Database.notify (Create(tblname, new_objref, Row.fold (fun k _ _ v acc -> (k, v) :: acc) row [])) (get_database t) + Database.notify (Create(tblname, new_objref, Row.fold (fun k _ _ _ v acc -> (k, v) :: acc) row [])) (get_database t) let create_row t tblname kvs' new_objref = with_lock (fun () -> create_row_locked t tblname kvs' new_objref) @@ -186,7 +186,7 @@ let read_field_where t rcd = let db = get_database t in let tbl = TableSet.find rcd.table (Database.tableset db) in Table.fold - (fun r _ _ row acc -> + (fun r _ _ _ row acc -> let field = Row.find rcd.where_field row in if field = rcd.where_value then Row.find rcd.return row :: acc else acc ) tbl [] @@ -209,7 +209,7 @@ let db_get_by_name_label t tbl label = (* Read references from tbl *) let read_refs t tblname = let tbl = TableSet.find tblname (Database.tableset (get_database t)) in - Table.fold (fun r _ _ _ acc -> r :: acc) tbl [] + Table.fold (fun r _ _ _ _ acc -> r :: acc) tbl [] (* Return a list of all the refs for which the expression returns true. *) let find_refs_with_filter_internal db (tblname: string) (expr: Db_filter_types.expr) = @@ -218,7 +218,7 @@ let find_refs_with_filter_internal db (tblname: string) (expr: Db_filter_types.e | Db_filter_types.Literal x -> x | Db_filter_types.Field x -> Row.find x row in Table.fold - (fun r _ _ row acc -> + (fun r _ _ _ row acc -> if Db_filter.eval_expr (eval_val row) expr then Row.find Db_names.ref row :: acc else acc ) tbl [] @@ -377,8 +377,8 @@ let make t connections default_schema = (** Return an association list of table name * record count *) let stats t = - TableSet.fold (fun name _ _ tbl acc -> - let size = Table.fold (fun _ _ _ _ acc -> acc + 1) tbl 0 in + TableSet.fold (fun name _ _ _ tbl acc -> + let size = Table.fold (fun _ _ _ _ _ acc -> acc + 1) tbl 0 in (name, size) :: acc) (Database.tableset (get_database t)) [] diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 9f155384530..aae85416fb5 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -29,7 +29,7 @@ module type MAP = sig type value val add: Time.t -> string -> value -> t -> t val empty : t - val fold : (string -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold : (string -> Time.t -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -44,7 +44,7 @@ module Make = functor(V: VAL) -> struct v : V.v } type map_t = x StringMap.t let empty = StringMap.empty - let fold f = StringMap.fold (fun key x -> f key x.created x.updated x.v) + let fold f = StringMap.fold (fun key x -> f key x.created x.updated 0L x.v) let add generation key value = StringMap.add key {created=generation; updated=generation; v=value} let find key map = (StringMap.find key map).v let mem = StringMap.mem @@ -150,7 +150,7 @@ module Table : TABLE = struct acc in fold_over_deleted t.deleted acc let rows t = - fold (fun _ _ _ r rs -> r :: rs) t [] + fold (fun _ _ _ _ r rs -> r :: rs) t [] end module StringTableMap = Make(struct type v = Table.t end) @@ -281,9 +281,9 @@ module Database = struct (* Recompute the keymap *) let keymap = TableSet.fold - (fun tblname _ _ tbl acc -> + (fun tblname _ _ _ tbl acc -> Table.fold - (fun rf _ _ row acc -> + (fun rf _ _ _ row acc -> let acc = KeyMap.add_unique tblname Db_names.ref (Ref rf) (tblname, rf) acc in if Row.mem Db_names.uuid row then KeyMap.add_unique tblname Db_names.uuid (Uuid (Row.find Db_names.uuid row)) (tblname, rf) acc @@ -303,7 +303,7 @@ module Database = struct VBDs may be missing a VBDs field altogether on upgrade) *) let many_tbl' = Table.fold - (fun vm _ _ row acc -> + (fun vm _ _ _ row acc -> let row' = Row.add g many_fldname (SExpr.string_of (SExpr.Node [])) row in Table.add g vm row' acc) many_tbl Table.empty in @@ -311,7 +311,7 @@ module Database = struct (* Build up a table of VM -> VBDs *) let vm_to_vbds = Table.fold - (fun vbd _ _ row acc -> + (fun vbd _ _ _ row acc -> let vm = Row.find one_fldname row in let existing = if Schema.ForeignMap.mem vm acc then Schema.ForeignMap.find vm acc else [] in Schema.ForeignMap.add vm (vbd :: existing) acc) diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 3d9fb600545..3f08235f9fd 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -13,7 +13,7 @@ module type MAP = sig type value val add: Time.t -> string -> value -> t -> t val empty : t - val fold : (string -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold : (string -> Time.t -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit diff --git a/ocaml/database/db_upgrade.ml b/ocaml/database/db_upgrade.ml index 08bcfd84346..a264b5c0fc0 100644 --- a/ocaml/database/db_upgrade.ml +++ b/ocaml/database/db_upgrade.ml @@ -21,7 +21,7 @@ open Pervasiveext (** Automatically insert blank tables and new columns with default values *) let generic_database_upgrade db = - let existing_table_names = TableSet.fold (fun name _ _ _ acc -> name :: acc) (Database.tableset db) [] in + let existing_table_names = TableSet.fold (fun name _ _ _ _ acc -> name :: acc) (Database.tableset db) [] in let schema_table_names = Schema.table_names (Database.schema db) in let created_table_names = Listext.List.set_difference schema_table_names existing_table_names in let g = Manifest.generation (Database.manifest db) in @@ -36,7 +36,7 @@ let generic_database_upgrade db = (fun db tblname -> let tbl = TableSet.find tblname (Database.tableset db) in let schema = Schema.table tblname (Database.schema db) in - let add_fields_to_row objref _ _ r tbl : Table.t = + let add_fields_to_row objref _ _ _ r tbl : Table.t = let row = Row.add_defaults g schema r in Table.add g objref row tbl in let tbl = Table.fold add_fields_to_row tbl Table.empty in diff --git a/ocaml/database/db_xml.ml b/ocaml/database/db_xml.ml index 63730b1cc50..16ba25ac4ec 100644 --- a/ocaml/database/db_xml.ml +++ b/ocaml/database/db_xml.ml @@ -43,13 +43,13 @@ module To = struct (* Marshal a whole database table to an Xmlm output abstraction *) let table schema (output: Xmlm.output) name (tbl: Table.t) = - let record rf ctime mtime (row: Row.t) _ = + let record rf ctime mtime _ (row: Row.t) _ = let preamble = if persist_generation_counts then [("__mtime",Generation.to_string mtime); ("__ctime",Generation.to_string ctime); ("ref",rf)] else [("ref",rf)] in - let (tag: Xmlm.tag) = make_tag "row" (List.rev (Row.fold (fun k _ _ v acc -> (k, Xml_spaces.protect v) :: acc) row preamble)) in + let (tag: Xmlm.tag) = make_tag "row" (List.rev (Row.fold (fun k _ _ _ v acc -> (k, Xml_spaces.protect v) :: acc) row preamble)) in Xmlm.output output (`El_start tag); Xmlm.output output `El_end in let tag = make_tag "table" [ "name", name ] in diff --git a/ocaml/db_process/xapi_db_process.ml b/ocaml/db_process/xapi_db_process.ml index ba3cc0baddb..0f9aaa5c4d5 100644 --- a/ocaml/db_process/xapi_db_process.ml +++ b/ocaml/db_process/xapi_db_process.ml @@ -99,7 +99,7 @@ let find_my_host_row() = let localhost_uuid = Xapi_inventory.lookup Xapi_inventory._installation_uuid in let db = Db_ref.get_database (Db_backend.make ()) in let tbl = TableSet.find Db_names.host (Database.tableset db) in - Table.fold (fun r _ _ row acc -> if Row.find Db_names.uuid row = localhost_uuid then (Some (r, row)) else acc) tbl None + Table.fold (fun r _ _ _ row acc -> if Row.find Db_names.uuid row = localhost_uuid then (Some (r, row)) else acc) tbl None let _iscsi_iqn = "iscsi_iqn" let _other_config = "other_config" diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 5d13669e80d..2a36c59ced9 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -505,10 +505,10 @@ let from_inner __context session subs from from_t deadline = let valid_ref_counts = Db_cache_types.TableSet.fold - (fun tablename _ _ table acc -> + (fun tablename _ _ _ table acc -> (String.lowercase tablename, (Db_cache_types.Table.fold - (fun r _ _ _ acc -> Int32.add 1l acc) table 0l))::acc) + (fun r _ _ _ _ acc -> Int32.add 1l acc) table 0l))::acc) tableset [] in { diff --git a/opam b/opam index 1c886287aae..9a7e9551fa7 100644 --- a/opam +++ b/opam @@ -10,7 +10,6 @@ depends: [ "ocamlfind" "xapi-idl" "xapi-libs-transitional" - "xen-api-client" "xapi-netdev" "omake" "cdrom" From 5c6786fab073843730a34a54d9ae343ab084fcd6 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 21:04:49 +0000 Subject: [PATCH 05/21] Database: every function which takes 3 Time.ts now takes Stat.t The 3 Time.t's are like a file "stat": - a create time - a last-modified time - a deletion time (since the events are historical) Signed-off-by: David Scott --- ocaml/database/database_test.ml | 30 +++++++-------- ocaml/database/db_backend.ml | 16 ++++---- ocaml/database/db_cache_impl.ml | 18 ++++----- ocaml/database/db_cache_types.ml | 59 ++++++++++++++++++----------- ocaml/database/db_cache_types.mli | 16 ++++++-- ocaml/database/db_upgrade.ml | 4 +- ocaml/database/db_xml.ml | 6 +-- ocaml/db_process/xapi_db_process.ml | 2 +- ocaml/xapi/xapi_event.ml | 18 ++++----- 9 files changed, 95 insertions(+), 74 deletions(-) diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index 8973e021986..8ee42ea24e8 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -175,19 +175,19 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let dump db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun c u d name table acc -> + (fun _ name table acc -> Db_cache_types.Table.fold_over_recent g - (fun c u d r acc -> + (fun { Db_cache_types.Stat.created; modified; deleted } r acc -> let s = try let row = Db_cache_types.Table.find r table in let s = Db_cache_types.Row.fold_over_recent g - (fun c u d k v acc -> + (fun _ k v acc -> Printf.sprintf "%s %s=%s" acc k v) (fun () -> ()) row "" in s with _ -> "(deleted)" in - Printf.printf "%s(%s): (%Ld %Ld %Ld) %s\n" name r c u d s; + Printf.printf "%s(%s): (%Ld %Ld %Ld) %s\n" name r created modified deleted s; ()) (fun () -> ()) table ()) (fun () -> ()) tables () in @@ -195,22 +195,22 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let get_created db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun c u d name table acc -> + (fun _ name table acc -> Db_cache_types.Table.fold_over_recent g - (fun c u d r acc -> - if c>=g then (name,r)::acc else acc) ignore table acc + (fun { Db_cache_types.Stat.created } r acc -> + if created>=g then (name,r)::acc else acc) ignore table acc ) (fun () -> ()) tables [] in let get_updated db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun c u d name table acc -> + (fun _ name table acc -> Db_cache_types.Table.fold_over_recent g - (fun c u d r acc -> + (fun _ r acc -> let row = Db_cache_types.Table.find r table in Db_cache_types.Row.fold_over_recent g - (fun c u d k v acc -> + (fun _ k v acc -> (r,(k,v))::acc) (fun () -> ()) row acc) ignore table acc) (fun () -> ()) tables [] in @@ -218,18 +218,18 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let get_deleted db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun c u d name table acc -> + (fun _ name table acc -> Db_cache_types.Table.fold_over_recent g - (fun c u d r acc -> - if d > g then r::acc else acc) + (fun { Db_cache_types.Stat.deleted } r acc -> + if deleted > g then r::acc else acc) ignore table acc) (fun () -> ()) tables [] in let get_max db = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent (-1L) - (fun c u d _ _ largest -> - max c (max u (max d largest))) (fun () -> ()) tables (-1L) + (fun { Db_cache_types.Stat.created; modified; deleted } _ _ largest -> + max created (max modified (max deleted largest))) (fun () -> ()) tables (-1L) in let db = Db_ref.get_database t in diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index 96071358bea..fd460e3957c 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -42,27 +42,27 @@ let blow_away_non_persistent_fields (schema: Schema.t) db = (* Generate a new row given a table schema *) let row schema row : Row.t * int64 = Row.fold - (fun name created updated _ v (acc,max_upd) -> + (fun name { Stat.created; modified } v (acc,max_upd) -> try let col = Schema.Table.find name schema in - let v',updated' = if col.Schema.Column.persistent then v,updated else col.Schema.Column.empty,g in - (Row.update updated' name "" (fun _ -> v') (Row.add created name v' acc),max max_upd updated') + let v',modified' = if col.Schema.Column.persistent then v,modified else col.Schema.Column.empty,g in + (Row.update modified' name "" (fun _ -> v') (Row.add created name v' acc),max max_upd modified') with Not_found -> Printf.printf "Skipping unknown column: %s\n%!" name; - (acc,max max_upd updated)) row (Row.empty,0L) in + (acc,max max_upd modified)) row (Row.empty,0L) in (* Generate a new table *) let table tblname tbl : Table.t = let schema = Schema.Database.find tblname schema.Schema.database in Table.fold - (fun objref created updated _ r acc -> + (fun objref { Stat.created; modified } r acc -> let (r,updated) = row schema r in - Table.update updated objref Row.empty (fun _ -> r) (Table.add created objref r acc)) tbl Table.empty in + Table.update modified objref Row.empty (fun _ -> r) (Table.add created objref r acc)) tbl Table.empty in Database.update (fun ts -> TableSet.fold - (fun tblname created updated _ tbl acc -> + (fun tblname { Stat.created; modified } tbl acc -> let tbl' = table tblname tbl in - TableSet.add updated tblname tbl' acc) ts TableSet.empty) + TableSet.add modified tblname tbl' acc) ts TableSet.empty) db let db_registration_mutex = Mutex.create () diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index 011f6933f7a..7702f315505 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -111,7 +111,7 @@ let read_set_ref t rcd = Printf.printf "Illegal read_set_ref query { table = %s; where_field = %s; where_value = %s; return = %s }; falling back to linear scan\n%!" rcd.table rcd.where_field rcd.where_value rcd.return; let tbl = TableSet.find rcd.table (Database.tableset db) in Table.fold - (fun rf _ _ _ row acc -> + (fun rf _ row acc -> if Row.find rcd.where_field row = rcd.where_value then Row.find rcd.return row :: acc else acc) tbl [] @@ -127,7 +127,7 @@ let read_set_ref t rcd = let read_record_internal db tblname objref = let tbl = TableSet.find tblname (Database.tableset db) in let row = Table.find_exn tblname objref tbl in - let fvlist = Row.fold (fun k _ _ _ d env -> (k,d)::env) row [] in + let fvlist = Row.fold (fun k _ d env -> (k,d)::env) row [] in (* Unfortunately the interface distinguishes between Set(Ref _) types and ordinary fields *) let schema = Schema.table tblname (Database.schema db) in @@ -155,7 +155,7 @@ let delete_row_locked t tblname objref = let db = get_database t in Database.notify (PreDelete(tblname, objref)) db; update_database t (remove_row tblname objref); - Database.notify (Delete(tblname, objref, Row.fold (fun k _ _ _ v acc -> (k, v) :: acc) row [])) (get_database t) + Database.notify (Delete(tblname, objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row [])) (get_database t) let delete_row t tblname objref = with_lock (fun () -> delete_row_locked t tblname objref) @@ -176,7 +176,7 @@ let create_row_locked t tblname kvs' new_objref = let row = Row.add_defaults g schema row in W.debug "create_row %s (%s) [%s]" tblname new_objref (String.concat "," (List.map (fun (k,v)->"("^k^","^"v"^")") kvs')); update_database t (add_row tblname new_objref row); - Database.notify (Create(tblname, new_objref, Row.fold (fun k _ _ _ v acc -> (k, v) :: acc) row [])) (get_database t) + Database.notify (Create(tblname, new_objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row [])) (get_database t) let create_row t tblname kvs' new_objref = with_lock (fun () -> create_row_locked t tblname kvs' new_objref) @@ -186,7 +186,7 @@ let read_field_where t rcd = let db = get_database t in let tbl = TableSet.find rcd.table (Database.tableset db) in Table.fold - (fun r _ _ _ row acc -> + (fun r _ row acc -> let field = Row.find rcd.where_field row in if field = rcd.where_value then Row.find rcd.return row :: acc else acc ) tbl [] @@ -209,7 +209,7 @@ let db_get_by_name_label t tbl label = (* Read references from tbl *) let read_refs t tblname = let tbl = TableSet.find tblname (Database.tableset (get_database t)) in - Table.fold (fun r _ _ _ _ acc -> r :: acc) tbl [] + Table.fold (fun r _ _ acc -> r :: acc) tbl [] (* Return a list of all the refs for which the expression returns true. *) let find_refs_with_filter_internal db (tblname: string) (expr: Db_filter_types.expr) = @@ -218,7 +218,7 @@ let find_refs_with_filter_internal db (tblname: string) (expr: Db_filter_types.e | Db_filter_types.Literal x -> x | Db_filter_types.Field x -> Row.find x row in Table.fold - (fun r _ _ _ row acc -> + (fun r _ row acc -> if Db_filter.eval_expr (eval_val row) expr then Row.find Db_names.ref row :: acc else acc ) tbl [] @@ -377,8 +377,8 @@ let make t connections default_schema = (** Return an association list of table name * record count *) let stats t = - TableSet.fold (fun name _ _ _ tbl acc -> - let size = Table.fold (fun _ _ _ _ _ acc -> acc + 1) tbl 0 in + TableSet.fold (fun name _ tbl acc -> + let size = Table.fold (fun _ _ _ acc -> acc + 1) tbl 0 in (name, size) :: acc) (Database.tableset (get_database t)) [] diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index aae85416fb5..87613444a8c 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -8,6 +8,15 @@ module Time = struct type t = Generation.t end +module Stat = struct + type t = { + created: Time.t; + modified: Time.t; + deleted: Time.t; + } + let make x = { created = x; modified = x; deleted = 0L } +end + (** Database tables, columns and rows are all indexed by string, each using a specialised StringMap *) module StringMap = struct @@ -29,7 +38,7 @@ module type MAP = sig type value val add: Time.t -> string -> value -> t -> t val empty : t - val fold : (string -> Time.t -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -39,21 +48,25 @@ end (** A specialised StringMap whose range type is V.v, and which keeps a record of when records are created/updated *) module Make = functor(V: VAL) -> struct type x = { - created : Time.t; - updated : Time.t; - v : V.v } + stat: Stat.t; + v : V.v + } type map_t = x StringMap.t let empty = StringMap.empty - let fold f = StringMap.fold (fun key x -> f key x.created x.updated 0L x.v) - let add generation key value = StringMap.add key {created=generation; updated=generation; v=value} + let fold f = StringMap.fold (fun key x -> f key x.stat x.v) + let add generation key v = + let stat = Stat.make generation in + StringMap.add key { stat; v } let find key map = (StringMap.find key map).v let mem = StringMap.mem let iter f = StringMap.iter (fun key x -> f key x.v) let remove = StringMap.remove let update_generation generation key default f row = - StringMap.update key {created=generation; updated=generation; v=default} (fun x -> {x with updated=generation; v=f x.v}) row + let default = { stat = Stat.make generation; v = default } in + StringMap.update key default (fun x -> { stat = { x.stat with Stat.modified=generation }; v=f x.v}) row let update generation key default f row = - let updatefn () = StringMap.update key {created=generation; updated=generation; v=default} (fun x -> {x with updated=generation; v=f x.v}) row in + let default = { stat = Stat.make generation; v = default } in + let updatefn () = StringMap.update key default (fun x -> { stat = { x.stat with Stat.modified=generation }; v=f x.v}) row in if mem key row then let old = find key row in @@ -63,7 +76,7 @@ module Make = functor(V: VAL) -> struct else updatefn () else updatefn () - let fold_over_recent since f _ t initial = StringMap.fold (fun x y z -> if y.updated > since then f y.created y.updated 0L x y.v z else z) t initial + let fold_over_recent since f _ t initial = StringMap.fold (fun x y z -> if y.stat.Stat.modified > since then f y.stat x y.v z else z) t initial end module StringStringMap = Make(struct type v = string end) @@ -74,7 +87,7 @@ module type ROW = sig val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Row : ROW = struct @@ -102,7 +115,7 @@ module type TABLE = sig val rows : t -> Row.t list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> Row.t - val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Stat.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : TABLE = struct @@ -122,7 +135,7 @@ module Table : TABLE = struct let remove g key t = let upper_length_deleted_queue = 512 in let lower_length_deleted_queue = 256 in - let created = (StringMap.find key t.rows).StringRowMap.created in + let created = (StringMap.find key t.rows).StringRowMap.stat.Stat.created in let new_element = (created,g,key) in let new_len,new_deleted = if t.deleted_len + 1 < upper_length_deleted_queue @@ -135,22 +148,22 @@ module Table : TABLE = struct let update_generation g key default f t = {t with rows = StringRowMap.update_generation g key default f t.rows } let update g key default f t = {t with rows = StringRowMap.update g key default f t.rows} let fold_over_recent since f errf t acc = - let acc = StringRowMap.fold_over_recent since (fun c u d x _ z -> f c u d x z) errf t.rows acc in + let acc = StringRowMap.fold_over_recent since (fun stat x _ z -> f stat x z) errf t.rows acc in let rec fold_over_deleted deleted acc = match deleted with - | (created,destroyed,r)::xs -> + | (created,deleted,r)::xs -> let new_acc = - if (destroyed > since) && (created <= since) - then (f created 0L destroyed r acc) + if (deleted > since) && (created <= since) + then (f { Stat.created; modified = deleted; deleted } r acc) else acc in - if destroyed <= since then new_acc else fold_over_deleted xs new_acc + if deleted <= since then new_acc else fold_over_deleted xs new_acc | [] -> errf (); acc in fold_over_deleted t.deleted acc let rows t = - fold (fun _ _ _ _ r rs -> r :: rs) t [] + fold (fun _ _ r rs -> r :: rs) t [] end module StringTableMap = Make(struct type v = Table.t end) @@ -158,7 +171,7 @@ module StringTableMap = Make(struct type v = Table.t end) module type TABLESET = sig include MAP with type value = Table.t - val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end @@ -281,9 +294,9 @@ module Database = struct (* Recompute the keymap *) let keymap = TableSet.fold - (fun tblname _ _ _ tbl acc -> + (fun tblname _ tbl acc -> Table.fold - (fun rf _ _ _ row acc -> + (fun rf _ row acc -> let acc = KeyMap.add_unique tblname Db_names.ref (Ref rf) (tblname, rf) acc in if Row.mem Db_names.uuid row then KeyMap.add_unique tblname Db_names.uuid (Uuid (Row.find Db_names.uuid row)) (tblname, rf) acc @@ -303,7 +316,7 @@ module Database = struct VBDs may be missing a VBDs field altogether on upgrade) *) let many_tbl' = Table.fold - (fun vm _ _ _ row acc -> + (fun vm _ row acc -> let row' = Row.add g many_fldname (SExpr.string_of (SExpr.Node [])) row in Table.add g vm row' acc) many_tbl Table.empty in @@ -311,7 +324,7 @@ module Database = struct (* Build up a table of VM -> VBDs *) let vm_to_vbds = Table.fold - (fun vbd _ _ _ row acc -> + (fun vbd _ row acc -> let vm = Row.find one_fldname row in let existing = if Schema.ForeignMap.mem vm acc then Schema.ForeignMap.find vm acc else [] in Schema.ForeignMap.add vm (vbd :: existing) acc) diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 3f08235f9fd..9339b1deb23 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -8,12 +8,20 @@ module Time : sig type t = Generation.t end +module Stat : sig + type t = { + created: Time.t; + modified: Time.t; + deleted: Time.t; + } +end + module type MAP = sig type t type value val add: Time.t -> string -> value -> t -> t val empty : t - val fold : (string -> Time.t -> Time.t -> Time.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -26,7 +34,7 @@ module Row : sig val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : sig @@ -36,13 +44,13 @@ module Table : sig val rows : t -> value list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> value - val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Stat.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module TableSet : sig include MAP with type value = Table.t - val fold_over_recent : Time.t -> (Time.t -> Time.t -> Time.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end diff --git a/ocaml/database/db_upgrade.ml b/ocaml/database/db_upgrade.ml index a264b5c0fc0..2584e62430d 100644 --- a/ocaml/database/db_upgrade.ml +++ b/ocaml/database/db_upgrade.ml @@ -21,7 +21,7 @@ open Pervasiveext (** Automatically insert blank tables and new columns with default values *) let generic_database_upgrade db = - let existing_table_names = TableSet.fold (fun name _ _ _ _ acc -> name :: acc) (Database.tableset db) [] in + let existing_table_names = TableSet.fold (fun name _ _ acc -> name :: acc) (Database.tableset db) [] in let schema_table_names = Schema.table_names (Database.schema db) in let created_table_names = Listext.List.set_difference schema_table_names existing_table_names in let g = Manifest.generation (Database.manifest db) in @@ -36,7 +36,7 @@ let generic_database_upgrade db = (fun db tblname -> let tbl = TableSet.find tblname (Database.tableset db) in let schema = Schema.table tblname (Database.schema db) in - let add_fields_to_row objref _ _ _ r tbl : Table.t = + let add_fields_to_row objref _ r tbl : Table.t = let row = Row.add_defaults g schema r in Table.add g objref row tbl in let tbl = Table.fold add_fields_to_row tbl Table.empty in diff --git a/ocaml/database/db_xml.ml b/ocaml/database/db_xml.ml index 16ba25ac4ec..04a7921e740 100644 --- a/ocaml/database/db_xml.ml +++ b/ocaml/database/db_xml.ml @@ -43,13 +43,13 @@ module To = struct (* Marshal a whole database table to an Xmlm output abstraction *) let table schema (output: Xmlm.output) name (tbl: Table.t) = - let record rf ctime mtime _ (row: Row.t) _ = + let record rf { Stat.created; modified } (row: Row.t) _ = let preamble = if persist_generation_counts - then [("__mtime",Generation.to_string mtime); ("__ctime",Generation.to_string ctime); ("ref",rf)] + then [("__mtime",Generation.to_string modified); ("__ctime",Generation.to_string created); ("ref",rf)] else [("ref",rf)] in - let (tag: Xmlm.tag) = make_tag "row" (List.rev (Row.fold (fun k _ _ _ v acc -> (k, Xml_spaces.protect v) :: acc) row preamble)) in + let (tag: Xmlm.tag) = make_tag "row" (List.rev (Row.fold (fun k _ v acc -> (k, Xml_spaces.protect v) :: acc) row preamble)) in Xmlm.output output (`El_start tag); Xmlm.output output `El_end in let tag = make_tag "table" [ "name", name ] in diff --git a/ocaml/db_process/xapi_db_process.ml b/ocaml/db_process/xapi_db_process.ml index 0f9aaa5c4d5..d66e1340121 100644 --- a/ocaml/db_process/xapi_db_process.ml +++ b/ocaml/db_process/xapi_db_process.ml @@ -99,7 +99,7 @@ let find_my_host_row() = let localhost_uuid = Xapi_inventory.lookup Xapi_inventory._installation_uuid in let db = Db_ref.get_database (Db_backend.make ()) in let tbl = TableSet.find Db_names.host (Database.tableset db) in - Table.fold (fun r _ _ _ row acc -> if Row.find Db_names.uuid row = localhost_uuid then (Some (r, row)) else acc) tbl None + Table.fold (fun r _ row acc -> if Row.find Db_names.uuid row = localhost_uuid then (Some (r, row)) else acc) tbl None let _iscsi_iqn = "iscsi_iqn" let _other_config = "other_config" diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 2a36c59ced9..bdc283bbb0b 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -435,17 +435,17 @@ let from_inner __context session subs from from_t deadline = (msg_gen, messages, tableset, List.fold_left (fun acc table -> Db_cache_types.Table.fold_over_recent !last_generation - (fun ctime mtime dtime objref (creates,mods,deletes,last) -> + (fun { Db_cache_types.Stat.created; modified; deleted } objref (creates,mods,deletes,last) -> if Subscription.object_matches subs (String.lowercase table) objref then begin - let last = max last (max mtime dtime) in (* mtime guaranteed to always be larger than ctime *) - if dtime > 0L then begin - if ctime > !last_generation then + let last = max last (max modified deleted) in (* mtime guaranteed to always be larger than ctime *) + if deleted > 0L then begin + if created > !last_generation then (creates,mods,deletes,last) (* It was created and destroyed since the last update *) else - (creates,mods,(table, objref, dtime)::deletes,last) (* It might have been modified, but we can't tell now *) + (creates,mods,(table, objref, deleted)::deletes,last) (* It might have been modified, but we can't tell now *) end else begin - ((if ctime > !last_generation then (table, objref, ctime)::creates else creates), - (if mtime > !last_generation then (table, objref, mtime)::mods else mods), + ((if created > !last_generation then (table, objref, created)::creates else creates), + (if modified > !last_generation then (table, objref, modified)::mods else mods), deletes, last) end end else begin @@ -505,10 +505,10 @@ let from_inner __context session subs from from_t deadline = let valid_ref_counts = Db_cache_types.TableSet.fold - (fun tablename _ _ _ table acc -> + (fun tablename _ table acc -> (String.lowercase tablename, (Db_cache_types.Table.fold - (fun r _ _ _ _ acc -> Int32.add 1l acc) table 0l))::acc) + (fun r _ _ acc -> Int32.add 1l acc) table 0l))::acc) tableset [] in { From e8326051bcdf7fcc747adef3d9332a3b4c23dad0 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 21:21:33 +0000 Subject: [PATCH 06/21] Database: fold_over_recent takes a function with the same signature as fold Previously fold and fold_over_recent used a slightly different permutation of arguments in the function being folded over the data. The OCaml stdlib convention is to have a function (key -> value -> 'a -> 'a) so we follow this. Signed-off-by: David Scott --- ocaml/database/database_test.ml | 22 +++++++++++----------- ocaml/database/db_cache_types.ml | 12 ++++++------ ocaml/database/db_cache_types.mli | 6 +++--- ocaml/xapi/xapi_event.ml | 2 +- 4 files changed, 21 insertions(+), 21 deletions(-) diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index 8ee42ea24e8..62494c6b972 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -175,14 +175,14 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let dump db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun _ name table acc -> + (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g - (fun { Db_cache_types.Stat.created; modified; deleted } r acc -> + (fun r { Db_cache_types.Stat.created; modified; deleted } acc -> let s = try let row = Db_cache_types.Table.find r table in let s = Db_cache_types.Row.fold_over_recent g - (fun _ k v acc -> + (fun k _ v acc -> Printf.sprintf "%s %s=%s" acc k v) (fun () -> ()) row "" in s with _ -> "(deleted)" @@ -195,9 +195,9 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let get_created db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun _ name table acc -> + (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g - (fun { Db_cache_types.Stat.created } r acc -> + (fun r { Db_cache_types.Stat.created } acc -> if created>=g then (name,r)::acc else acc) ignore table acc ) (fun () -> ()) tables [] in @@ -205,12 +205,12 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let get_updated db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun _ name table acc -> + (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g - (fun _ r acc -> + (fun r _ acc -> let row = Db_cache_types.Table.find r table in Db_cache_types.Row.fold_over_recent g - (fun _ k v acc -> + (fun k _ v acc -> (r,(k,v))::acc) (fun () -> ()) row acc) ignore table acc) (fun () -> ()) tables [] in @@ -218,9 +218,9 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let get_deleted db g = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g - (fun _ name table acc -> + (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g - (fun { Db_cache_types.Stat.deleted } r acc -> + (fun r { Db_cache_types.Stat.deleted } acc -> if deleted > g then r::acc else acc) ignore table acc) (fun () -> ()) tables [] in @@ -228,7 +228,7 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let get_max db = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent (-1L) - (fun { Db_cache_types.Stat.created; modified; deleted } _ _ largest -> + (fun _ { Db_cache_types.Stat.created; modified; deleted } _ largest -> max created (max modified (max deleted largest))) (fun () -> ()) tables (-1L) in diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 87613444a8c..89fb0ec8709 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -76,7 +76,7 @@ module Make = functor(V: VAL) -> struct else updatefn () else updatefn () - let fold_over_recent since f _ t initial = StringMap.fold (fun x y z -> if y.stat.Stat.modified > since then f y.stat x y.v z else z) t initial + let fold_over_recent since f _ t initial = StringMap.fold (fun x y z -> if y.stat.Stat.modified > since then f x y.stat y.v z else z) t initial end module StringStringMap = Make(struct type v = string end) @@ -87,7 +87,7 @@ module type ROW = sig val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Row : ROW = struct @@ -115,7 +115,7 @@ module type TABLE = sig val rows : t -> Row.t list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> Row.t - val fold_over_recent : Time.t -> (Stat.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : TABLE = struct @@ -148,13 +148,13 @@ module Table : TABLE = struct let update_generation g key default f t = {t with rows = StringRowMap.update_generation g key default f t.rows } let update g key default f t = {t with rows = StringRowMap.update g key default f t.rows} let fold_over_recent since f errf t acc = - let acc = StringRowMap.fold_over_recent since (fun stat x _ z -> f stat x z) errf t.rows acc in + let acc = StringRowMap.fold_over_recent since (fun x stat _ z -> f x stat z) errf t.rows acc in let rec fold_over_deleted deleted acc = match deleted with | (created,deleted,r)::xs -> let new_acc = if (deleted > since) && (created <= since) - then (f { Stat.created; modified = deleted; deleted } r acc) + then (f r { Stat.created; modified = deleted; deleted } acc) else acc in if deleted <= since then new_acc else fold_over_deleted xs new_acc @@ -171,7 +171,7 @@ module StringTableMap = Make(struct type v = Table.t end) module type TABLESET = sig include MAP with type value = Table.t - val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 9339b1deb23..eacd2acead7 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -34,7 +34,7 @@ module Row : sig val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : sig @@ -44,13 +44,13 @@ module Table : sig val rows : t -> value list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> value - val fold_over_recent : Time.t -> (Stat.t -> string -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module TableSet : sig include MAP with type value = Table.t - val fold_over_recent : Time.t -> (Stat.t -> string -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index bdc283bbb0b..450dc6deb0a 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -435,7 +435,7 @@ let from_inner __context session subs from from_t deadline = (msg_gen, messages, tableset, List.fold_left (fun acc table -> Db_cache_types.Table.fold_over_recent !last_generation - (fun { Db_cache_types.Stat.created; modified; deleted } objref (creates,mods,deletes,last) -> + (fun objref { Db_cache_types.Stat.created; modified; deleted } (creates,mods,deletes,last) -> if Subscription.object_matches subs (String.lowercase table) objref then begin let last = max last (max modified deleted) in (* mtime guaranteed to always be larger than ctime *) if deleted > 0L then begin From 8ca4d226cc9e5d7e8dc6d82376830ff2a07e4215 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 21:54:22 +0000 Subject: [PATCH 07/21] Database: split Table.fold_over_recent into fold_over_recent and fold_over_deleted This allows fold_over_recent to have the same signature as the other functions with the same name. Tracking of deleted references (without values) is specific to the Table. Signed-off-by: David Scott --- ocaml/database/database_test.ml | 8 ++++---- ocaml/database/db_cache_types.ml | 34 ++++++++++++++++--------------- ocaml/database/db_cache_types.mli | 3 ++- ocaml/xapi/xapi_event.ml | 29 ++++++++++++++++---------- 4 files changed, 42 insertions(+), 32 deletions(-) diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index 62494c6b972..7564e0e01cf 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -177,7 +177,7 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct Db_cache_types.TableSet.fold_over_recent g (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g - (fun r { Db_cache_types.Stat.created; modified; deleted } acc -> + (fun r { Db_cache_types.Stat.created; modified; deleted } _ acc -> let s = try let row = Db_cache_types.Table.find r table in @@ -197,7 +197,7 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct Db_cache_types.TableSet.fold_over_recent g (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g - (fun r { Db_cache_types.Stat.created } acc -> + (fun r { Db_cache_types.Stat.created } _ acc -> if created>=g then (name,r)::acc else acc) ignore table acc ) (fun () -> ()) tables [] in @@ -207,7 +207,7 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct Db_cache_types.TableSet.fold_over_recent g (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g - (fun r _ acc -> + (fun r _ _ acc -> let row = Db_cache_types.Table.find r table in Db_cache_types.Row.fold_over_recent g (fun k _ v acc -> @@ -219,7 +219,7 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent g (fun name _ table acc -> - Db_cache_types.Table.fold_over_recent g + Db_cache_types.Table.fold_over_deleted g (fun r { Db_cache_types.Stat.deleted } acc -> if deleted > g then r::acc else acc) ignore table acc) (fun () -> ()) tables [] diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 89fb0ec8709..a9935f79bba 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -115,7 +115,8 @@ module type TABLE = sig val rows : t -> Row.t list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> Row.t - val fold_over_recent : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : TABLE = struct @@ -147,21 +148,22 @@ module Table : TABLE = struct deleted = new_deleted} let update_generation g key default f t = {t with rows = StringRowMap.update_generation g key default f t.rows } let update g key default f t = {t with rows = StringRowMap.update g key default f t.rows} - let fold_over_recent since f errf t acc = - let acc = StringRowMap.fold_over_recent since (fun x stat _ z -> f x stat z) errf t.rows acc in - let rec fold_over_deleted deleted acc = - match deleted with - | (created,deleted,r)::xs -> - let new_acc = - if (deleted > since) && (created <= since) - then (f r { Stat.created; modified = deleted; deleted } acc) - else acc - in - if deleted <= since then new_acc else fold_over_deleted xs new_acc - | [] -> - errf (); - acc - in fold_over_deleted t.deleted acc + let fold_over_recent since f errf t acc = StringRowMap.fold_over_recent since f errf t.rows acc + + let fold_over_deleted since f errf t acc = + let rec loop xs acc = match xs with + | (created,deleted,r)::xs -> + let new_acc = + if (deleted > since) && (created <= since) + then (f r { Stat.created; modified = deleted; deleted } acc) + else acc + in + if deleted <= since then new_acc else loop xs new_acc + | [] -> + errf (); + acc in + loop t.deleted acc + let rows t = fold (fun _ _ r rs -> r :: rs) t [] end diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index eacd2acead7..ef9e495a139 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -44,7 +44,8 @@ module Table : sig val rows : t -> value list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> value - val fold_over_recent : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module TableSet : sig diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 450dc6deb0a..627a059f43f 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -434,20 +434,27 @@ let from_inner __context session subs from from_t deadline = if Subscription.table_matches subs "message" then (!Message.get_since_for_events) ~__context !last_msg_gen else (0L, []) in (msg_gen, messages, tableset, List.fold_left (fun acc table -> - Db_cache_types.Table.fold_over_recent !last_generation + (* Fold over the live objects *) + let acc = Db_cache_types.Table.fold_over_recent !last_generation + (fun objref { Db_cache_types.Stat.created; modified; deleted } _ (creates,mods,deletes,last) -> + if Subscription.object_matches subs (String.lowercase table) objref then begin + let last = max last (max modified deleted) in (* mtime guaranteed to always be larger than ctime *) + ((if created > !last_generation then (table, objref, created)::creates else creates), + (if modified > !last_generation then (table, objref, modified)::mods else mods), + deletes, last) + end else begin + (creates,mods,deletes,last) + end + ) (fun () -> ()) (Db_cache_types.TableSet.find table tableset) acc in + (* Fold over the deleted objects *) + Db_cache_types.Table.fold_over_deleted !last_generation (fun objref { Db_cache_types.Stat.created; modified; deleted } (creates,mods,deletes,last) -> if Subscription.object_matches subs (String.lowercase table) objref then begin let last = max last (max modified deleted) in (* mtime guaranteed to always be larger than ctime *) - if deleted > 0L then begin - if created > !last_generation then - (creates,mods,deletes,last) (* It was created and destroyed since the last update *) - else - (creates,mods,(table, objref, deleted)::deletes,last) (* It might have been modified, but we can't tell now *) - end else begin - ((if created > !last_generation then (table, objref, created)::creates else creates), - (if modified > !last_generation then (table, objref, modified)::mods else mods), - deletes, last) - end + if created > !last_generation then + (creates,mods,deletes,last) (* It was created and destroyed since the last update *) + else + (creates,mods,(table, objref, deleted)::deletes,last) (* It might have been modified, but we can't tell now *) end else begin (creates,mods,deletes,last) end From d7291d5b6e57c70a24533bf250eb94d569cf5386 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 22:00:16 +0000 Subject: [PATCH 08/21] Database: fold_over_recent have the same signature, so put in the common definition Now that all the common MAP instances have the same fold_over_recent signature, we can share the definition and avoid people playing "spot the difference" with a complicated type. Signed-off-by: David Scott --- ocaml/database/db_cache_types.ml | 4 +--- ocaml/database/db_cache_types.mli | 4 +--- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index a9935f79bba..d2d4f98e738 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -39,6 +39,7 @@ module type MAP = sig val add: Time.t -> string -> value -> t -> t val empty : t val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -87,7 +88,6 @@ module type ROW = sig val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Row : ROW = struct @@ -115,7 +115,6 @@ module type TABLE = sig val rows : t -> Row.t list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> Row.t - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end @@ -173,7 +172,6 @@ module StringTableMap = Make(struct type v = Table.t end) module type TABLESET = sig include MAP with type value = Table.t - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index ef9e495a139..d516efe64ca 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -22,6 +22,7 @@ module type MAP = sig val add: Time.t -> string -> value -> t -> t val empty : t val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -34,7 +35,6 @@ module Row : sig val add_defaults: Time.t -> Schema.Table.t -> t -> t val remove : string -> t -> t - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module Table : sig @@ -44,14 +44,12 @@ module Table : sig val rows : t -> value list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> value - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b end module TableSet : sig include MAP with type value = Table.t - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b val remove : string -> t -> t end From 1e4119b1da1fae54fd97cb56aedea6f995c0c3f5 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 12 Nov 2014 22:14:34 +0000 Subject: [PATCH 09/21] Database: remove the errf from fold_over_{recent,deleted} as no-one was using it To define an error case from a fold you can either - turn the accumulator into a result type and return `Error - throw an exception (... and document this and guarantee to catch it) Signed-off-by: David Scott --- ocaml/database/database_test.ml | 18 +++++++++--------- ocaml/database/db_cache_types.ml | 11 +++++------ ocaml/database/db_cache_types.mli | 4 ++-- ocaml/xapi/xapi_event.ml | 4 ++-- 4 files changed, 18 insertions(+), 19 deletions(-) diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index 7564e0e01cf..9e9e58e67bf 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -183,13 +183,13 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let row = Db_cache_types.Table.find r table in let s = Db_cache_types.Row.fold_over_recent g (fun k _ v acc -> - Printf.sprintf "%s %s=%s" acc k v) (fun () -> ()) row "" in + Printf.sprintf "%s %s=%s" acc k v) row "" in s with _ -> "(deleted)" in Printf.printf "%s(%s): (%Ld %Ld %Ld) %s\n" name r created modified deleted s; - ()) - (fun () -> ()) table ()) (fun () -> ()) tables () + () + ) table ()) tables () in let get_created db g = @@ -198,8 +198,8 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct (fun name _ table acc -> Db_cache_types.Table.fold_over_recent g (fun r { Db_cache_types.Stat.created } _ acc -> - if created>=g then (name,r)::acc else acc) ignore table acc - ) (fun () -> ()) tables [] + if created>=g then (name,r)::acc else acc) table acc + ) tables [] in let get_updated db g = @@ -211,8 +211,8 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct let row = Db_cache_types.Table.find r table in Db_cache_types.Row.fold_over_recent g (fun k _ v acc -> - (r,(k,v))::acc) (fun () -> ()) row acc) - ignore table acc) (fun () -> ()) tables [] + (r,(k,v))::acc) row acc) + table acc) tables [] in let get_deleted db g = @@ -222,14 +222,14 @@ module Tests = functor(Client: Db_interface.DB_ACCESS) -> struct Db_cache_types.Table.fold_over_deleted g (fun r { Db_cache_types.Stat.deleted } acc -> if deleted > g then r::acc else acc) - ignore table acc) (fun () -> ()) tables [] + table acc) tables [] in let get_max db = let tables = Db_cache_types.Database.tableset db in Db_cache_types.TableSet.fold_over_recent (-1L) (fun _ { Db_cache_types.Stat.created; modified; deleted } _ largest -> - max created (max modified (max deleted largest))) (fun () -> ()) tables (-1L) + max created (max modified (max deleted largest))) tables (-1L) in let db = Db_ref.get_database t in diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index d2d4f98e738..94fa06dcbfe 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -39,7 +39,7 @@ module type MAP = sig val add: Time.t -> string -> value -> t -> t val empty : t val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -77,7 +77,7 @@ module Make = functor(V: VAL) -> struct else updatefn () else updatefn () - let fold_over_recent since f _ t initial = StringMap.fold (fun x y z -> if y.stat.Stat.modified > since then f x y.stat y.v z else z) t initial + let fold_over_recent since f t initial = StringMap.fold (fun x y z -> if y.stat.Stat.modified > since then f x y.stat y.v z else z) t initial end module StringStringMap = Make(struct type v = string end) @@ -115,7 +115,7 @@ module type TABLE = sig val rows : t -> Row.t list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> Row.t - val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end module Table : TABLE = struct @@ -147,9 +147,9 @@ module Table : TABLE = struct deleted = new_deleted} let update_generation g key default f t = {t with rows = StringRowMap.update_generation g key default f t.rows } let update g key default f t = {t with rows = StringRowMap.update g key default f t.rows} - let fold_over_recent since f errf t acc = StringRowMap.fold_over_recent since f errf t.rows acc + let fold_over_recent since f t acc = StringRowMap.fold_over_recent since f t.rows acc - let fold_over_deleted since f errf t acc = + let fold_over_deleted since f t acc = let rec loop xs acc = match xs with | (created,deleted,r)::xs -> let new_acc = @@ -159,7 +159,6 @@ module Table : TABLE = struct in if deleted <= since then new_acc else loop xs new_acc | [] -> - errf (); acc in loop t.deleted acc diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index d516efe64ca..78ee27142b9 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -22,7 +22,7 @@ module type MAP = sig val add: Time.t -> string -> value -> t -> t val empty : t val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b - val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit @@ -44,7 +44,7 @@ module Table : sig val rows : t -> value list val remove : Time.t -> string -> t -> t val find_exn : string -> string -> t -> value - val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> (unit -> unit) -> t -> 'b -> 'b + val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end module TableSet : sig diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 627a059f43f..bc28f6a5904 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -445,7 +445,7 @@ let from_inner __context session subs from from_t deadline = end else begin (creates,mods,deletes,last) end - ) (fun () -> ()) (Db_cache_types.TableSet.find table tableset) acc in + ) (Db_cache_types.TableSet.find table tableset) acc in (* Fold over the deleted objects *) Db_cache_types.Table.fold_over_deleted !last_generation (fun objref { Db_cache_types.Stat.created; modified; deleted } (creates,mods,deletes,last) -> @@ -458,7 +458,7 @@ let from_inner __context session subs from from_t deadline = end else begin (creates,mods,deletes,last) end - ) (fun () -> ()) (Db_cache_types.TableSet.find table tableset) acc + ) (Db_cache_types.TableSet.find table tableset) acc ) ([],[],[],!last_generation) tables) in (* Each event.from should have an independent subscription record *) From be115bd961c07ecf4bc715f815a01bae878ba256 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 11:52:31 +0000 Subject: [PATCH 10/21] Database: add missing license headers Signed-off-by: David Scott --- ocaml/database/db_cache_types.ml | 14 ++++++++++++++ ocaml/database/db_cache_types.mli | 14 ++++++++++++++ 2 files changed, 28 insertions(+) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 94fa06dcbfe..ba989d159ab 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -1,3 +1,17 @@ +(* + * Copyright (C) 2006-2014 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + open Db_exn module Value = struct diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 78ee27142b9..ce46d427a66 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -1,3 +1,17 @@ +(* + * Copyright (C) 2006-2014 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + (** The values stored in the database *) module Value : sig type t = string From 4773f63d941a7d09698545ec93ae98dc8c6513ba Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 12:09:07 +0000 Subject: [PATCH 11/21] Database: start adding ocamldoc to the interface Signed-off-by: David Scott --- ocaml/database/db_cache_types.ml | 2 +- ocaml/database/db_cache_types.mli | 47 +++++++++++++++++++++++++++---- 2 files changed, 42 insertions(+), 7 deletions(-) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index ba989d159ab..a371e348bf3 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -50,8 +50,8 @@ end module type MAP = sig type t type value - val add: Time.t -> string -> value -> t -> t val empty : t + val add: Time.t -> string -> value -> t -> t val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index ce46d427a66..80a19554031 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -12,35 +12,63 @@ * GNU Lesser General Public License for more details. *) -(** The values stored in the database *) module Value : sig type t = string + (** A value stored in the database *) + end -(** A timestamp *) module Time : sig type t = Generation.t + (** A monotonically increasing counter associated with this database *) end module Stat : sig type t = { - created: Time.t; - modified: Time.t; - deleted: Time.t; + created: Time.t; (** Time this value was created *) + modified: Time.t; (** Time this value was last modified *) + deleted: Time.t; (** Time this value was deleted (or 0L meaning it is still alive) *) } + (** Metadata associated with a database value *) end module type MAP = sig type t + (** A map from string to some value *) + type value - val add: Time.t -> string -> value -> t -> t + (** The type of the values in the map *) + val empty : t + (** The empty map *) + + val add: Time.t -> string -> value -> t -> t + (** [add now key value map] returns a new map with [key] associated with [value], + with creation time [now] *) + val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + (** [fold f t initial] folds [f key stats value acc] over the items in [t] *) + val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b + (** [fold_over_recent since f t initial] folds [f key stats value acc] over all the + items with a modified time larger than [since] *) + val find : string -> t -> value + (** [find key t] returns the value associated with [key] in [t] or raises + [DBCache_NotFound] *) + val mem : string -> t -> bool + (** [mem key t] returns true if [value] is associated with [key] in [t] or false + otherwise *) + val iter : (string -> value -> unit) -> t -> unit + (** [iter f t] applies [f key value] to each binding in [t] *) + val update : Time.t -> string -> value -> (value -> value) -> t -> t + (** [update now key default f t] returns a new map which is the same as [t] except: + if there is a value associated with [key] it is replaced with [f key[ + or if there is no value associated with [key] then [default] is associated with [key] + *) end module Row : sig @@ -48,12 +76,19 @@ module Row : sig with type value = Value.t val add_defaults: Time.t -> Schema.Table.t -> t -> t + (** [add_defaults now schema t]: returns a row which is [t] extended to contain + all the columns specified in the schema, with default values set if not already + in [t]. If the schema is missing a default value then raises [DBCache_NotFound]: + this would happen if a client failed to provide a necessary field. *) + val remove : string -> t -> t + (** [remove key t] removes the binding of [key] from [t]. *) end module Table : sig include MAP with type value = Row.t + val update_generation : Time.t -> string -> value -> (value -> value) -> t -> t val rows : t -> value list val remove : Time.t -> string -> t -> t From bc251357a80cd30ddd06f4f235ad4a05aa667d07 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 13:43:42 +0000 Subject: [PATCH 12/21] Database: remove Table.find_exn This was confusing because we already had {Row,Table,TableSet}.find which threw exceptions. The only difference was that Table.find_exn would throw a DBCache exception rather than Not_found. We revert all callers to Table.find, and expect them (in the DB_ACCESS layer) to convert the Not_found into the DB_ACCESS-specific exception themselves. Signed-off-by: David Scott --- ocaml/database/db_cache_impl.ml | 85 +++++++++++++++++-------------- ocaml/database/db_cache_types.ml | 9 ++-- ocaml/database/db_cache_types.mli | 1 - 3 files changed, 52 insertions(+), 43 deletions(-) diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index 7702f315505..d335d2a4b88 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -50,7 +50,10 @@ let is_valid_ref t objref = | None -> false let read_field_internal t tblname fldname objref db = - Row.find fldname (Table.find_exn tblname objref (TableSet.find tblname (Database.tableset db))) + try + Row.find fldname (Table.find objref (TableSet.find tblname (Database.tableset db))) + with Not_found -> + raise (DBCache_NotFound ("missing row", tblname, objref)) (* Read field from cache *) let read_field t tblname fldname objref = @@ -125,38 +128,45 @@ let read_set_ref t rcd = name of the Set Ref field in tbl; and ref list is the list of foreign keys from related table with remote-fieldname=objref] *) let read_record_internal db tblname objref = - let tbl = TableSet.find tblname (Database.tableset db) in - let row = Table.find_exn tblname objref tbl in - let fvlist = Row.fold (fun k _ d env -> (k,d)::env) row [] in - (* Unfortunately the interface distinguishes between Set(Ref _) types and - ordinary fields *) - let schema = Schema.table tblname (Database.schema db) in - let set_ref = List.filter (fun (k, _) -> - try - let column = Schema.Table.find k schema in - column.Schema.Column.issetref - with Not_found as e -> - Printf.printf "Failed to find table %s in schema\n%!" k; - raise e - ) fvlist in - (* the set_ref fields must be converted back into lists *) - let set_ref = List.map (fun (k, v) -> - k, String_unmarshall_helper.set (fun x -> x) v) set_ref in - (fvlist, set_ref) + try + let tbl = TableSet.find tblname (Database.tableset db) in + let row = Table.find objref tbl in + let fvlist = Row.fold (fun k _ d env -> (k,d)::env) row [] in + (* Unfortunately the interface distinguishes between Set(Ref _) types and + ordinary fields *) + let schema = Schema.table tblname (Database.schema db) in + let set_ref = List.filter (fun (k, _) -> + try + let column = Schema.Table.find k schema in + column.Schema.Column.issetref + with Not_found as e -> + Printf.printf "Failed to find table %s in schema\n%!" k; + raise e + ) fvlist in + (* the set_ref fields must be converted back into lists *) + let set_ref = List.map (fun (k, v) -> + k, String_unmarshall_helper.set (fun x -> x) v) set_ref in + (fvlist, set_ref) + with Not_found -> + raise (DBCache_NotFound ("missing row", tblname, objref)) + let read_record t = read_record_internal (get_database t) (* Delete row from tbl *) let delete_row_locked t tblname objref = - W.debug "delete_row %s (%s)" tblname objref; + try + W.debug "delete_row %s (%s)" tblname objref; - let tbl = TableSet.find tblname (Database.tableset (get_database t)) in - let row = Table.find_exn tblname objref tbl in + let tbl = TableSet.find tblname (Database.tableset (get_database t)) in + let row = Table.find objref tbl in - let db = get_database t in - Database.notify (PreDelete(tblname, objref)) db; - update_database t (remove_row tblname objref); - Database.notify (Delete(tblname, objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row [])) (get_database t) - + let db = get_database t in + Database.notify (PreDelete(tblname, objref)) db; + update_database t (remove_row tblname objref); + Database.notify (Delete(tblname, objref, Row.fold (fun k _ v acc -> (k, v) :: acc) row [])) (get_database t) + with Not_found -> + raise (DBCache_NotFound ("missing row", tblname, objref)) + let delete_row t tblname objref = with_lock (fun () -> delete_row_locked t tblname objref) @@ -231,15 +241,14 @@ let read_records_where t tbl expr = List.map (fun ref->ref, read_record_internal db tbl ref) reqd_refs let process_structured_field_locked t (key,value) tblname fld objref proc_fn_selector = - - (* Ensure that both keys and values are valid for UTF-8-encoded XML. *) - let key = ensure_utf8_xml key in - let value = ensure_utf8_xml value in - - let tbl = TableSet.find tblname (Database.tableset (get_database t)) in - let row = Table.find_exn tblname objref tbl in - let existing_str = Row.find fld row in - let new_str = match proc_fn_selector with + (* Ensure that both keys and values are valid for UTF-8-encoded XML. *) + let key = ensure_utf8_xml key in + let value = ensure_utf8_xml value in + try + let tbl = TableSet.find tblname (Database.tableset (get_database t)) in + let row = Table.find objref tbl in + let existing_str = Row.find fld row in + let new_str = match proc_fn_selector with | AddSet -> add_to_set key existing_str | RemoveSet -> remove_from_set key existing_str | AddMap -> @@ -251,7 +260,9 @@ let process_structured_field_locked t (key,value) tblname fld objref proc_fn_sel raise (Duplicate_key (tblname,fld,objref,key)); end | RemoveMap -> remove_from_map key existing_str in - write_field t tblname objref fld new_str + write_field t tblname objref fld new_str + with Not_found -> + raise (DBCache_NotFound ("missing row", tblname, objref)) let process_structured_field t (key,value) tblname fld objref proc_fn_selector = with_lock (fun () -> diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index a371e348bf3..a167361a2ec 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -128,7 +128,6 @@ module type TABLE = sig val update_generation : Time.t -> string -> Row.t -> (Row.t -> Row.t) -> t -> t val rows : t -> Row.t list val remove : Time.t -> string -> t -> t - val find_exn : string -> string -> t -> Row.t val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end @@ -140,9 +139,6 @@ module Table : TABLE = struct let add g key value t = {t with rows=StringRowMap.add g key value t.rows} let empty = {rows=StringRowMap.empty; deleted_len = 1; deleted=[(0L,0L,"")] } let fold f t acc = StringRowMap.fold f t.rows acc - let find_exn tbl key t = - try StringRowMap.find key t.rows - with Not_found -> raise (DBCache_NotFound ("missing row", tbl, key)) let find key t = StringRowMap.find key t.rows let mem key t = StringRowMap.mem key t.rows let iter f t = StringRowMap.iter f t.rows @@ -420,7 +416,10 @@ let is_valid tblname objref db = let get_field tblname objref fldname db = - Row.find fldname (Table.find_exn tblname objref (TableSet.find tblname (Database.tableset db))) + try + Row.find fldname (Table.find objref (TableSet.find tblname (Database.tableset db))) + with Not_found -> + raise (DBCache_NotFound ("missing row", tblname, objref)) let unsafe_set_field g tblname objref fldname newval = (Database.update diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 80a19554031..175b59cb596 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -92,7 +92,6 @@ module Table : sig val update_generation : Time.t -> string -> value -> (value -> value) -> t -> t val rows : t -> value list val remove : Time.t -> string -> t -> t - val find_exn : string -> string -> t -> value val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end From 1fd3f51b55bdfa4015abbd75989d4d62a9a9391f Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 14:06:38 +0000 Subject: [PATCH 13/21] Database: rename 'update_generation' to 'touch' and simplify the signature The 'update_generation' function was defined as - always bump the generation count (in contract to 'update') - also transform one binding to another value In practice all users were using it only to bump the generation count like "touch"ing a file. Therefore we remove the transform ability and rename the function "touch". Signed-off-by: David Scott --- ocaml/database/db_cache_impl.ml | 4 ++-- ocaml/database/db_cache_impl.mli | 5 +++-- ocaml/database/db_cache_types.ml | 19 ++++++++++--------- ocaml/database/db_cache_types.mli | 19 +++++++++++++------ ocaml/xapi/xapi_event.ml | 2 +- 5 files changed, 29 insertions(+), 20 deletions(-) diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index d335d2a4b88..c1a980bb7a3 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -84,8 +84,8 @@ let write_field t tblname objref fldname newval = with_lock (fun () -> write_field_locked t tblname objref fldname newval) -let refresh_row t tblname objref = - update_database t (update_generation tblname objref); +let touch_row t tblname objref = + update_database t (touch tblname objref); Database.notify (RefreshRow(tblname, objref)) (get_database t) (* This function *should* only be used by db_actions code looking up Set(Ref _) fields: diff --git a/ocaml/database/db_cache_impl.mli b/ocaml/database/db_cache_impl.mli index 42e2dc820ce..4304586f1ab 100644 --- a/ocaml/database/db_cache_impl.mli +++ b/ocaml/database/db_cache_impl.mli @@ -13,8 +13,9 @@ val sync : Parse_db_conf.db_connection list -> Db_cache_types.Database.t -> unit (** [stats t] returns some stats data for logging *) val stats : Db_ref.t -> (string * int) list -(** [refresh_row context tbl ref] generates a RefreshRow event *) -val refresh_row : Db_ref.t -> string -> string -> unit +(** [touch_row context tbl ref] bumps the generation count on [tbl], [ref] and + generates a RefreshRow event *) +val touch_row : Db_ref.t -> string -> string -> unit (** Used for Test_db_lowlevel *) val fist_delay_read_records_where : bool ref diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index a167361a2ec..2b4d7002823 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -58,6 +58,7 @@ module type MAP = sig val mem : string -> t -> bool val iter : (string -> value -> unit) -> t -> unit val update : int64 -> string -> value -> (value -> value) -> t -> t + val touch : int64 -> string -> value -> t -> t end (** A specialised StringMap whose range type is V.v, and which keeps a record of when records are created/updated *) @@ -76,9 +77,9 @@ module Make = functor(V: VAL) -> struct let mem = StringMap.mem let iter f = StringMap.iter (fun key x -> f key x.v) let remove = StringMap.remove - let update_generation generation key default f row = + let touch generation key default row = let default = { stat = Stat.make generation; v = default } in - StringMap.update key default (fun x -> { stat = { x.stat with Stat.modified=generation }; v=f x.v}) row + StringMap.update key default (fun x -> { x with stat = { x.stat with Stat.modified=generation } }) row let update generation key default f row = let default = { stat = Stat.make generation; v = default } in let updatefn () = StringMap.update key default (fun x -> { stat = { x.stat with Stat.modified=generation }; v=f x.v}) row in @@ -125,7 +126,7 @@ module StringRowMap = Make(struct type v = Row.t end) module type TABLE = sig include MAP with type value = Row.t - val update_generation : Time.t -> string -> Row.t -> (Row.t -> Row.t) -> t -> t + val touch : Time.t -> string -> Row.t -> t -> t val rows : t -> Row.t list val remove : Time.t -> string -> t -> t val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b @@ -155,7 +156,7 @@ module Table : TABLE = struct {rows = StringRowMap.remove key t.rows; deleted_len = new_len; deleted = new_deleted} - let update_generation g key default f t = {t with rows = StringRowMap.update_generation g key default f t.rows } + let touch g key default t = {t with rows = StringRowMap.touch g key default t.rows } let update g key default f t = {t with rows = StringRowMap.update g key default f t.rows} let fold_over_recent since f t acc = StringRowMap.fold_over_recent since f t.rows acc @@ -229,11 +230,11 @@ module Manifest = struct let generation x = x.generation_count - let update_generation f x = { + let touch f x = { x with generation_count = f x.generation_count } - let next = update_generation (Int64.add 1L) + let next = touch (Int64.add 1L) let schema x = match x.schema with | None -> 0, 0 @@ -275,7 +276,7 @@ module Database = struct { x with tables = f x.tables } let set_generation g = - update_manifest (Manifest.update_generation (fun _ -> g)) + update_manifest (Manifest.touch (fun _ -> g)) let update_tableset f x = { x with tables = f x.tables } @@ -489,7 +490,7 @@ let set_field tblname objref fldname newval db = (fun _ -> newval))) db end -let update_generation tblname objref db = +let touch tblname objref db = let g = Manifest.generation (Database.manifest db) in (* We update the generation twice so that we can return the lower count for the "event.inject" API to guarantee that the token from a later @@ -498,7 +499,7 @@ let update_generation tblname objref db = (Database.increment ++ Database.increment ++ ((Database.update ++ (TableSet.update g tblname Table.empty) - ++ (Table.update_generation g objref Row.empty)) id + ++ (Table.touch g objref)) Row.empty )) db let add_row tblname objref newval db = diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 175b59cb596..c4b56d322c8 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -66,9 +66,18 @@ module type MAP = sig val update : Time.t -> string -> value -> (value -> value) -> t -> t (** [update now key default f t] returns a new map which is the same as [t] except: - if there is a value associated with [key] it is replaced with [f key[ - or if there is no value associated with [key] then [default] is associated with [key] + if there is a value associated with [key] it is replaced with [f key] + or if there is no value associated with [key] then [default] is associated with [key]. + This function touches the modification time of [key] *unless* [f key] is physically + equal with the current value: in this case the modification time isn't bumped as + an optimisation. *) + + val touch : Time.t -> string -> value -> t -> t + (** [touch now key default t] returns a new map which is the same as [t] except: + if there is a value associated with [t] then its modification time is set to [now]; + if there is no value asssociated with [t] then one is created with value [default]. + On exit there will be a binding of [key] whose modification time is [now] *) end module Row : sig @@ -89,7 +98,6 @@ module Table : sig include MAP with type value = Row.t - val update_generation : Time.t -> string -> value -> (value -> value) -> t -> t val rows : t -> value list val remove : Time.t -> string -> t -> t val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b @@ -107,7 +115,7 @@ module Manifest : val empty : t val make : int -> int -> Generation.t -> t val generation : t -> Generation.t - val update_generation : (Generation.t -> Generation.t) -> t -> t + val touch : (Generation.t -> Generation.t) -> t -> t val next : t -> t val schema : t -> int * int val update_schema : ((int * int) option -> (int * int) option) -> t -> t @@ -153,8 +161,7 @@ val set_field : string -> string -> string -> string -> Database.t -> Database.t val get_field : string -> string -> string -> Database.t -> string val remove_row : string -> string -> Database.t -> Database.t val add_row : string -> string -> Row.t -> Database.t -> Database.t - -val update_generation : string -> string -> Database.t -> Database.t +val touch : string -> string -> Database.t -> Database.t type where_record = { table: string; (** table from which ... *) diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index bc28f6a5904..4342f8001a5 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -558,7 +558,7 @@ let inject ~__context ~_class ~_ref = (fun () -> let db_ref = Db_backend.make () in let g = Manifest.generation (Database.manifest (Db_ref.get_database db_ref)) in - Db_cache_impl.refresh_row db_ref _class _ref; (* consumes this generation *) + Db_cache_impl.touch_row db_ref _class _ref; (* consumes this generation *) g ) in let token = Int64.sub generation 1L, 0L in From 18ddcf37e340db946a72481ceefcd637de8eddf2 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 14:30:51 +0000 Subject: [PATCH 14/21] Database: use the same 'remove' function signature everywhere This allows us to put the 'remove' function into the MAP signature for consistency. Now Row, Table, TableSet all have a remove which takes a Time.t which allows tracking of delete events. We only use these in the Table to track deleted Rows, but maybe in future we could track deleted Tables or fields later? Signed-off-by: David Scott --- ocaml/database/db_cache_types.ml | 13 ++++--------- ocaml/database/db_cache_types.mli | 12 ++++-------- 2 files changed, 8 insertions(+), 17 deletions(-) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 2b4d7002823..15820506f43 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -52,6 +52,7 @@ module type MAP = sig type value val empty : t val add: Time.t -> string -> value -> t -> t + val remove : Time.t -> string -> t -> t val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val fold_over_recent : Time.t -> (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b val find : string -> t -> value @@ -76,7 +77,7 @@ module Make = functor(V: VAL) -> struct let find key map = (StringMap.find key map).v let mem = StringMap.mem let iter f = StringMap.iter (fun key x -> f key x.v) - let remove = StringMap.remove + let remove _ = StringMap.remove let touch generation key default row = let default = { stat = Stat.make generation; v = default } in StringMap.update key default (fun x -> { x with stat = { x.stat with Stat.modified=generation } }) row @@ -102,7 +103,6 @@ module type ROW = sig with type value = Value.t val add_defaults: Time.t -> Schema.Table.t -> t -> t - val remove : string -> t -> t end module Row : ROW = struct @@ -128,7 +128,6 @@ module type TABLE = sig with type value = Row.t val touch : Time.t -> string -> Row.t -> t -> t val rows : t -> Row.t list - val remove : Time.t -> string -> t -> t val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end @@ -153,7 +152,7 @@ module Table : TABLE = struct then t.deleted_len + 1, (new_element::t.deleted) else lower_length_deleted_queue + 1, (new_element::(Listext.List.take lower_length_deleted_queue t.deleted)) in - {rows = StringRowMap.remove key t.rows; + {rows = StringRowMap.remove g key t.rows; deleted_len = new_len; deleted = new_deleted} let touch g key default t = {t with rows = StringRowMap.touch g key default t.rows } @@ -179,11 +178,7 @@ end module StringTableMap = Make(struct type v = Table.t end) -module type TABLESET = sig - include MAP - with type value = Table.t - val remove : string -> t -> t -end +module type TABLESET = MAP with type value = Table.t module TableSet : TABLESET = struct include StringTableMap diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index c4b56d322c8..258d1372038 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -46,6 +46,9 @@ module type MAP = sig (** [add now key value map] returns a new map with [key] associated with [value], with creation time [now] *) + val remove : Time.t -> string -> t -> t + (** [remove now key t] removes the binding of [key] from [t]. *) + val fold : (string -> Stat.t -> value -> 'b -> 'b) -> t -> 'b -> 'b (** [fold f t initial] folds [f key stats value acc] over the items in [t] *) @@ -90,8 +93,6 @@ module Row : sig in [t]. If the schema is missing a default value then raises [DBCache_NotFound]: this would happen if a client failed to provide a necessary field. *) - val remove : string -> t -> t - (** [remove key t] removes the binding of [key] from [t]. *) end module Table : sig @@ -99,15 +100,10 @@ module Table : sig with type value = Row.t val rows : t -> value list - val remove : Time.t -> string -> t -> t val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end -module TableSet : sig - include MAP - with type value = Table.t - val remove : string -> t -> t -end +module TableSet : MAP with type value = Table.t module Manifest : sig From 875efa2af39f2aaa0765e56738acd610e8ab8e6f Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 14:37:15 +0000 Subject: [PATCH 15/21] Database: remove unused function 'rows' This was a trivial use of fold anyway. Signed-off-by: David Scott --- ocaml/database/db_cache_types.ml | 4 ---- ocaml/database/db_cache_types.mli | 2 -- 2 files changed, 6 deletions(-) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 15820506f43..bbfb41570fe 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -127,7 +127,6 @@ module type TABLE = sig include MAP with type value = Row.t val touch : Time.t -> string -> Row.t -> t -> t - val rows : t -> Row.t list val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end @@ -171,9 +170,6 @@ module Table : TABLE = struct | [] -> acc in loop t.deleted acc - - let rows t = - fold (fun _ _ r rs -> r :: rs) t [] end module StringTableMap = Make(struct type v = Table.t end) diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 258d1372038..2f373f98fc7 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -98,8 +98,6 @@ end module Table : sig include MAP with type value = Row.t - - val rows : t -> value list val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b end From 8248d0f03457b65abbd3344940af814d4da9c76f Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 15:07:25 +0000 Subject: [PATCH 16/21] Database: add ocamldoc for the 'fold_over_deleted' function Signed-off-by: David Scott --- ocaml/database/db_cache_types.mli | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index 2f373f98fc7..a2fb7978c28 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -98,7 +98,11 @@ end module Table : sig include MAP with type value = Row.t + val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b + (** [fold_over_deleted now f t initial] folds [f key stat acc] over the keys + which have been recently deleted. Note this is not guaranteed to remember + all events, so the list may be short. *) end module TableSet : MAP with type value = Table.t From c7678d5b968999422f734013be619cfb43e6a273 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 15:14:47 +0000 Subject: [PATCH 17/21] Database: remove some signatures duplicated from the .mli Signed-off-by: David Scott --- ocaml/database/db_cache_types.ml | 22 +++------------------- 1 file changed, 3 insertions(+), 19 deletions(-) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index bbfb41570fe..d12379144eb 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -98,14 +98,7 @@ end module StringStringMap = Make(struct type v = string end) -module type ROW = sig - include MAP - with type value = Value.t - - val add_defaults: Time.t -> Schema.Table.t -> t -> t -end - -module Row : ROW = struct +module Row = struct include StringStringMap type t=map_t type value = Value.t @@ -123,14 +116,7 @@ end module StringRowMap = Make(struct type v = Row.t end) -module type TABLE = sig - include MAP - with type value = Row.t - val touch : Time.t -> string -> Row.t -> t -> t - val fold_over_deleted : Time.t -> (string -> Stat.t -> 'b -> 'b) -> t -> 'b -> 'b -end - -module Table : TABLE = struct +module Table = struct type t = { rows : StringRowMap.map_t; deleted_len : int; deleted : (Time.t * Time.t * string) list } @@ -174,9 +160,7 @@ end module StringTableMap = Make(struct type v = Table.t end) -module type TABLESET = MAP with type value = Table.t - -module TableSet : TABLESET = struct +module TableSet = struct include StringTableMap type t=map_t type value = Table.t From 177c20cf1a7ef4211411953ca4d4e06e20dd0022 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 17:17:30 +0000 Subject: [PATCH 18/21] Database: add a 'Value.t' to the schema The schema can use this value for describing Column.ts, in particular - the 'empty' value - the optional 'default' value The Value.t is still being marshalled to a string for storage in the database. Signed-off-by: David Scott --- ocaml/database/db_backend.ml | 2 +- ocaml/database/db_cache_types.ml | 2 +- ocaml/database/schema.ml | 17 ++++++++++-- ocaml/database/test_schemas.ml | 28 +++++++++---------- ocaml/idl/datamodel_schema.ml | 6 ++--- ocaml/idl/datamodel_values.ml | 46 +++++++++++++++++--------------- 6 files changed, 59 insertions(+), 42 deletions(-) diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index fd460e3957c..066ffecac34 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -45,7 +45,7 @@ let blow_away_non_persistent_fields (schema: Schema.t) db = (fun name { Stat.created; modified } v (acc,max_upd) -> try let col = Schema.Table.find name schema in - let v',modified' = if col.Schema.Column.persistent then v,modified else col.Schema.Column.empty,g in + let v',modified' = if col.Schema.Column.persistent then v,modified else Schema.Value.marshal col.Schema.Column.empty,g in (Row.update modified' name "" (fun _ -> v') (Row.add created name v' acc),max max_upd modified') with Not_found -> Printf.printf "Skipping unknown column: %s\n%!" name; diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index d12379144eb..89331b95f1e 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -109,7 +109,7 @@ module Row = struct List.fold_left (fun t c -> if not(mem c.Schema.Column.name t) then match c.Schema.Column.default with - | Some default -> add g c.Schema.Column.name default t + | Some default -> add g c.Schema.Column.name (Schema.Value.marshal default) t | None -> raise (DBCache_NotFound ("missing field", c.Schema.Column.name, "")) else t) t schema.Schema.Table.columns end diff --git a/ocaml/database/schema.ml b/ocaml/database/schema.ml index 92c0766d7db..3a5945ab1a1 100644 --- a/ocaml/database/schema.ml +++ b/ocaml/database/schema.ml @@ -21,12 +21,25 @@ module Type = struct with sexp end +module Value = struct + type t = + | String of string + | Set of string list + | Pairs of (string * string) list + with sexp + + let marshal = function + | String x -> x + | Set xs -> String_marshall_helper.set (fun x -> x) xs + | Pairs xs -> String_marshall_helper.map (fun x -> x) (fun x -> x) xs +end + module Column = struct type t = { name: string; persistent: bool; (** see is_field_persistent *) - empty: string; (** fresh value used when loading non-persistent fields *) - default: string option; (** if column is missing, this is default value is used *) + empty: Value.t; (** fresh value used when loading non-persistent fields *) + default: Value.t option; (** if column is missing, this is default value is used *) ty: Type.t; (** the type of the value in the column *) issetref: bool; (** only so we can special case set refs in the interface *) } with sexp diff --git a/ocaml/database/test_schemas.ml b/ocaml/database/test_schemas.ml index 1c7c436cc12..90452e57a0c 100644 --- a/ocaml/database/test_schemas.ml +++ b/ocaml/database/test_schemas.ml @@ -2,7 +2,7 @@ let schema = let _ref = { Schema.Column.name = Db_names.ref; persistent = true; - empty = ""; + empty = Schema.Value.String ""; default = None; ty = Schema.Type.String; issetref = false; @@ -10,7 +10,7 @@ let schema = let uuid = { Schema.Column.name = Db_names.uuid; persistent = true; - empty = ""; + empty = Schema.Value.String ""; default = None; ty = Schema.Type.String; issetref = false; @@ -18,7 +18,7 @@ let schema = let name_label = { Schema.Column.name = Db_names.name_label; persistent = true; - empty = ""; + empty = Schema.Value.String ""; default = None; ty = Schema.Type.String; issetref = false; @@ -26,7 +26,7 @@ let schema = let name_description = { Schema.Column.name = "name__description"; persistent = true; - empty = ""; + empty = Schema.Value.String ""; default = None; ty = Schema.Type.String; issetref = false; @@ -34,39 +34,39 @@ let schema = let vbds = { Schema.Column.name = "VBDs"; persistent = false; - empty = "()"; - default = Some("()"); + empty = Schema.Value.Set []; + default = Some(Schema.Value.Set []); ty = Schema.Type.Set; issetref = true; } in let other_config = { Schema.Column.name = "other_config"; persistent = false; - empty = "()"; - default = Some("()"); + empty = Schema.Value.Pairs []; + default = Some(Schema.Value.Pairs []); ty = Schema.Type.Pairs; issetref = false; } in let pp = { Schema.Column.name = "protection_policy"; persistent = true; - empty = ""; - default = Some("OpaqueRef:NULL"); + empty = Schema.Value.String ""; + default = Some(Schema.Value.String "OpaqueRef:NULL"); ty = Schema.Type.String; issetref = false; } in let tags = { Schema.Column.name = "tags"; persistent = true; - empty = ""; - default = Some("()"); + empty = Schema.Value.Set []; + default = Some(Schema.Value.Set []); ty = Schema.Type.Set; issetref = false; } in let vm = { Schema.Column.name = "VM"; persistent = true; - empty = ""; + empty = Schema.Value.String ""; default = None; ty = Schema.Type.String; issetref = false; @@ -100,7 +100,7 @@ let schema = let many_to_many = let bar_column = { Schema.Column.name = "bars"; persistent = false; - empty = "()"; + empty = Schema.Value.Pairs []; default = None; ty = Schema.Type.Pairs; issetref = false; diff --git a/ocaml/idl/datamodel_schema.ml b/ocaml/idl/datamodel_schema.ml index f560cf8b065..05969a4d99d 100644 --- a/ocaml/idl/datamodel_schema.ml +++ b/ocaml/idl/datamodel_schema.ml @@ -42,8 +42,8 @@ let of_datamodel () = (* NB Set(Ref _) fields aren't allowed to have a default value specified so we hardcode one here *) default = if issetref - then Some (SExpr.string_of (SExpr.Node [])) - else Opt.map Datamodel_values.to_db_string f.Datamodel_types.default_value ; + then Some (Value.Set []) + else Opt.map Datamodel_values.to_db f.Datamodel_types.default_value ; ty = ty; issetref = issetref; } in @@ -52,7 +52,7 @@ let of_datamodel () = let _ref = { Column.name = Db_names.ref; persistent = true; - empty = ""; + empty = Value.String ""; default = None; ty = Type.String; issetref = false; diff --git a/ocaml/idl/datamodel_values.ml b/ocaml/idl/datamodel_values.ml index dc518ce8729..c6a1429efb5 100644 --- a/ocaml/idl/datamodel_values.ml +++ b/ocaml/idl/datamodel_values.ml @@ -62,30 +62,34 @@ let to_ocaml_string v = | Rpc.DateTime t -> sprintf "Rpc.DateTime %s" t in aux (to_rpc v) -let rec to_db_string v = +let rec to_db v = + let open Schema.Value in match v with - VString s -> s - | VInt i -> Int64.to_string i - | VFloat f -> string_of_float f - | VBool true -> "true" - | VBool false -> "false" - | VDateTime d -> Date.to_string d - | VEnum e -> e - | VMap vvl -> String_marshall_helper.map to_db_string to_db_string vvl - | VSet vl -> String_marshall_helper.set to_db_string vl - | VRef r -> r + VString s -> String s + | VInt i -> String (Int64.to_string i) + | VFloat f -> String (string_of_float f) + | VBool true -> String "true" + | VBool false -> String "false" + | VDateTime d -> String (Date.to_string d) + | VEnum e -> String e + | VMap vvl -> + Pairs(List.map (fun (k, v) -> to_string k, to_string v) vvl) + | VSet vl -> + Set(List.map to_string vl) + | VRef r -> String r (* Generate suitable "empty" database value of specified type *) let gen_empty_db_val t = + let open Schema in match t with - | String -> "" - | Int -> "0" - | Float -> string_of_float 0.0 - | Bool -> "false" - | DateTime -> Date.to_string Date.never - | Enum (_,(enum_value,_)::_) -> enum_value + | String -> Value.String "" + | Int -> Value.String "0" + | Float -> Value.String (string_of_float 0.0) + | Bool -> Value.String "false" + | DateTime -> Value.String (Date.to_string Date.never) + | Enum (_,(enum_value,_)::_) -> Value.String enum_value | Enum (_, []) -> assert false - | Set _ -> String_marshall_helper.map to_db_string to_db_string [] - | Map _ -> String_marshall_helper.set to_db_string [] - | Ref _ -> Ref.string_of Ref.null - | Record _ -> "" + | Set _ -> Value.Set [] + | Map _ -> Value.Pairs [] + | Ref _ -> Value.String (Ref.string_of Ref.null) + | Record _ -> Value.String "" From 277c852834c38591c554a5c6318827c3f0d25b13 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 18:41:08 +0000 Subject: [PATCH 19/21] Database: fill the database with Schema.Value.t rather than strings In particular this means that sets and maps are not automatically serialised to strings via the 'add_to' and 'remove_from' code. However the wire protocol still uses s-expressions so the more slaves, the more s-expressions you'll see. --- ocaml/database/OMakefile | 6 +- ocaml/database/db_action_helper.ml | 8 +-- ocaml/database/db_backend.ml | 5 +- ocaml/database/db_cache_impl.ml | 55 ++++++++-------- ocaml/database/db_cache_types.ml | 94 +++++++++++----------------- ocaml/database/db_cache_types.mli | 26 +++----- ocaml/database/db_xml.ml | 22 ++++--- ocaml/database/eventgen.ml | 30 +++++---- ocaml/database/redo_log.ml | 6 +- ocaml/database/ref_index.ml | 6 +- ocaml/database/schema.ml | 31 +++++++++ ocaml/db_process/xapi_db_process.ml | 10 ++- ocaml/idl/ocaml_backend/exnHelper.ml | 2 - 13 files changed, 155 insertions(+), 146 deletions(-) diff --git a/ocaml/database/OMakefile b/ocaml/database/OMakefile index 7224860a7ad..0f4caa842f2 100644 --- a/ocaml/database/OMakefile +++ b/ocaml/database/OMakefile @@ -20,13 +20,11 @@ BLOCK_DEVICE_IO_FILES = \ OCamlProgram(block_device_io, $(BLOCK_DEVICE_IO_FILES)) OCamlDocProgram(block_device_io, $(BLOCK_DEVICE_IO_FILES)) -DATABASE_SERVER_FILES = database_server_main test_schemas database_test ../autogen/db_actions -DATABASE_TEST_FILES = database_test database_test_main test_schemas +DATABASE_SERVER_FILES = database_server_main test_schemas ../autogen/db_actions section: #XXX there are lots of interdependencies which we should be aim to remove OCAML_LIBS += ../util/version ../idl/ocaml_backend/common ../idl/ocaml_backend/client ../util/stats ../idl/ocaml_backend/server OCamlProgram(database_server, $(DATABASE_SERVER_FILES)) - OCamlProgram(database_test, $(DATABASE_TEST_FILES)) section: OCAML_LIBS += ../idl/ocaml_backend/common ../idl/ocaml_backend/client ../idl/ocaml_backend/server @@ -43,5 +41,5 @@ sdk-install: install .PHONY: clean clean: rm -f $(CLEAN_OBJS) xenEnterpriseAPI* gen gen.opt db_filter_parse.ml db_filter_parse.mli db_filter_lex.ml - rm -f block_device_io unit_test_marshall block_device_io.opt unit_test_marshall.opt database_test + rm -f block_device_io unit_test_marshall block_device_io.opt unit_test_marshall.opt diff --git a/ocaml/database/db_action_helper.ml b/ocaml/database/db_action_helper.ml index dc1783b08b9..96d911b3eb2 100644 --- a/ocaml/database/db_action_helper.ml +++ b/ocaml/database/db_action_helper.ml @@ -22,15 +22,11 @@ let events_notify ?(snapshot) ty op ref = match !__callback with | None -> () | Some f -> f ?snapshot ty op ref - + (* exception Db_set_or_map_parse_fail of string let parse_sexpr s : SExpr.t list = match SExpr_TS.of_string s with | SExpr.Node xs -> xs | _ -> raise (Db_set_or_map_parse_fail s) - -let add_key_to_set key set = - if List.mem (SExpr.String key) set - then set - else SExpr.String key :: set +*) diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index 066ffecac34..1e9bbaef811 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -45,8 +45,9 @@ let blow_away_non_persistent_fields (schema: Schema.t) db = (fun name { Stat.created; modified } v (acc,max_upd) -> try let col = Schema.Table.find name schema in - let v',modified' = if col.Schema.Column.persistent then v,modified else Schema.Value.marshal col.Schema.Column.empty,g in - (Row.update modified' name "" (fun _ -> v') (Row.add created name v' acc),max max_upd modified') + let empty = col.Schema.Column.empty in + let v',modified' = if col.Schema.Column.persistent then v,modified else empty,g in + (Row.update modified' name empty (fun _ -> v') (Row.add created name v' acc),max max_upd modified') with Not_found -> Printf.printf "Skipping unknown column: %s\n%!" name; (acc,max max_upd modified)) row (Row.empty,0L) in diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index c1a980bb7a3..365eb814994 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -57,10 +57,7 @@ let read_field_internal t tblname fldname objref db = (* Read field from cache *) let read_field t tblname fldname objref = - read_field_internal t tblname fldname objref (get_database t) - - - + Schema.Value.marshal (read_field_internal t tblname fldname objref (get_database t)) (** Finds the longest XML-compatible UTF-8 prefix of the given *) (** string, by truncating the string at the first incompatible *) @@ -81,6 +78,10 @@ let write_field_locked t tblname objref fldname newval = Database.notify (WriteField(tblname, objref, fldname, current_val, newval)) (get_database t) let write_field t tblname objref fldname newval = + let db = get_database t in + let schema = Schema.table tblname (Database.schema db) in + let column = Schema.Table.find fldname schema in + let newval = Schema.Value.unmarshal column.Schema.Column.ty newval in with_lock (fun () -> write_field_locked t tblname objref fldname newval) @@ -107,16 +108,16 @@ let read_set_ref t rcd = let _, many_tbl, many_fld = List.find (fun (a, _, _) -> a = one_fld) rels in let objref = rcd.where_value in - let str = read_field_internal t many_tbl many_fld objref db in - String_unmarshall_helper.set (fun x -> x) str + Schema.Value.Unsafe_cast.set (read_field_internal t many_tbl many_fld objref db) end else begin error "Illegal read_set_ref query { table = %s; where_field = %s; where_value = %s; return = %s }; falling back to linear scan" rcd.table rcd.where_field rcd.where_value rcd.return; Printf.printf "Illegal read_set_ref query { table = %s; where_field = %s; where_value = %s; return = %s }; falling back to linear scan\n%!" rcd.table rcd.where_field rcd.where_value rcd.return; let tbl = TableSet.find rcd.table (Database.tableset db) in Table.fold (fun rf _ row acc -> - if Row.find rcd.where_field row = rcd.where_value - then Row.find rcd.return row :: acc else acc) + let v = Schema.Value.Unsafe_cast.string (Row.find rcd.where_field row) in + if v = rcd.where_value + then v :: acc else acc) tbl [] end @@ -136,16 +137,15 @@ let read_record_internal db tblname objref = ordinary fields *) let schema = Schema.table tblname (Database.schema db) in let set_ref = List.filter (fun (k, _) -> - try - let column = Schema.Table.find k schema in - column.Schema.Column.issetref - with Not_found as e -> - Printf.printf "Failed to find table %s in schema\n%!" k; - raise e + let column = Schema.Table.find k schema in + column.Schema.Column.issetref + ) fvlist in + let fvlist = List.map (fun (k, v) -> + k, Schema.Value.marshal v ) fvlist in (* the set_ref fields must be converted back into lists *) let set_ref = List.map (fun (k, v) -> - k, String_unmarshall_helper.set (fun x -> x) v) set_ref in + k, Schema.Value.Unsafe_cast.set v) set_ref in (fvlist, set_ref) with Not_found -> raise (DBCache_NotFound ("missing row", tblname, objref)) @@ -172,13 +172,18 @@ let delete_row t tblname objref = (* Create new row in tbl containing specified k-v pairs *) let create_row_locked t tblname kvs' new_objref = - - (* Ensure values are valid for UTF-8-encoded XML. *) - let kvs' = List.map (fun (key, value) -> (key, ensure_utf8_xml value)) kvs' in + let db = get_database t in + let schema = Schema.table tblname (Database.schema db) in + + let kvs' = List.map (fun (key, value) -> + let value = ensure_utf8_xml value in + let column = Schema.Table.find key schema in + key, Schema.Value.unmarshal column.Schema.Column.ty value + ) kvs' in (* we add the reference to the row itself so callers can use read_field_where to return the reference: awkward if it is just the key *) - let kvs' = (Db_names.ref, new_objref) :: kvs' in + let kvs' = (Db_names.ref, Schema.Value.String new_objref) :: kvs' in let g = Manifest.generation (Database.manifest (get_database t)) in let row = List.fold_left (fun row (k, v) -> Row.add g k v row) Row.empty kvs' in let schema = Schema.table tblname (Database.schema (get_database t)) in @@ -197,8 +202,8 @@ let read_field_where t rcd = let tbl = TableSet.find rcd.table (Database.tableset db) in Table.fold (fun r _ row acc -> - let field = Row.find rcd.where_field row in - if field = rcd.where_value then Row.find rcd.return row :: acc else acc + let field = Schema.Value.marshal (Row.find rcd.where_field row) in + if field = rcd.where_value then Schema.Value.marshal (Row.find rcd.return row) :: acc else acc ) tbl [] let db_get_by_uuid t tbl uuid_val = @@ -226,11 +231,11 @@ let find_refs_with_filter_internal db (tblname: string) (expr: Db_filter_types.e let tbl = TableSet.find tblname (Database.tableset db) in let eval_val row = function | Db_filter_types.Literal x -> x - | Db_filter_types.Field x -> Row.find x row in + | Db_filter_types.Field x -> Schema.Value.marshal (Row.find x row) in Table.fold (fun r _ row acc -> if Db_filter.eval_expr (eval_val row) expr - then Row.find Db_names.ref row :: acc else acc + then Schema.Value.Unsafe_cast.string (Row.find Db_names.ref row) :: acc else acc ) tbl [] let find_refs_with_filter t = find_refs_with_filter_internal (get_database t) @@ -248,7 +253,7 @@ let process_structured_field_locked t (key,value) tblname fld objref proc_fn_sel let tbl = TableSet.find tblname (Database.tableset (get_database t)) in let row = Table.find objref tbl in let existing_str = Row.find fld row in - let new_str = match proc_fn_selector with + let newval = match proc_fn_selector with | AddSet -> add_to_set key existing_str | RemoveSet -> remove_from_set key existing_str | AddMap -> @@ -260,7 +265,7 @@ let process_structured_field_locked t (key,value) tblname fld objref proc_fn_sel raise (Duplicate_key (tblname,fld,objref,key)); end | RemoveMap -> remove_from_map key existing_str in - write_field t tblname objref fld new_str + write_field_locked t tblname objref fld newval with Not_found -> raise (DBCache_NotFound ("missing row", tblname, objref)) diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 89331b95f1e..79fd0926994 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -14,10 +14,6 @@ open Db_exn -module Value = struct - type t = string -end - module Time = struct type t = Generation.t end @@ -44,7 +40,7 @@ module StringMap = struct end module type VAL = sig - type v + type t end module type MAP = sig @@ -62,11 +58,11 @@ module type MAP = sig val touch : int64 -> string -> value -> t -> t end -(** A specialised StringMap whose range type is V.v, and which keeps a record of when records are created/updated *) +(** A specialised StringMap whose range type is V.t, and which keeps a record of when records are created/updated *) module Make = functor(V: VAL) -> struct type x = { stat: Stat.t; - v : V.v + v : V.t } type map_t = x StringMap.t let empty = StringMap.empty @@ -96,12 +92,11 @@ module Make = functor(V: VAL) -> struct let fold_over_recent since f t initial = StringMap.fold (fun x y z -> if y.stat.Stat.modified > since then f x y.stat y.v z else z) t initial end -module StringStringMap = Make(struct type v = string end) - module Row = struct - include StringStringMap + include Make(Schema.Value) + type t=map_t - type value = Value.t + type value = Schema.Value.t let find key t = try find key t with Not_found -> raise (DBCache_NotFound ("missing field", key, "")) @@ -109,14 +104,14 @@ module Row = struct List.fold_left (fun t c -> if not(mem c.Schema.Column.name t) then match c.Schema.Column.default with - | Some default -> add g c.Schema.Column.name (Schema.Value.marshal default) t + | Some default -> add g c.Schema.Column.name default t | None -> raise (DBCache_NotFound ("missing field", c.Schema.Column.name, "")) else t) t schema.Schema.Table.columns end -module StringRowMap = Make(struct type v = Row.t end) - module Table = struct + module StringRowMap = Make(Row) + type t = { rows : StringRowMap.map_t; deleted_len : int; deleted : (Time.t * Time.t * string) list } @@ -158,10 +153,9 @@ module Table = struct loop t.deleted acc end -module StringTableMap = Make(struct type v = Table.t end) - module TableSet = struct - include StringTableMap + include Make(Table) + type t=map_t type value = Table.t let find key t = @@ -223,10 +217,10 @@ end (** The core database updates (RefreshRow and PreDelete is more of an 'event') *) type update = | RefreshRow of string (* tblname *) * string (* objref *) - | WriteField of string (* tblname *) * string (* objref *) * string (* fldname *) * string (* oldval *) * string (* newval *) + | WriteField of string (* tblname *) * string (* objref *) * string (* fldname *) * Schema.Value.t (* oldval *) * Schema.Value.t (* newval *) | PreDelete of string (* tblname *) * string (* objref *) - | Delete of string (* tblname *) * string (* objref *) * (string * string) list (* values *) - | Create of string (* tblname *) * string (* objref *) * (string * string) list (* values *) + | Delete of string (* tblname *) * string (* objref *) * (string * Schema.Value.t) list (* values *) + | Create of string (* tblname *) * string (* objref *) * (string * Schema.Value.t) list (* values *) module Database = struct type t = { @@ -284,8 +278,8 @@ module Database = struct (fun rf _ row acc -> let acc = KeyMap.add_unique tblname Db_names.ref (Ref rf) (tblname, rf) acc in if Row.mem Db_names.uuid row - then KeyMap.add_unique tblname Db_names.uuid (Uuid (Row.find Db_names.uuid row)) (tblname, rf) acc - else acc + then KeyMap.add_unique tblname Db_names.uuid (Uuid (Schema.Value.Unsafe_cast.string (Row.find Db_names.uuid row))) (tblname, rf) acc + else acc ) tbl acc) x.tables KeyMap.empty in @@ -302,7 +296,7 @@ module Database = struct upgrade) *) let many_tbl' = Table.fold (fun vm _ row acc -> - let row' = Row.add g many_fldname (SExpr.string_of (SExpr.Node [])) row in + let row' = Row.add g many_fldname (Schema.Value.Set []) row in Table.add g vm row' acc) many_tbl Table.empty in @@ -310,7 +304,7 @@ module Database = struct let vm_to_vbds = Table.fold (fun vbd _ row acc -> - let vm = Row.find one_fldname row in + let vm = Schema.Value.Unsafe_cast.string (Row.find one_fldname row) in let existing = if Schema.ForeignMap.mem vm acc then Schema.ForeignMap.find vm acc else [] in Schema.ForeignMap.add vm (vbd :: existing) acc) one_tbl Schema.ForeignMap.empty in @@ -320,8 +314,7 @@ module Database = struct then acc else let row = Table.find vm acc in - let vbds' = SExpr.string_of (SExpr.Node (List.map (fun x -> SExpr.String x) vbds)) in - let row' = Row.add g many_fldname vbds' row in + let row' = Row.add g many_fldname (Schema.Value.Set vbds) row in Table.add g vm row' acc) vm_to_vbds many_tbl' in TableSet.add g many_tblname many_tbl'' tables) @@ -349,38 +342,22 @@ end (* Helper functions to deal with Sets and Maps *) let add_to_set key t = - let existing = Db_action_helper.parse_sexpr t in - let processed = Db_action_helper.add_key_to_set key existing in - SExpr.string_of (SExpr.Node processed) + let t = Schema.Value.Unsafe_cast.set t in + Schema.Value.Set (if List.mem key t then t else key :: t) let remove_from_set key t = - let existing = Db_action_helper.parse_sexpr t in - let processed = List.filter (function SExpr.String x -> x <> key | _ -> true) existing in - SExpr.string_of (SExpr.Node processed) - -let set_of_string t = - List.map - (function SExpr.String x -> x - | x -> failwith (Printf.sprintf "Unexpected sexpr: %s" t)) - (Db_action_helper.parse_sexpr t) -let string_of_set t = SExpr.string_of (SExpr.Node (List.map (fun x -> SExpr.String x) t)) + let t = Schema.Value.Unsafe_cast.set t in + Schema.Value.Set (List.filter (fun x -> x <> key) t) exception Duplicate let add_to_map key value t = - let existing = Db_action_helper.parse_sexpr t in - let kv = SExpr.Node [ SExpr.String key; SExpr.String value ] in - let duplicate = List.fold_left (||) false - (List.map (function SExpr.Node (SExpr.String k :: _) when k = key -> true - | _ -> false) existing) in - if duplicate then raise Duplicate; - let processed = kv::existing in - SExpr.string_of (SExpr.Node processed) + let t = Schema.Value.Unsafe_cast.pairs t in + if List.mem key (List.map fst t) then raise Duplicate; + Schema.Value.Pairs ((key, value) :: t) let remove_from_map key t = - let existing = Db_action_helper.parse_sexpr t in - let processed = List.filter (function SExpr.Node [ SExpr.String x; _ ] -> x <> key - | _ -> true) existing in - SExpr.string_of (SExpr.Node processed) + let t = Schema.Value.Unsafe_cast.pairs t in + Schema.Value.Pairs (List.filter (fun (k, _) -> k <> key) t) let (++) f g x = f (g x) @@ -401,14 +378,14 @@ let unsafe_set_field g tblname objref fldname newval = (Database.update ++ (TableSet.update g tblname Table.empty) ++ (Table.update g objref Row.empty) - ++ (Row.update g fldname "")) + ++ (Row.update g fldname (Schema.Value.String ""))) (fun _ -> newval) let update_one_to_many g tblname objref f db = if not (is_valid tblname objref db) then db else List.fold_left (fun db (one_fld, many_tbl, many_fld) -> (* the value one_fld_val is the Ref _ *) - let one_fld_val = get_field tblname objref one_fld db in + let one_fld_val = Schema.Value.Unsafe_cast.string (get_field tblname objref one_fld db) in let valid = try ignore(Database.table_of_ref one_fld_val db); true with _ -> false in if valid then unsafe_set_field g many_tbl one_fld_val many_fld (f objref (get_field many_tbl one_fld_val many_fld db)) db @@ -418,8 +395,7 @@ let update_one_to_many g tblname objref f db = let update_many_to_many g tblname objref f db = if not (is_valid tblname objref db) then db else List.fold_left (fun db (this_fld, other_tbl, other_fld) -> - let this_fld_val = get_field tblname objref this_fld db in - let this_fld_refs = set_of_string this_fld_val in + let this_fld_refs = Schema.Value.Unsafe_cast.set (get_field tblname objref this_fld db) in (* for each of this_fld_refs, apply f *) List.fold_left (fun db other_ref -> let valid = try ignore(Database.table_of_ref other_ref db); true with _ -> false in @@ -452,7 +428,7 @@ let set_field tblname objref fldname newval db = ++ ((Database.update ++ (TableSet.update g tblname Table.empty) ++ (Table.update g objref Row.empty) - ++ (Row.update g fldname "")) (fun _ -> newval)) + ++ (Row.update g fldname (Schema.Value.String ""))) (fun _ -> newval)) ++ (update_one_to_many g tblname objref remove_from_set) ++ (update_many_to_many g tblname objref remove_from_set)) db end else begin @@ -461,7 +437,7 @@ let set_field tblname objref fldname newval db = ++ ((Database.update ++ (TableSet.update g tblname Table.empty) ++ (Table.update g objref Row.empty) - ++ (Row.update g fldname "")) + ++ (Row.update g fldname (Schema.Value.String ""))) (fun _ -> newval))) db end @@ -489,13 +465,13 @@ let add_row tblname objref newval db = ++ (Database.update_keymap (KeyMap.add_unique tblname Db_names.ref (Ref objref) (tblname, objref))) ++ (Database.update_keymap (fun m -> if Row.mem Db_names.uuid newval - then KeyMap.add_unique tblname Db_names.uuid (Uuid (Row.find Db_names.uuid newval)) (tblname, objref) m + then KeyMap.add_unique tblname Db_names.uuid (Uuid (Schema.Value.Unsafe_cast.string (Row.find Db_names.uuid newval))) (tblname, objref) m else m))) db let remove_row tblname objref db = let uuid = try - Some (Row.find Db_names.uuid (Table.find objref (TableSet.find tblname (Database.tableset db)))) + Some (Schema.Value.Unsafe_cast.string (Row.find Db_names.uuid (Table.find objref (TableSet.find tblname (Database.tableset db))))) with _ -> None in let g = db.Database.manifest.Manifest.generation_count in (Database.increment diff --git a/ocaml/database/db_cache_types.mli b/ocaml/database/db_cache_types.mli index a2fb7978c28..d1a9354eec1 100644 --- a/ocaml/database/db_cache_types.mli +++ b/ocaml/database/db_cache_types.mli @@ -12,12 +12,6 @@ * GNU Lesser General Public License for more details. *) -module Value : sig - type t = string - (** A value stored in the database *) - -end - module Time : sig type t = Generation.t (** A monotonically increasing counter associated with this database *) @@ -85,7 +79,7 @@ end module Row : sig include MAP - with type value = Value.t + with type value = Schema.Value.t val add_defaults: Time.t -> Schema.Table.t -> t -> t (** [add_defaults now schema t]: returns a row which is [t] extended to contain @@ -122,10 +116,10 @@ module Manifest : (** The core database updates (RefreshRow and PreDelete is more of an 'event') *) type update = | RefreshRow of string (* tblname *) * string (* objref *) - | WriteField of string (* tblname *) * string (* objref *) * string (* fldname *) * string (* oldval *) * string (* newval *) + | WriteField of string (* tblname *) * string (* objref *) * string (* fldname *) * Schema.Value.t (* oldval *) * Schema.Value.t (* newval *) | PreDelete of string (* tblname *) * string (* objref *) - | Delete of string (* tblname *) * string (* objref *) * (string * string) list (* values *) - | Create of string (* tblname *) * string (* objref *) * (string * string) list (* values *) + | Delete of string (* tblname *) * string (* objref *) * (string * Schema.Value.t) list (* values *) + | Create of string (* tblname *) * string (* objref *) * (string * Schema.Value.t) list (* values *) module Database : sig @@ -150,13 +144,13 @@ module Database : end exception Duplicate -val add_to_set : string -> string -> string -val remove_from_set : string -> string -> string -val add_to_map : string -> string -> string -> string -val remove_from_map : string -> string -> string +val add_to_set : string -> Schema.Value.t -> Schema.Value.t +val remove_from_set : string -> Schema.Value.t -> Schema.Value.t +val add_to_map : string -> string -> Schema.Value.t -> Schema.Value.t +val remove_from_map : string -> Schema.Value.t -> Schema.Value.t -val set_field : string -> string -> string -> string -> Database.t -> Database.t -val get_field : string -> string -> string -> Database.t -> string +val set_field : string -> string -> string -> Schema.Value.t -> Database.t -> Database.t +val get_field : string -> string -> string -> Database.t -> Schema.Value.t val remove_row : string -> string -> Database.t -> Database.t val add_row : string -> string -> Row.t -> Database.t -> Database.t val touch : string -> string -> Database.t -> Database.t diff --git a/ocaml/database/db_xml.ml b/ocaml/database/db_xml.ml index 04a7921e740..31740c0477f 100644 --- a/ocaml/database/db_xml.ml +++ b/ocaml/database/db_xml.ml @@ -49,7 +49,7 @@ module To = struct then [("__mtime",Generation.to_string modified); ("__ctime",Generation.to_string created); ("ref",rf)] else [("ref",rf)] in - let (tag: Xmlm.tag) = make_tag "row" (List.rev (Row.fold (fun k _ v acc -> (k, Xml_spaces.protect v) :: acc) row preamble)) in + let (tag: Xmlm.tag) = make_tag "row" (List.rev (Row.fold (fun k _ v acc -> (k, Xml_spaces.protect (Schema.Value.marshal v)) :: acc) row preamble)) in Xmlm.output output (`El_start tag); Xmlm.output output `El_end in let tag = make_tag "table" [ "name", name ] in @@ -102,14 +102,14 @@ module From = struct raise (Unmarshall_error "Unexpected end of file") end else f accu in - let rec f ((tableset, table, manifest) as acc) = match Xmlm.input input with + let rec f ((tableset, table, tblname, manifest) as acc) = match Xmlm.input input with (* On reading a start tag... *) | `El_start (tag: Xmlm.tag) -> Stack.push tag tags; begin match tag with | (_, ("database" | "manifest")), _ -> f acc - | (_, "table"), [ (_, "name"), _ ] -> - f (tableset, Table.empty, manifest) + | (_, "table"), [ (_, "name"), tblname ] -> + f (tableset, Table.empty, tblname, manifest) | (_, "row"), ((_, "ref"), rf) :: rest -> (* Remove any other duplicate "ref"s which might have sneaked in there *) let rest = List.filter (fun ((_,k), _) -> k <> "ref") rest in @@ -118,11 +118,15 @@ module From = struct let ctime = match ctime_l with | [(_,ctime_s)] -> Int64.of_string ctime_s | _ -> 0L in let mtime = match mtime_l with | [(_,mtime_s)] -> Int64.of_string mtime_s | _ -> 0L in let row = List.fold_left (fun row ((_, k), v) -> - Row.update mtime k "" (fun _ -> (Xml_spaces.unprotect v)) (Row.add ctime k (Xml_spaces.unprotect v) row) + let table_schema = Schema.Database.find tblname schema.Schema.database in + let column_schema = Schema.Table.find k table_schema in + let value = Schema.Value.unmarshal column_schema.Schema.Column.ty (Xml_spaces.unprotect v) in + let empty = column_schema.Schema.Column.empty in + Row.update mtime k empty (fun _ -> value) (Row.add ctime k value row) ) Row.empty rest in - f (tableset, (Table.update mtime rf Row.empty (fun _ -> row) (Table.add ctime rf row table)), manifest) + f (tableset, (Table.update mtime rf Row.empty (fun _ -> row) (Table.add ctime rf row table)), tblname, manifest) | (_, "pair"), [ (_, "key"), k; (_, "value"), v ] -> - f (tableset, table, (k, v) :: manifest) + f (tableset, table, tblname, (k, v) :: manifest) | (_, name), _ -> raise (Unmarshall_error (Printf.sprintf "Unexpected tag: %s" name)) end @@ -132,13 +136,13 @@ module From = struct begin match tag with | (_, ("database" | "manifest" | "row" | "pair")), _ -> maybe_return f acc | (_, "table"), [ (_, "name"), name ] -> - maybe_return f (TableSet.add 0L name table tableset, Table.empty, manifest) + maybe_return f (TableSet.add 0L name table tableset, Table.empty, "", manifest) | (_, name), _ -> raise (Unmarshall_error (Printf.sprintf "Unexpected tag: %s" name)) end | _ -> f acc in - let (ts, _, manifest) = f (TableSet.empty, Table.empty, []) in + let (ts, _, _, manifest) = f (TableSet.empty, Table.empty, "", []) in let g = Int64.of_string (List.assoc _generation_count manifest) in let major_vsn = int_of_string (List.assoc _schema_major_vsn manifest) in let minor_vsn = int_of_string (List.assoc _schema_minor_vsn manifest) in diff --git a/ocaml/database/eventgen.ml b/ocaml/database/eventgen.ml index 558a64ebed2..428251b0b3a 100644 --- a/ocaml/database/eventgen.ml +++ b/ocaml/database/eventgen.ml @@ -79,11 +79,15 @@ let database_callback event db = let other_tbl_refs_for_this_field tblname fldname = List.filter (fun (_,fld) -> fld=fldname) (other_tbl_refs tblname) in - let is_valid_ref r = - try - ignore(Database.table_of_ref r db); - true - with _ -> false in + let is_valid_ref = function + | Schema.Value.String r -> + begin + try + ignore(Database.table_of_ref r db); + true + with _ -> false + end + | _ -> false in match event with | RefreshRow (tblname, objref) -> @@ -100,12 +104,14 @@ let database_callback event db = | WriteField (tblname, objref, fldname, oldval, newval) -> let events_old_val = if is_valid_ref oldval then + let oldval = Schema.Value.Unsafe_cast.string oldval in events_of_other_tbl_refs (List.map (fun (tbl,fld) -> (tbl, oldval, find_get_record tbl ~__context:context ~self:oldval)) (other_tbl_refs_for_this_field tblname fldname)) else [] in let events_new_val = if is_valid_ref newval then + let newval = Schema.Value.Unsafe_cast.string newval in events_of_other_tbl_refs (List.map (fun (tbl,fld) -> (tbl, newval, find_get_record tbl ~__context:context ~self:newval)) (other_tbl_refs_for_this_field tblname fldname)) @@ -148,9 +154,10 @@ let database_callback event db = let other_tbl_refs = List.fold_left (fun accu (remote_tbl,fld) -> let fld_value = List.assoc fld kv in - if is_valid_ref fld_value - then (remote_tbl, fld_value, find_get_record remote_tbl ~__context:context ~self:fld_value) :: accu - else accu) + if is_valid_ref fld_value then begin + let fld_value = Schema.Value.Unsafe_cast.string fld_value in + (remote_tbl, fld_value, find_get_record remote_tbl ~__context:context ~self:fld_value) :: accu + end else accu) [] other_tbl_refs in let other_tbl_ref_events = events_of_other_tbl_refs other_tbl_refs in List.iter (function @@ -167,9 +174,10 @@ let database_callback event db = let other_tbl_refs = List.fold_left (fun accu (tbl,fld) -> let fld_value = List.assoc fld kv in - if is_valid_ref fld_value - then (tbl, fld_value, find_get_record tbl ~__context:context ~self:fld_value) :: accu - else accu) + if is_valid_ref fld_value then begin + let fld_value = Schema.Value.Unsafe_cast.string fld_value in + (tbl, fld_value, find_get_record tbl ~__context:context ~self:fld_value) :: accu + end else accu) [] other_tbl_refs in let other_tbl_events = events_of_other_tbl_refs other_tbl_refs in begin match snapshot() with diff --git a/ocaml/database/redo_log.ml b/ocaml/database/redo_log.ml index 047228cb4c0..19aebbeab75 100644 --- a/ocaml/database/redo_log.ml +++ b/ocaml/database/redo_log.ml @@ -759,9 +759,9 @@ let database_callback event db = | Db_cache_types.RefreshRow (tblname, objref) -> None | Db_cache_types.WriteField (tblname, objref, fldname, oldval, newval) -> - R.debug "WriteField(%s, %s, %s, %s, %s)" tblname objref fldname oldval newval; + R.debug "WriteField(%s, %s, %s, %s, %s)" tblname objref fldname (Schema.Value.marshal oldval) (Schema.Value.marshal newval); if Schema.is_field_persistent (Db_cache_types.Database.schema db) tblname fldname - then Some (WriteField(tblname, objref, fldname, newval)) + then Some (WriteField(tblname, objref, fldname, Schema.Value.marshal newval)) else None | Db_cache_types.PreDelete (tblname, objref) -> None @@ -771,7 +771,7 @@ let database_callback event db = else None | Db_cache_types.Create (tblname, objref, kvs) -> if Schema.is_table_persistent (Db_cache_types.Database.schema db) tblname - then Some (CreateRow(tblname, objref, kvs)) + then Some (CreateRow(tblname, objref, (List.map (fun (k, v) -> k, Schema.Value.marshal v) kvs))) else None in diff --git a/ocaml/database/ref_index.ml b/ocaml/database/ref_index.ml index c0625036a5d..676e26f8806 100644 --- a/ocaml/database/ref_index.ml +++ b/ocaml/database/ref_index.ml @@ -30,9 +30,9 @@ let lookup key = let db = Db_ref.get_database t in let r (tblname, objref) = let row = Table.find objref (TableSet.find tblname (Database.tableset db)) in { - name_label = (try Some (Row.find Db_names.name_label row) with _ -> None); - uuid = Row.find Db_names.uuid row; - _ref = Row.find Db_names.ref row; + name_label = (try Some (Schema.Value.Unsafe_cast.string (Row.find Db_names.name_label row)) with _ -> None); + uuid = Schema.Value.Unsafe_cast.string (Row.find Db_names.uuid row); + _ref = Schema.Value.Unsafe_cast.string (Row.find Db_names.ref row); } in Opt.map r (Database.lookup_key key db) diff --git a/ocaml/database/schema.ml b/ocaml/database/schema.ml index 3a5945ab1a1..d0b32b6aa0c 100644 --- a/ocaml/database/schema.ml +++ b/ocaml/database/schema.ml @@ -19,6 +19,15 @@ module Type = struct | Set (* of strings *) | Pairs (* of string * string *) with sexp + + exception Error of t * t + let _ = Printexc.register_printer (function + | Error (expected, actual) -> + Some (Printf.sprintf "Schema.Type.Error: expected %s; received %s" + (Sexplib.Sexp.to_string_hum (sexp_of_t expected)) + (Sexplib.Sexp.to_string_hum (sexp_of_t actual))) + | _ -> None + ) end module Value = struct @@ -32,6 +41,28 @@ module Value = struct | String x -> x | Set xs -> String_marshall_helper.set (fun x -> x) xs | Pairs xs -> String_marshall_helper.map (fun x -> x) (fun x -> x) xs + + let unmarshal ty x = match ty with + | Type.String -> String x + | Type.Set -> Set (String_unmarshall_helper.set (fun x -> x) x) + | Type.Pairs -> Pairs (String_unmarshall_helper.map (fun x -> x) (fun x -> x) x) + + module Unsafe_cast = struct + let string = function + | String x -> x + | Set _ -> raise (Type.Error(Type.String, Type.Set)) + | Pairs _ -> raise (Type.Error(Type.String, Type.Pairs)) + + let set = function + | Set xs -> xs + | String _ -> raise (Type.Error(Type.Set, Type.String)) + | Pairs _ -> raise (Type.Error(Type.Set, Type.Pairs)) + + let pairs = function + | Pairs x -> x + | String _ -> raise (Type.Error(Type.Pairs, Type.String)) + | Set _ -> raise (Type.Error(Type.Pairs, Type.Set)) + end end module Column = struct diff --git a/ocaml/db_process/xapi_db_process.ml b/ocaml/db_process/xapi_db_process.ml index d66e1340121..bc24da824fa 100644 --- a/ocaml/db_process/xapi_db_process.ml +++ b/ocaml/db_process/xapi_db_process.ml @@ -99,7 +99,7 @@ let find_my_host_row() = let localhost_uuid = Xapi_inventory.lookup Xapi_inventory._installation_uuid in let db = Db_ref.get_database (Db_backend.make ()) in let tbl = TableSet.find Db_names.host (Database.tableset db) in - Table.fold (fun r _ row acc -> if Row.find Db_names.uuid row = localhost_uuid then (Some (r, row)) else acc) tbl None + Table.fold (fun r _ row acc -> if Schema.Value.Unsafe_cast.string (Row.find Db_names.uuid row) = localhost_uuid then (Some (r, row)) else acc) tbl None let _iscsi_iqn = "iscsi_iqn" let _other_config = "other_config" @@ -109,8 +109,7 @@ let do_read_hostiqn() = match find_my_host_row() with | None -> failwith "No row for localhost" | Some (_, row) -> - let other_config_sexpr = Row.find Db_names.other_config row in - let other_config = String_unmarshall_helper.map (fun x->x) (fun x->x) other_config_sexpr in + let other_config = Schema.Value.Unsafe_cast.pairs (Row.find Db_names.other_config row) in Printf.printf "%s" (List.assoc _iscsi_iqn other_config) let do_write_hostiqn() = @@ -122,8 +121,7 @@ let do_write_hostiqn() = | None -> failwith "No row for localhost" | Some (r, row) -> (* read other_config from my row, replace host_iqn if already there, add it if its not there and write back *) - let other_config_sexpr = Row.find Db_names.other_config row in - let other_config = String_unmarshall_helper.map (fun x->x) (fun x->x) other_config_sexpr in + let other_config = Schema.Value.Unsafe_cast.pairs (Row.find Db_names.other_config row) in let other_config = if List.mem_assoc _iscsi_iqn other_config then (* replace if key already exists *) @@ -131,7 +129,7 @@ let do_write_hostiqn() = else (* ... otherwise add new key/value pair *) (_iscsi_iqn,new_iqn)::other_config in - let other_config = String_marshall_helper.map (fun x->x) (fun x->x) other_config in + let other_config = Schema.Value.Pairs other_config in Db_ref.update_database (Db_backend.make ()) (set_field Db_names.host r Db_names.other_config other_config); write_out_databases() diff --git a/ocaml/idl/ocaml_backend/exnHelper.ml b/ocaml/idl/ocaml_backend/exnHelper.ml index 59d00a36613..3272d0bb53d 100644 --- a/ocaml/idl/ocaml_backend/exnHelper.ml +++ b/ocaml/idl/ocaml_backend/exnHelper.ml @@ -33,8 +33,6 @@ let error_of_exn e = | Db_exn.Too_many_values(tbl, objref, uuid) -> (* Very bad: database has duplicate references or UUIDs *) internal_error, [ sprintf "duplicate objects in database: tbl='%s'; object_ref='%s'; uuid='%s'" tbl objref uuid ] - | Db_action_helper.Db_set_or_map_parse_fail s -> - internal_error, [ sprintf "db set/map failure: %s" s ] | Db_exn.DBCache_NotFound (reason,p1,p2) -> begin match reason with From 74fd92572382244e644a035cd6940848212a36d9 Mon Sep 17 00:00:00 2001 From: David Scott Date: Thu, 13 Nov 2014 21:16:50 +0000 Subject: [PATCH 20/21] Database: re-add a test for the database library The library test can be run easily from the build. The remainder of 'database_test' is really a 'database server test' which doesn't currently work. Signed-off-by: David Scott --- Makefile | 3 +- ocaml/database/OMakefile | 6 ++- ocaml/database/db_cache_test.ml | 81 +++++++++++++++++++++++++++++++++ 3 files changed, 86 insertions(+), 4 deletions(-) create mode 100644 ocaml/database/db_cache_test.ml diff --git a/Makefile b/Makefile index 2ecdd2ba6ff..8b0fbc059b4 100644 --- a/Makefile +++ b/Makefile @@ -60,8 +60,7 @@ test: @echo @echo @ HA binpack test @./ocaml/xapi/binpack -# The following test no longer runs: -# ./ocaml/database/database_test + ./ocaml/database/database_test # The following test no longer compiles: # ./ocaml/xenops/device_number_test # The following test must be run in dom0: diff --git a/ocaml/database/OMakefile b/ocaml/database/OMakefile index 0f4caa842f2..0e2d2a05cca 100644 --- a/ocaml/database/OMakefile +++ b/ocaml/database/OMakefile @@ -1,6 +1,6 @@ OCAMLINCLUDES = ../idl/ocaml_backend ../xapi ../idl ../util ../autogen .. -OCAMLPACKS = xml-light2 stdext stunnel http-svr xcp sexpr rpclib uuid gzip xcp-inventory +OCAMLPACKS = xml-light2 stdext stunnel http-svr xcp sexpr rpclib uuid gzip xcp-inventory oUnit #OCAMLPPFLAGS = -pp "camlp4o" #OCAMLDEPFLAGS = -pp "camlp4o" @@ -21,10 +21,12 @@ OCamlProgram(block_device_io, $(BLOCK_DEVICE_IO_FILES)) OCamlDocProgram(block_device_io, $(BLOCK_DEVICE_IO_FILES)) DATABASE_SERVER_FILES = database_server_main test_schemas ../autogen/db_actions +DATABASE_TEST_FILES = db_cache_test test_schemas section: #XXX there are lots of interdependencies which we should be aim to remove OCAML_LIBS += ../util/version ../idl/ocaml_backend/common ../idl/ocaml_backend/client ../util/stats ../idl/ocaml_backend/server OCamlProgram(database_server, $(DATABASE_SERVER_FILES)) + OCamlProgram(database_test, $(DATABASE_TEST_FILES)) section: OCAML_LIBS += ../idl/ocaml_backend/common ../idl/ocaml_backend/client ../idl/ocaml_backend/server @@ -41,5 +43,5 @@ sdk-install: install .PHONY: clean clean: rm -f $(CLEAN_OBJS) xenEnterpriseAPI* gen gen.opt db_filter_parse.ml db_filter_parse.mli db_filter_lex.ml - rm -f block_device_io unit_test_marshall block_device_io.opt unit_test_marshall.opt + rm -f block_device_io unit_test_marshall block_device_io.opt unit_test_marshall.opt database_test diff --git a/ocaml/database/db_cache_test.ml b/ocaml/database/db_cache_test.ml new file mode 100644 index 00000000000..d7f0ae7d75a --- /dev/null +++ b/ocaml/database/db_cache_test.ml @@ -0,0 +1,81 @@ +(* + * Copyright (C) 2010-2014 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Pervasiveext +open Db_cache_types + +let create_test_db () = + let schema = Test_schemas.many_to_many in + let db = + ((fun x -> x) + ++ (Db_backend.blow_away_non_persistent_fields schema) + ++ (Db_upgrade.generic_database_upgrade)) + (Database.make schema) in + + db + +let check_many_to_many () = + let db = create_test_db () in + (* make a foo with bars = [] *) + (* make a bar with foos = [] *) + (* add 'bar' to foo.bars *) + let db = + ((fun x -> x) + ++ (set_field "foo" "foo:1" "bars" (add_to_set "bar:1" (Schema.Value.Set []))) + ++ (add_row "foo" "foo:1" (Row.add 0L Db_names.ref (Schema.Value.String "foo:1") (Row.add 0L "bars" (Schema.Value.Set []) Row.empty))) + ++ (add_row "bar" "bar:1" (Row.add 0L Db_names.ref (Schema.Value.String "bar:1") (Row.add 0L "foos" (Schema.Value.Set []) Row.empty)))) db in + (* check that 'bar.foos' includes 'foo' *) + let bar_1 = Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in + let bar_foos = Row.find "foos" bar_1 in + if bar_foos <> (Schema.Value.Set [ "foo:1" ]) + then failwith (Printf.sprintf "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s" (Sexplib.Sexp.to_string (Schema.Value.sexp_of_t bar_foos))); + + (* set foo.bars to [] *) + (* let foo_1 = Table.find "foo:1" (TableSet.find "foo" (Database.tableset db)) in*) + let db = set_field "foo" "foo:1" "bars" (Schema.Value.Set []) db in + (* check that 'bar.foos' is empty *) + let bar_1 = Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in + let bar_foos = Row.find "foos" bar_1 in + if bar_foos <> (Schema.Value.Set []) + then failwith (Printf.sprintf "check_many_to_many: bar(bar:1).foos expected () got %s" (Sexplib.Sexp.to_string (Schema.Value.sexp_of_t bar_foos))); + (* add 'bar' to foo.bars *) + let db = set_field "foo" "foo:1" "bars" (Schema.Value.Set [ "bar:1" ]) db in + (* check that 'bar.foos' includes 'foo' *) + let bar_1 = Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in + let bar_foos = Row.find "foos" bar_1 in + if bar_foos <> (Schema.Value.Set [ "foo:1" ]) + then failwith (Printf.sprintf "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2" (Sexplib.Sexp.to_string (Schema.Value.sexp_of_t bar_foos))); + (* delete 'bar' *) + let db = remove_row "bar" "bar:1" db in + (* check that 'foo.bars' is empty *) + let foo_1 = Table.find "foo:1" (TableSet.find "foo" (Database.tableset db)) in + let foo_bars = Row.find "bars" foo_1 in + if foo_bars <> (Schema.Value.Set []) + then failwith (Printf.sprintf "check_many_to_many: foo(foo:1).foos expected () got %s" (Sexplib.Sexp.to_string (Schema.Value.sexp_of_t foo_bars))); + () + +open OUnit + +let _ = + let verbose = ref false in + Arg.parse [ + "-verbose", Arg.Unit (fun _ -> verbose := true), "Run in verbose mode"; + ] (fun x -> Printf.fprintf stderr "Ignoring argument: %s" x) + "Test database library"; + + let suite = "tar" >::: + [ + "many to many" >:: check_many_to_many; + ] in + run_test_tt ~verbose:!verbose suite From 54a36983189115b38205a94c7acf4ae17173fb87 Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 14 Nov 2014 17:42:26 +0000 Subject: [PATCH 21/21] Database: unit test now exits with non-zero on error (woo) Thanks to @johnelse for pointing this out. Signed-off-by: David Scott --- ocaml/database/db_cache_test.ml | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/ocaml/database/db_cache_test.ml b/ocaml/database/db_cache_test.ml index d7f0ae7d75a..96c9237e923 100644 --- a/ocaml/database/db_cache_test.ml +++ b/ocaml/database/db_cache_test.ml @@ -68,14 +68,8 @@ let check_many_to_many () = open OUnit let _ = - let verbose = ref false in - Arg.parse [ - "-verbose", Arg.Unit (fun _ -> verbose := true), "Run in verbose mode"; - ] (fun x -> Printf.fprintf stderr "Ignoring argument: %s" x) - "Test database library"; - - let suite = "tar" >::: + let suite = "db_cache" >::: [ "many to many" >:: check_many_to_many; ] in - run_test_tt ~verbose:!verbose suite + OUnit2.run_test_tt_main (OUnit.ounit2_of_ounit1 suite)