CA-134765: Fix race condition in database layer

ocaml/database/db_cache_impl.ml

@@ -32,6 +32,8 @@ module W = Debug.Make(struct let name = "db_write" end)
 open Db_cache_types
 open Db_ref
 
+let fist_delay_read_records_where = ref false
+
 (* Only needed by the DB_ACCESS signature *)
 let initialise () = ()
 
@@ -122,8 +124,7 @@ let read_set_ref t rcd =
    and iterates through set-refs [returning (fieldname, ref list) list; where fieldname is the
    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 t tblname objref  =
-	let db = get_database t in
+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
@@ -142,6 +143,7 @@ let read_record t tblname objref  =
 	let set_ref = List.map (fun (k, v) -> 
 		k, String_unmarshall_helper.set (fun x -> x) v) set_ref in
 	(fvlist, set_ref)
+let read_record t = read_record_internal (get_database t)
 
 (* Delete row from tbl *)
 let delete_row_locked t tblname objref =
@@ -210,8 +212,7 @@ let read_refs t tblname =
 	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 t (tblname: string) (expr: Db_filter_types.expr) = 
-	let db = get_database t in
+let find_refs_with_filter_internal db (tblname: string) (expr: Db_filter_types.expr) =
 	let tbl = TableSet.find tblname (Database.tableset db) in
 	let eval_val row = function
 		| Db_filter_types.Literal x -> x
@@ -221,10 +222,13 @@ let find_refs_with_filter t (tblname: string) (expr: Db_filter_types.expr) =
 			if Db_filter.eval_expr (eval_val row) expr
 			then Row.find Db_names.ref row :: acc else acc
 		) tbl []
+let find_refs_with_filter t = find_refs_with_filter_internal (get_database t)
 
 let read_records_where t tbl expr =
-	let reqd_refs = find_refs_with_filter t tbl expr in
-	List.map (fun ref->ref, read_record t tbl ref) reqd_refs
+	let db = get_database t in
+	let reqd_refs = find_refs_with_filter_internal db tbl expr in
+	if !fist_delay_read_records_where then Thread.delay 0.5;
+	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 =
 

ocaml/database/db_cache_impl.mli

@@ -15,3 +15,6 @@ 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
+
+(** Used for Test_db_lowlevel *)
+val fist_delay_read_records_where : bool ref

ocaml/test/OMakefile

@@ -30,6 +30,7 @@ OCAML_OBJS = \
 	test_common \
 	test_basic \
 	test_helpers \
+	test_db_lowlevel \
 	test_pool_db_backup \
 	test_xapi_db_upgrade \
 	test_ca91480 \

ocaml/test/suite.ml

@@ -21,6 +21,7 @@ let base_suite =
 		[
 			Test_basic.test;
 			Test_helpers.test;
+			Test_db_lowlevel.test;
 			Test_pool_db_backup.test;
 			Test_xapi_db_upgrade.test;
 			Test_ca91480.test;

ocaml/test/test_db_lowlevel.ml

@@ -0,0 +1,48 @@
+(*
+ * Copyright (C) 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 OUnit
+open Test_common
+
+(* If we delete a record after making a Db.get_all_records call, but before the
+ * call returns, then Db.get_all_records should return successfully (not throw
+ * an Db_exn.DBCache_NotFound("missing row",...) exception, and the return
+ * value should include the deleted record. *)
+let test_db_get_all_records_race () =
+	let __context = make_test_database () in
+	let  (vm_ref: API.ref_VM) = make_vm ~__context () in
+
+	Db_cache_impl.fist_delay_read_records_where := true;
+
+	(* Kick off the thread which will destroy a VM. *)
+	let destroyer_thread =
+		Thread.create (fun self -> Db.VM.destroy ~__context ~self) vm_ref
+	in
+
+	(* Call get_all_records *)
+	let _ =
+		try Db.VM.get_all_records ~__context
+		with Db_exn.DBCache_NotFound("missing row", _, _) ->
+			assert_failure "Race condition present"
+	in
+	Thread.join destroyer_thread
+
+let tear_down () =
+	Db_cache_impl.fist_delay_read_records_where := false
+
+let test =
+	"test_db_lowlevel" >:::
+		[
+			"test_db_get_all_records_race" >:: (bracket id test_db_get_all_records_race tear_down);
+		]