Merge master into feature/pool-licensing

.github/workflows/release.yml

@@ -20,13 +20,11 @@ jobs:
           python-version: "3.x"
 
       - name: Install build dependencies
-        run: |
-          pip install build
-          sudo apt-get install ocaml dune libfindlib-ocaml-dev libdune-ocaml-dev libcmdliner-ocaml-dev
+        run: pip install build
 
       - name: Generate python package for XenAPI
         run: |
-          ./configure --xapi_version=${{ github.ref_name }}
+          echo "export XAPI_VERSION=${{ github.ref_name }}" > config.mk
           make python
 
       - name: Store python distribution artifacts

doc/content/design/coverage/index.md

@@ -8,7 +8,7 @@ revision: 2
 
 We would like to add optional coverage profiling to existing [OCaml]
 projects in the context of [XenServer] and [XenAPI]. This article
-presents how we do it. 
+presents how we do it.
 
 Binaries instrumented for coverage profiling in the XenServer project
 need to run in an environment where several services act together as
@@ -21,7 +21,7 @@ isolation.
 To build binaries with coverage profiling, do:
 
     ./configure --enable-coverage
-    make 
+    make
 
 Binaries will log coverage data to `/tmp/bisect*.out` from which a
 coverage report can be generated in `coverage/`:
@@ -38,7 +38,7 @@ and logs during execution data to in-memory data structures. Before an
 instrumented binary terminates, it writes the logged data to a file.
 This data can then be analysed with the `bisect-ppx-report` tool, to
 produce a summary of annotated code that highlights what part of a
-codebase was executed. 
+codebase was executed.
 
 [BisectPPX] has several desirable properties:
 
@@ -65,13 +65,13 @@ abstracted by OCamlfind (OCaml's library manager) and OCamlbuild
 
     # build it with instrumentation from bisect_ppx
     ocamlbuild -use-ocamlfind -pkg bisect_ppx -pkg unix example.native
-    
+
     # execute it - generates files ./bisect*.out
     ./example.native
-    
+
     # generate report
     bisect-ppx-report -I _build -html coverage bisect000*
-    
+
     # view coverage/index.html
 
     Summary:
@@ -86,7 +86,7 @@ will be instrumented during compilation. Behind the scenes `ocamlfind`
 makes sure that the compiler uses a preprocessing step that instruments
 the code.
 
-## Signal Handling 
+## Signal Handling
 
 During execution the code instrumentation leads to the collection of
 data. This code registers a function with `at_exit` that writes the data
@@ -98,7 +98,7 @@ terminated by receiving the `TERM` signal, a signal handler must be
 installed:
 
     let stop signal =
-      printf "caught signal %d\n" signal;
+      printf "caught signal %a\n" Debug.Pp.signal signal;
       exit 0
 
     Sys.set_signal Sys.sigterm (Sys.Signal_handle stop)
@@ -149,8 +149,8 @@ environment variable. This can happen on the command line:
 
     BISECT_FILE=/tmp/example ./example.native
 
-In the context of XenServer we could do this in startup scripts. 
-However, we added a bit of code 
+In the context of XenServer we could do this in startup scripts.
+However, we added a bit of code
 
     val Coverage.init: string -> unit
 
@@ -176,12 +176,12 @@ Goals for instrumentation are:
 
 * what files are instrumented should be obvious and easy to manage
 * instrumentation must be optional, yet easy to activate
-* avoid methods that require to keep several files in sync like multiple 
+* avoid methods that require to keep several files in sync like multiple
   `_oasis` files
 * avoid separate Git branches for instrumented and non-instrumented
   code
 
-In the ideal case, we could introduce a configuration switch 
+In the ideal case, we could introduce a configuration switch
 `./configure --enable-coverage` that would prepare compilation for
 coverage instrumentation. While [Oasis] supports the creation of such
 switches, they cannot be used to control build dependencies like
@@ -196,7 +196,7 @@ rules in file `_tags.coverage` that cause files to be instrumented:
 
 leads to the execution of this code during preparation:
 
-    coverage: _tags _tags.coverage 
+    coverage: _tags _tags.coverage
       test ! -f _tags.orig && mv _tags _tags.orig || true
       cat _tags.coverage _tags.orig > _tags
 
@@ -207,7 +207,7 @@ could be tweaked to instrument only some files:
     <**/*.native>:   pkg_bisect_ppx
 
 When `make coverage` is not called, these rules are not active and
-hence, code is not instrumented for coverage. We believe that this 
+hence, code is not instrumented for coverage. We believe that this
 solution to control instrumentation meets the goals from above. In
 particular, what files are instrumented and when is controlled by very
 few lines of declarative code that lives in the main repository of a
@@ -226,14 +226,14 @@ coverage analysis are:
 The `_oasis` file bundles the files under `profiling/` into an internal
 library which executables then depend on:
 
-		# Support files for profiling 
+		# Support files for profiling
 		Library profiling
 			CompiledObject:     best
 			Path:               profiling
 			Install:            false
 			Findlibname:        profiling
 			Modules:            Coverage
-			BuildDepends: 
+			BuildDepends:
 
 		Executable set_domain_uuid
 			CompiledObject:     best
@@ -243,16 +243,16 @@ library which executables then depend on:
 			MainIs:             set_domain_uuid.ml
 			Install:            false
 			BuildDepends:
-				xenctrl, 
-				uuidm, 
+				xenctrl,
+				uuidm,
 				cmdliner,
 				profiling			# <-- here
 
 The `Makefile` target `coverage` primes the project for a profiling build:
 
 		# make coverage - prepares for building with coverage analysis
 
-		coverage: _tags _tags.coverage 
+		coverage: _tags _tags.coverage
 			test ! -f _tags.orig && mv _tags _tags.orig || true
 			cat _tags.coverage _tags.orig > _tags
 

ocaml/database/database_test.ml

@@ -16,6 +16,8 @@ let name_label = "name__label"
 
 let name_description = "name__description"
 
+let failwith_fmt fmt = Printf.ksprintf failwith fmt
+
 module Tests =
 functor
   (Client : Db_interface.DB_ACCESS)
@@ -111,7 +113,7 @@ functor
               ; where_value= ""
               }
           in
-          failwith (Printf.sprintf "%s <invalid table>" fn_name)
+          failwith_fmt "%s <invalid table>" fn_name
       ) ;
       Printf.printf
         "%s <valid table> <invalid return> <valid field> <valid value>\n"
@@ -126,11 +128,9 @@ functor
               ; where_value= name
               }
           in
-          failwith
-            (Printf.sprintf
-               "%s <valid table> <invalid return> <valid field> <valid value>"
-               fn_name
-            )
+          failwith_fmt
+            "%s <valid table> <invalid return> <valid field> <valid value>"
+            fn_name
       ) ;
       Printf.printf
         "%s <valid table> <valid return> <invalid field> <valid value>\n"
@@ -145,11 +145,9 @@ functor
               ; where_value= ""
               }
           in
-          failwith
-            (Printf.sprintf
-               "%s <valid table> <valid return> <invalid field> <valid value>"
-               fn_name
-            )
+          failwith_fmt
+            "%s <valid table> <valid return> <invalid field> <valid value>"
+            fn_name
       )
 
     (* Verify the ref_index contents are correct for a given [tblname] and [key] (uuid/ref) *)
@@ -168,10 +166,9 @@ functor
       | Some {Ref_index.name_label= name_label'; uuid; _ref} ->
           (* key should be either uuid or _ref *)
           if key <> uuid && key <> _ref then
-            failwith
-              (Printf.sprintf "check_ref_index %s key %s: got ref %s uuid %s"
-                 tblname key _ref uuid
-              ) ;
+            failwith_fmt "check_ref_index %s key %s: got ref %s uuid %s" tblname
+              key _ref uuid ;
+
           let real_ref =
             if Client.is_valid_ref t key then
               key
@@ -183,14 +180,11 @@ functor
             with _ -> None
           in
           if name_label' <> real_name_label then
-            failwith
-              (Printf.sprintf
-                 "check_ref_index %s key %s: ref_index name_label = %s; db has \
-                  %s"
-                 tblname key
-                 (Option.value ~default:"None" name_label')
-                 (Option.value ~default:"None" real_name_label)
-              )
+            failwith_fmt
+              "check_ref_index %s key %s: ref_index name_label = %s; db has %s"
+              tblname key
+              (Option.value ~default:"None" name_label')
+              (Option.value ~default:"None" real_name_label)
 
     open Db_cache_types
 
@@ -226,11 +220,9 @@ functor
       in
       let bar_foos = Row.find "foos" bar_1 in
       if bar_foos <> Set ["foo:1"] then
-        failwith
-          (Printf.sprintf
-             "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s"
-             (Schema.Value.marshal bar_foos)
-          ) ;
+        failwith_fmt
+          "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s"
+          (Schema.Value.marshal 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" (Set []) db in
@@ -240,11 +232,8 @@ functor
       in
       let bar_foos = Row.find "foos" bar_1 in
       if bar_foos <> Set [] then
-        failwith
-          (Printf.sprintf
-             "check_many_to_many: bar(bar:1).foos expected () got %s"
-             (Schema.Value.marshal bar_foos)
-          ) ;
+        failwith_fmt "check_many_to_many: bar(bar:1).foos expected () got %s"
+          (Schema.Value.marshal bar_foos) ;
       (* add 'bar' to foo.bars *)
       let db = set_field "foo" "foo:1" "bars" (Set ["bar:1"]) db in
       (* check that 'bar.foos' includes 'foo' *)
@@ -253,11 +242,9 @@ functor
       in
       let bar_foos = Row.find "foos" bar_1 in
       if bar_foos <> Set ["foo:1"] then
-        failwith
-          (Printf.sprintf
-             "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2"
-             (Schema.Value.marshal bar_foos)
-          ) ;
+        failwith_fmt
+          "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2"
+          (Schema.Value.marshal bar_foos) ;
       (* delete 'bar' *)
       let db = remove_row "bar" "bar:1" db in
       (* check that 'foo.bars' is empty *)
@@ -266,11 +253,8 @@ functor
       in
       let foo_bars = Row.find "bars" foo_1 in
       if foo_bars <> Set [] then
-        failwith
-          (Printf.sprintf
-             "check_many_to_many: foo(foo:1).foos expected () got %s"
-             (Schema.Value.marshal foo_bars)
-          ) ;
+        failwith_fmt "check_many_to_many: foo(foo:1).foos expected () got %s"
+          (Schema.Value.marshal foo_bars) ;
       ()
 
     let check_events t =
@@ -503,8 +487,7 @@ functor
       | None ->
           Printf.printf "Reference '%s' has no associated table\n" invalid_ref
       | Some t ->
-          failwith
-            (Printf.sprintf "Reference '%s' exists in table '%s'" invalid_ref t)
+          failwith_fmt "Reference '%s' exists in table '%s'" invalid_ref t
       ) ;
       Printf.printf "is_valid_ref <invalid_ref>\n" ;
       if Client.is_valid_ref t invalid_ref then
@@ -571,15 +554,25 @@ functor
       Printf.printf "db_get_by_uuid <valid uuid>\n" ;
       let r = Client.db_get_by_uuid t "VM" valid_uuid in
       if r <> valid_ref then
-        failwith
-          (Printf.sprintf "db_get_by_uuid <valid uuid>: got %s; expected %s" r
-             valid_ref
-          ) ;
+        failwith_fmt "db_get_by_uuid <valid uuid>: got %s; expected %s" r
+          valid_ref ;
       Printf.printf "db_get_by_uuid <invalid uuid>\n" ;
       expect_missing_uuid "VM" invalid_uuid (fun () ->
           let (_ : string) = Client.db_get_by_uuid t "VM" invalid_uuid in
           failwith "db_get_by_uuid <invalid uuid>"
       ) ;
+      Printf.printf "db_get_by_uuid_opt <valid uuid>\n" ;
+      let r = Client.db_get_by_uuid_opt t "VM" valid_uuid in
+      ( if r <> Some valid_ref then
+          let rs = Option.value ~default:"None" r in
+          failwith_fmt "db_get_by_uuid_opt <valid uuid>: got %s; expected %s" rs
+            valid_ref
+      ) ;
+      Printf.printf "db_get_by_uuid_opt <invalid uuid>\n" ;
+      let r = Client.db_get_by_uuid_opt t "VM" invalid_uuid in
+      if not (Option.is_none r) then
+        failwith_fmt "db_get_by_uuid_opt <invalid uuid>: got %s; expected None"
+          valid_ref ;
       Printf.printf "get_by_name_label <invalid name label>\n" ;
       if Client.db_get_by_name_label t "VM" invalid_name <> [] then
         failwith "db_get_by_name_label <invalid name label>" ;

ocaml/database/db_remote_cache_access_v1.ml

@@ -102,6 +102,12 @@ module DBCacheRemoteListener = struct
           let s, e = unmarshall_db_get_by_uuid_args args in
           success
             (marshall_db_get_by_uuid_response (DBCache.db_get_by_uuid t s e))
+      | "db_get_by_uuid_opt" ->
+          let s, e = unmarshall_db_get_by_uuid_args args in
+          success
+            (marshall_db_get_by_uuid_opt_response
+               (DBCache.db_get_by_uuid_opt t s e)
+            )
       | "db_get_by_name_label" ->
           let s, e = unmarshall_db_get_by_name_label_args args in
           success

ocaml/database/db_remote_cache_access_v2.ml

@@ -36,6 +36,8 @@ let process_rpc (req : Rpc.t) =
             Response.Read_field_where (DB.read_field_where t w)
         | Request.Db_get_by_uuid (a, b) ->
             Response.Db_get_by_uuid (DB.db_get_by_uuid t a b)
+        | Request.Db_get_by_uuid_opt (a, b) ->
+            Response.Db_get_by_uuid_opt (DB.db_get_by_uuid_opt t a b)
         | Request.Db_get_by_name_label (a, b) ->
             Response.Db_get_by_name_label (DB.db_get_by_name_label t a b)
         | Request.Create_row (a, b, c) ->

ocaml/database/db_rpc_client_v2.ml

@@ -78,7 +78,7 @@ functor
           raise Remote_db_server_returned_bad_message
 
     let db_get_by_uuid_opt _ t u =
-      match process (Request.Db_get_by_uuid (t, u)) with
+      match process (Request.Db_get_by_uuid_opt (t, u)) with
       | Response.Db_get_by_uuid_opt y ->
           y
       | _ ->

ocaml/database/db_rpc_common_v1.ml

@@ -192,6 +192,8 @@ let unmarshall_db_get_by_uuid_args xml = unmarshall_2strings xml
 
 let marshall_db_get_by_uuid_response s = XMLRPC.To.string s
 
+let marshall_db_get_by_uuid_opt_response = marshall_stringopt
+
 let unmarshall_db_get_by_uuid_response xml = XMLRPC.From.string xml
 
 let unmarshall_db_get_by_uuid_opt_response xml = unmarshall_stringopt xml

ocaml/database/db_rpc_common_v2.ml

@@ -23,6 +23,7 @@ module Request = struct
     | Find_refs_with_filter of string * Db_filter_types.expr
     | Read_field_where of Db_cache_types.where_record
     | Db_get_by_uuid of string * string
+    | Db_get_by_uuid_opt of string * string
     | Db_get_by_name_label of string * string
     | Create_row of string * (string * string) list * string
     | Delete_row of string * string