Merge pull request #5824 from BengangY/private/bengangy/merge-master-…

…to-non-cdn-update

Merge master to feature/non-cdn-update

.gitignore

@@ -2,6 +2,7 @@ _build/
 *.bak
 *.native
 .merlin
+_coverage/
 *.install
 *.swp
 compile_flags.txt

Makefile

@@ -6,7 +6,7 @@ JOBS = $(shell getconf _NPROCESSORS_ONLN)
 PROFILE=release
 OPTMANDIR ?= $(OPTDIR)/man/man1/
 
-.PHONY: build clean test doc python format install uninstall
+.PHONY: build clean test doc python format install uninstall coverage
 
 # if we have XAPI_VERSION set then set it in dune-project so we use that version number instead of the one obtained from git
 # this is typically used when we're not building from a git repo
@@ -20,6 +20,11 @@ build:
 check:
 	dune build @check -j $(JOBS)
 
+coverage:
+	dune runtest --instrument-with bisect_ppx --force --profile=$(RELEASE) -j $(JOBS)
+	bisect-ppx-report html
+	bisect-ppx-report summary --per-file
+
 clean:
 	dune clean
 
@@ -57,6 +62,7 @@ TEST_TIMEOUT=600
 TEST_TIMEOUT2=1200
 test:
 	ulimit -S -t $(TEST_TIMEOUT); \
+	ulimit -n 2048; \
 	 (sleep $(TEST_TIMEOUT) && ps -ewwlyF --forest)& \
 	 PSTREE_SLEEP_PID=$$!; \
 	 trap "kill $${PSTREE_SLEEP_PID}" INT TERM EXIT; \
@@ -206,6 +212,7 @@ install: build doc sdk doc-json
 	install -D -m 755 _build/install/default/bin/xcp-rrdd-iostat $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-iostat
 	install -D -m 755 _build/install/default/bin/xcp-rrdd-squeezed $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-squeezed
 	install -D -m 755 _build/install/default/bin/xcp-rrdd-xenpm $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-xenpm
+	install -D -m 755 _build/install/default/bin/xcp-rrdd-dcmi $(DESTDIR)$(LIBEXECDIR)/xcp-rrdd-plugins/xcp-rrdd-dcmi
 	install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins.xml
 	install -D -m 644 ocaml/xcp-rrdd/bugtool-plugin/rrdd-plugins/stuff.xml $(DESTDIR)$(ETCXENDIR)/bugtool/xcp-rrdd-plugins/stuff.xml
 	install -D -m 755 ocaml/xcp-rrdd/bin/rrdp-scripts/sysconfig-rrdd-plugins $(DESTDIR)/etc/sysconfig/xcp-rrdd-plugins

dune-project

@@ -2,6 +2,8 @@
 (formatting (enabled_for ocaml))
 (using menhir 2.0)
 
+(cram enable)
+(implicit_transitive_deps false)
 (generate_opam_files true)
 
 (name "xapi")
@@ -559,6 +561,8 @@ This package provides an Lwt compatible interface to the library.")
     base-unix
     (odoc :with-doc)
     (xapi-stdext-pervasives (= :version))
+    (mtime :with-test)
+    (xapi-stdext-unix (= :version))
   )
 )
 
@@ -568,12 +572,19 @@ This package provides an Lwt compatible interface to the library.")
   (authors "Jonathan Ludlam")
   (depends
     (ocaml (>= 4.12.0))
+    (alcotest :with-test)
     base-unix
+    (bisect_ppx :with-test)
     (fd-send-recv (>= 2.0.0))
+    fmt
+    (mtime (and (>= 2.0.0) :with-test))
+    (logs :with-test)
+    (qcheck-core (and (>= 0.21.2) :with-test))
     (odoc :with-doc)
     xapi-backtrace
     unix-errno
     (xapi-stdext-pervasives (= :version))
+    polly
   )
 )
 

ocaml/database/dune

@@ -41,6 +41,7 @@
     xapi-datamodel
     xapi-log
     (re_export xapi-schema)
+    xapi-idl.updates
     xapi-stdext-encodings
     xapi-stdext-pervasives
     xapi-stdext-std

ocaml/database/master_connection.ml

@@ -271,7 +271,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) :
           !Db_globs.permanent_master_failure_retry_interval ;
         Thread.delay !Db_globs.permanent_master_failure_retry_interval ;
         !Db_globs.restart_fn ()
-    | e -> (
+    | e ->
         error "Caught %s" (Printexc.to_string e) ;
         (* RPC failed - there's no way we can recover from this so try reopening connection every 2s + backoff delay *)
         ( match !my_connection with
@@ -322,9 +322,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) :
           debug "%s: Sleep interrupted, retrying master connection now"
             __FUNCTION__ ;
         update_backoff_delay () ;
-        try open_secure_connection () with _ -> ()
-        (* oh well, maybe nextime... *)
-      )
+        D.log_and_ignore_exn open_secure_connection
   done ;
   !result
 

ocaml/database/redo_log.ml

@@ -642,7 +642,8 @@ let startup log =
           ) ;
           match !(log.device) with
           | None ->
-              D.info "Could not find block device"
+              D.info "Could not find block device" ;
+              broken log
           | Some device ->
               D.info "Using block device at %s" device ;
               (* Check that the block device exists *)

ocaml/forkexecd/lib/dune

@@ -7,6 +7,7 @@
    fd-send-recv
    rpclib.core
    rpclib.json
+   rpclib.xml
    uuid
    xapi-backtrace
    xapi-log

ocaml/forkexecd/test/dune

@@ -1,7 +1,7 @@
 (executable
  (modes exe)
  (name fe_test)
- (libraries forkexec uuid xapi-stdext-unix))
+ (libraries forkexec uuid xapi-stdext-unix fd-send-recv))
 
 (rule
  (alias runtest)

ocaml/idl/datamodel_certificate.ml

@@ -69,10 +69,10 @@ let t =
             [(Published, rel_stockholm, ""); (Deprecated, "24.19.0", "")]
           ~ty:String "fingerprint" ~default_value:(Some (VString ""))
           "Use fingerprint_sha256 instead"
-      ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha256"
+      ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha256"
           ~default_value:(Some (VString ""))
           "The certificate's SHA256 fingerprint / hash"
-      ; field ~qualifier:StaticRO ~lifecycle ~ty:String "fingerprint_sha1"
+      ; field ~qualifier:StaticRO ~lifecycle:[] ~ty:String "fingerprint_sha1"
           ~default_value:(Some (VString ""))
           "The certificate's SHA1 fingerprint / hash"
       ]

ocaml/idl/datamodel_cluster.ml

@@ -169,6 +169,16 @@ let pool_resync =
     ~params:[(Ref _cluster, "self", "The cluster to resync")]
     ~lifecycle ~allowed_roles:_R_POOL_OP ~errs:[] ()
 
+let cstack_sync =
+  call ~name:"cstack_sync"
+    ~doc:
+      "Sync xapi db with the cluster stack synchronously, and generate alerts \
+       as needed. Only happens on the coordinator as this is where the cluster \
+       watcher performs updates."
+    ~params:[(Ref _cluster, "self", "The cluster to sync")]
+    ~hide_from_docs:true ~pool_internal:true ~lifecycle
+    ~allowed_roles:_R_POOL_OP ~errs:[] ()
+
 let t =
   create_obj ~name:_cluster ~descr:"Cluster-wide Cluster metadata"
     ~doccomments:[] ~gen_constructor_destructor:false ~gen_events:true
@@ -245,5 +255,6 @@ let t =
       ; pool_force_destroy
       ; pool_destroy
       ; pool_resync
+      ; cstack_sync
       ]
     ()

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 779
+let schema_minor_vsn = 780
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_lifecycle.ml

@@ -1,6 +1,6 @@
 let prototyped_of_class = function
   | "VM_group" ->
-      Some "24.18.0-next"
+      Some "24.19.1"
   | "Observer" ->
       Some "23.14.0"
   | "VTPM" ->
@@ -10,9 +10,9 @@ let prototyped_of_class = function
 
 let prototyped_of_field = function
   | "VM_group", "VMs" ->
-      Some "24.18.0-next"
+      Some "24.19.1"
   | "VM_group", "placement" ->
-      Some "24.18.0-next"
+      Some "24.19.1"
   | "Observer", "enabled" ->
       Some "23.14.0"
   | "Observer", "components" ->
@@ -27,6 +27,10 @@ let prototyped_of_field = function
       Some "23.14.0"
   | "Repository", "gpgkey_path" ->
       Some "22.12.0"
+  | "Certificate", "fingerprint_sha1" ->
+      Some "24.19.1-next"
+  | "Certificate", "fingerprint_sha256" ->
+      Some "24.19.1-next"
   | "Cluster_host", "last_update_live" ->
       Some "24.3.0"
   | "Cluster_host", "live" ->
@@ -62,7 +66,7 @@ let prototyped_of_field = function
   | "host", "last_software_update" ->
       Some "22.20.0"
   | "VM", "groups" ->
-      Some "24.18.0-next"
+      Some "24.19.1"
   | "VM", "pending_guidances_full" ->
       Some "24.10.0"
   | "VM", "pending_guidances_recommended" ->
@@ -72,7 +76,7 @@ let prototyped_of_field = function
   | "VM", "actions__after_softreboot" ->
       Some "23.1.0"
   | "pool", "recommendations" ->
-      Some "24.18.0-next"
+      Some "24.19.1"
   | "pool", "update_sync_enabled" ->
       Some "23.18.0"
   | "pool", "update_sync_day" ->
@@ -150,7 +154,7 @@ let prototyped_of_message = function
   | "VM", "restart_device_models" ->
       Some "23.30.0"
   | "VM", "set_groups" ->
-      Some "24.18.0-next"
+      Some "24.19.1"
   | "pool", "get_guest_secureboot_readiness" ->
       Some "24.17.0"
   | "pool", "set_ext_auth_max_threads" ->

ocaml/idl/ocaml_backend/gen_api.ml

@@ -112,6 +112,19 @@ let gen_non_record_type tys =
           t
     | ty :: t ->
         let alias = OU.alias_of_ty ty in
+        let accu =
+          match ty with
+          | DT.Enum (name, cs) ->
+              sprintf "let all_%s = [%s]" name
+                (cs
+                |> List.map fst
+                |> List.map OU.constructor_of
+                |> String.concat "; "
+                )
+              :: accu
+          | _ ->
+              accu
+        in
         if List.mem_assoc alias overrides then
           aux
             (sprintf "type %s = %s\n%s\n" alias (OU.ocaml_of_ty ty)

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "efdb1c7e536362523741ccdb7f33f797"
+let last_known_schema_hash = "7885f7b085e4a5e32977a4b222030412"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/libs/clock/dune

@@ -16,5 +16,5 @@
   (names test_date test_timer)
   (package clock)
   (modules test_date test_timer)
-  (libraries alcotest clock fmt mtime ptime qcheck-core qcheck-core.runner)
+  (libraries alcotest clock fmt mtime mtime.clock.os ptime qcheck-core qcheck-core.runner)
 )

ocaml/libs/ezxenstore/core/dune

@@ -6,6 +6,8 @@
     logs
     threads
     uuidm
-    xenstore_transport
-    xenstore.unix)
+    (re_export xenstore)
+    (re_export xenstore_transport)
+    threads.posix
+    (re_export xenstore.unix))
 )

ocaml/libs/ezxenstore/lib/dune

@@ -3,7 +3,7 @@
   (public_name ezxenstore)
   (wrapped false)
   (libraries
-    ezxenstore_core
-    ezxenstore_watch
+    (re_export ezxenstore_core)
+    (re_export ezxenstore_watch)
   )
 )

ocaml/libs/ezxenstore/lib_test/dune

@@ -2,5 +2,5 @@
   (name main)
   (package ezxenstore)
   (deps main.exe)
-  (libraries cmdliner ezxenstore xenstore_transport)
+  (libraries cmdliner ezxenstore xenstore_transport xenstore xenstore.unix)
 )

ocaml/libs/ezxenstore/watch/dune

@@ -4,5 +4,8 @@
   (wrapped false)
   (libraries
     ezxenstore_core
-    xenctrl)
+    xenctrl
+    uuidm
+    threads.posix
+   )
 )

ocaml/libs/http-lib/bufio_test.ml

@@ -0,0 +1,81 @@
+open QCheck2
+open Xapi_fd_test
+
+let print_timeout = string_of_float
+
+let expect_string ~expected ~actual =
+  if not (String.equal expected actual) then
+    Test.fail_reportf "Data sent and observed do not match: %S <> %S" expected
+      actual
+
+let expect_amount ~expected observation =
+  let open Observations in
+  let actual = String.length observation.data in
+  if expected <> actual then
+    Test.fail_reportf
+      "Amount of data available and transferred does not match: %d <> %d;@,%a"
+      expected actual pp observation
+
+let test_buf_io =
+  let timeouts = Generate.timeouts in
+  let gen = Gen.tup2 Generate.t timeouts
+  and print = Print.tup2 Generate.print print_timeout in
+  Test.make ~name:__FUNCTION__ ~print gen @@ fun (behaviour, timeout) ->
+  let timeout_span = Mtime.Span.of_float_ns (timeout *. 1e9) |> Option.get in
+  (* Format.eprintf "Testing %s@." (print (behaviour, timeout)); *)
+  if behaviour.kind <> Unix.S_SOCK then
+    QCheck2.assume_fail () ;
+  (* we only support sockets for this function *)
+  let test_elapsed = ref Mtime.Span.zero in
+  let test wrapped_fd =
+    let fd = Xapi_fdcaps.Operations.For_test.unsafe_fd_exn wrapped_fd in
+    let bio = Buf_io.of_fd fd in
+    let dt = Mtime_clock.counter () in
+    let finally () = test_elapsed := Mtime_clock.count dt in
+    Fun.protect ~finally (fun () ->
+        Buf_io.really_input_buf bio behaviour.size ~timeout
+    )
+  in
+  (*Printf.eprintf "testing: %s\n%!" (print (behaviour, timeout)) ;*)
+  let observations, result =
+    let buf = String.init behaviour.size (fun i -> Char.chr (i mod 255)) in
+    Generate.run_ro behaviour buf ~f:test
+  in
+  let () =
+    let open Observations in
+    let elapsed = !test_elapsed in
+    let timeout_extra =
+      Mtime.Span.(add (timeout_span :> Mtime.Span.t) @@ (500 * ms))
+    in
+    if Mtime.Span.compare elapsed timeout_extra > 0 then
+      Test.fail_reportf
+        "Function duration significantly exceeds timeout: %a > %.6f; %s"
+        Mtime.Span.pp elapsed timeout
+        (Fmt.to_to_string Fmt.(option pp) observations.Observations.write) ;
+    (* Format.eprintf "Result: %a@." (Fmt.option Observations.pp) observations.write;*)
+    match (observations, result) with
+    | {write= Some write; _}, Ok actual ->
+        expect_amount ~expected:(String.length actual) write ;
+        expect_string ~expected:write.data ~actual
+    | {write= Some _; _}, Error (`Exn_trap (Buf_io.Timeout, _)) ->
+        let elapsed = !test_elapsed in
+        if Mtime.Span.compare elapsed timeout_span < 0 then
+          Test.fail_reportf "Timed out earlier than requested: %a < %a"
+            Mtime.Span.pp elapsed Mtime.Span.pp timeout_span
+    | ( {write= Some write; _}
+      , Error (`Exn_trap (Unix.Unix_error (Unix.EPIPE, _, _), _)) ) ->
+        if String.length write.data = behaviour.size then
+          Test.fail_reportf
+            "Transferred exact amount, shouldn't have tried to send more: %d"
+            behaviour.size
+    | {write= None; _}, _ ->
+        ()
+    | _, Error (`Exn_trap (e, bt)) ->
+        Printexc.raise_with_backtrace e bt
+  in
+  true
+
+let () =
+  (* avoid SIGPIPE *)
+  let (_ : Sys.signal_behavior) = Sys.signal Sys.sigpipe Sys.Signal_ignore in
+  QCheck_base_runner.run_tests_main [test_buf_io]