Merge feature/perf to master

.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")
@@ -518,6 +520,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))
   )
 )
 
@@ -527,12 +531,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/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/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]

ocaml/libs/http-lib/dune

@@ -3,11 +3,12 @@
   (public_name http-lib)
   (modes best)
   (wrapped false)
-  (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server))
+  (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server bufio_test))
   (preprocess (per_module ((pps ppx_deriving_rpc) Http)))
   (libraries
     astring
     base64
+    fmt
     ipaddr
     mtime
     mtime.clock.os
@@ -19,6 +20,7 @@
     stunnel
     threads.posix
     uuid
+    uri
     xapi-backtrace
     xapi-consts.xapi_version
     xapi-idl.updates
@@ -40,8 +42,10 @@
   (libraries
     astring
     http_lib
+    ipaddr
     polly
     threads.posix
+    uri
     xapi-log
     xapi-stdext-pervasives
     xapi-stdext-threads
@@ -57,10 +61,37 @@
   (libraries
     alcotest
     dune-build-info
+    fmt
     http_lib
   )
 )
 
+(test
+  (name bufio_test)
+  (package http-lib)
+  (modes (best exe))
+  (modules bufio_test)
+  (libraries
+    fmt
+    mtime
+    mtime.clock
+    mtime.clock.os
+    rresult
+    http_lib
+    qcheck-core
+    qcheck-core.runner
+    xapi_fd_test
+  )
+  ; use fixed seed to avoid causing random failures in CI and package builds
+  (action (run %{test} -v -bt --seed 42))
+)
+
+(rule
+  (alias stresstest)
+  ; use default random seed on stresstests
+  (action (run %{dep:bufio_test.exe} -v -bt))
+)
+
 (executable
   (modes exe)
   (name test_client)

ocaml/libs/sexpr/test/dune

@@ -2,4 +2,4 @@
  (name test_sexpr)
  (package sexpr)
  (modules test_sexpr)
- (libraries sexpr astring rresult qcheck-core alcotest threads))
+ (libraries sexpr astring rresult qcheck-core alcotest threads.posix))

ocaml/libs/stunnel/stunnel.ml

@@ -391,7 +391,7 @@ let rec retry f = function
     try f ()
     with Stunnel_initialisation_failed ->
       (* Leave a few seconds between each attempt *)
-      ignore (Unix.select [] [] [] 3.) ;
+      Thread.delay 3. ;
       retry f (n - 1)
   )
 

ocaml/libs/tracing/dune

@@ -1,7 +1,7 @@
 (library
  (name tracing)
  (modules tracing)
- (libraries re uri xapi-log xapi-stdext-threads)
+ (libraries re uri xapi-log xapi-stdext-threads threads.posix)
  (public_name xapi-tracing))
 
 (library
@@ -15,7 +15,10 @@
   ptime.clock.os
   rpclib.core
   rpclib.json
+  result
+  rresult
   tracing
+  threads.posix
   uri
   xapi-log
   xapi-open-uri
@@ -29,4 +32,4 @@
  (name test_tracing)
  (modules test_tracing)
  (package xapi-tracing)
- (libraries tracing alcotest uuid))
+ (libraries tracing alcotest fmt uuid xapi-log))