Merge master to Go SDK feature branch

dune-project

@@ -22,10 +22,6 @@
   (name xml-light2)
 )
 
-(package
-  (name xen-api-sdk)
-)
-
 (package
   (name xen-api-client-lwt)
 )
@@ -65,10 +61,37 @@
 
 (package
   (name xapi-tracing)
+  (depends
+   ocaml
+   dune
+   (alcotest :with-test)
+   re
+   uri
+   (uuid :with-test)
+   (xapi-log :version)
+   (xapi-stdext-threads :version)
+  )
+  (synopsis "Allows to instrument code to generate tracing information")
+  (description "This library provides modules to allow gathering runtime traces.")
 )
 
 (package
   (name xapi-tracing-export)
+  (depends
+   ocaml
+   cohttp-posix
+   dune
+   cohttp
+   rpclib
+   (xapi-log :version)
+   (xapi-open-uri :version)
+   (xapi-stdext-threads :version)
+   (xapi-stdext-unix :version)
+   (xapi-tracing :version)
+   (zstd :version)
+  )
+  (synopsis "Export traces in multiple protocols and formats")
+  (description "This library export traces is able to push traces to http endpoints or generate compressed tarballs in the filesystem.")
 )
 
 (package
@@ -93,18 +116,56 @@
 
 (package
   (name rrdd-plugin)
+  (synopsis "A plugin library for the xapi performance monitoring daemon")
+  (description "This library allows one to expose a datasource which can then be sampled by the performance monitoring daemon.")
+  (depends
+   ocaml
+   astring
+   rpclib
+   (xapi-forkexecd :version)
+   (xapi-stdext-pervasives :version)
+   (xapi-stdext-std :version)
+   (xapi-stdext-threads :version)
+   (xapi-stdext-unix :version)
+   (xapi-idl :version)
+   xenstore_transport
+  )
 )
 
 (package
   (name xapi-rrdd)
+  (synopsis "Performance monitoring daemon for xapi")
+  (description "This daemon monitors 'datasources' i.e. time-varying values such as performance counters and records the samples in RRD archives. These archives can be used to examine historical performance trends.")
+  (depends
+   (ocaml (>= "4.02.0"))
+   dune-build-info
+   astring
+   (gzip :version)
+   (http-lib :version)
+   inotify
+   io-page
+   mtime
+   ppx_deriving_rpc
+   rpclib
+   systemd
+   (ezxenstore :version)
+   (uuid :version)
+   (xapi-backtrace :version)
+   (xapi-idl :version)
+   (xapi-rrd :version)
+   (xapi-stdext-threads :version)
+  )
 )
 
 (package
   (name xapi-rrd-transport-utils)
-)
-
-(package
-  (name xapi-rrd-transport)
+  (synopsis "Shared-memory protocols for exposing performance counters")
+  (description "VMs running on a Xen host can use this library to expose performance counters which can be sampled by the xapi performance monitoring daemon.")
+  (authors "John Else")
+  (depends
+   ocaml
+   cmdliner
+  )
 )
 
 (package

ocaml/forkexecd/lib/forkhelpers.ml

@@ -196,9 +196,13 @@ let safe_close_and_exec ?tracing ?env stdin stdout stderr
   let fds_to_close = ref [] in
 
   let add_fd_to_close_list fd = fds_to_close := fd :: !fds_to_close in
-  (* let remove_fd_from_close_list fd = fds_to_close := List.filter (fun fd' -> fd' <> fd) !fds_to_close in *)
+  let remove_fd_from_close_list fd =
+    fds_to_close := List.filter (fun fd' -> fd' <> fd) !fds_to_close
+  in
   let close_fds () = List.iter (fun fd -> Unix.close fd) !fds_to_close in
 
+  add_fd_to_close_list sock ;
+
   finally
     (fun () ->
       let maybe_add_id_to_fd_map id_to_fd_map (uuid, fd, v) =
@@ -290,6 +294,7 @@ let safe_close_and_exec ?tracing ?env stdin stdout stderr
       Fecomms.write_raw_rpc ?tracing sock Fe.Exec ;
       match Fecomms.read_raw_rpc ?tracing sock with
       | Ok (Fe.Execed pid) ->
+          remove_fd_from_close_list sock ;
           (sock, pid)
       | Ok status ->
           let msg =

ocaml/forkexecd/test/fe_test.ml

@@ -20,6 +20,13 @@ let min_fds = 7
 
 let max_fds = 1024 - 13 (* fe daemon has a bunch for its own use *)
 
+let fail x =
+  Xapi_stdext_unix.Unixext.write_string_to_file "/tmp/fe-test.log" x ;
+  Printf.fprintf stderr "%s\n" x ;
+  assert false
+
+let fail fmt = Format.ksprintf fail fmt
+
 let all_combinations fds =
   let y =
     {
@@ -68,8 +75,26 @@ let shuffle x =
   done ;
   Array.to_list arr
 
+let fds_fold f init =
+  let path = "/proc/self/fd" in
+  (* get rid of the fd used to read the directory *)
+  Array.fold_right
+    (fun fd_num acc ->
+      try
+        let link = Unix.readlink (Filename.concat path fd_num) in
+        f fd_num link acc
+      with _ -> acc
+    )
+    (Sys.readdir path) init
+
+let fd_list () = fds_fold (fun fd_num link l -> (fd_num, link) :: l) []
+
+let fd_count () = fds_fold (fun _ _ n -> n + 1) 0
+
 let irrelevant_strings = ["irrelevant"; "not"; "important"]
 
+let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ())
+
 let one fds x =
   (*Printf.fprintf stderr "named_fds = %d\n" x.named_fds;
     Printf.fprintf stderr "extra = %d\n" x.extra;*)
@@ -82,7 +107,6 @@ let one fds x =
   let number_of_extra = x.extra in
   let other_names = make_names number_of_extra in
 
-  let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
   let table =
     (fun x -> List.combine x (List.map (fun _ -> fd) x)) (names @ other_names)
   in
@@ -107,7 +131,6 @@ let one fds x =
 
 let test_delay () =
   let start = Unix.gettimeofday () in
-  let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
   let args = ["sleep"] in
   (* Need to have fractional part because some internal usage split integer
      and fractional and do computation.
@@ -117,7 +140,7 @@ let test_delay () =
   let timeout = 1.7 in
   try
     Forkhelpers.execute_command_get_output ~timeout exe args |> ignore ;
-    failwith "Failed to timeout"
+    fail "Failed to timeout"
   with
   | Forkhelpers.Subprocess_timeout ->
       let elapsed = Unix.gettimeofday () -. start in
@@ -127,39 +150,25 @@ let test_delay () =
       if elapsed > timeout +. 0.2 then
         failwith "Excessive time elapsed"
   | e ->
-      failwith
-        (Printf.sprintf "Failed with unexpected exception: %s"
-           (Printexc.to_string e)
-        )
+      fail "Failed with unexpected exception: %s" (Printexc.to_string e)
 
 let test_notimeout () =
-  let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
   let args = ["sleep"] in
   try
     Forkhelpers.execute_command_get_output exe args |> ignore ;
     ()
-  with e ->
-    failwith
-      (Printf.sprintf "Failed with unexpected exception: %s"
-         (Printexc.to_string e)
-      )
-
-let fail x =
-  Xapi_stdext_unix.Unixext.write_string_to_file "/tmp/fe-test.log" x ;
-  Printf.fprintf stderr "%s\n" x ;
-  assert false
+  with e -> fail "Failed with unexpected exception: %s" (Printexc.to_string e)
 
 let expect expected s =
   if s <> expected ^ "\n" then
-    fail (Printf.sprintf "output %s expected %s" s expected)
+    fail "output %s expected %s" s expected
 
 let test_exitcode () =
   let run_expect cmd expected =
     try Forkhelpers.execute_command_get_output cmd [] |> ignore
     with Forkhelpers.Spawn_internal_error (_, _, Unix.WEXITED n) ->
       if n <> expected then
-        fail
-          (Printf.sprintf "%s exited with code %d, expected %d" cmd n expected)
+        fail "%s exited with code %d, expected %d" cmd n expected
   in
   run_expect "/bin/false" 1 ;
   run_expect "/bin/xe-fe-test-no-command" 127 ;
@@ -168,7 +177,6 @@ let test_exitcode () =
   Printf.printf "\nCompleted exitcode tests\n"
 
 let test_output () =
-  let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
   let expected_out = "output string" in
   let expected_err = "error string" in
   let args = ["echo"; expected_out; expected_err] in
@@ -178,7 +186,6 @@ let test_output () =
   print_endline "Completed output tests"
 
 let test_input () =
-  let exe = Printf.sprintf "/proc/%d/exe" (Unix.getpid ()) in
   let input = "input string" in
   let args = ["replay"] in
   let out, _ =
@@ -187,6 +194,38 @@ let test_input () =
   expect input out ;
   print_endline "Completed input tests"
 
+(* This test tests a failure inside Forkhelpers.safe_close_and_exec.
+   Although the exact way of this reproduction is never supposed to
+   happen in the real world, an internal failure could happen for instance
+   if forkexecd daemon is restarted for a moment, so make sure we are
+   able to detect and handle these cases *)
+let test_internal_failure_error () =
+  let initial_fd_count = fd_count () in
+  let leak_fd_detect () =
+    let current_fd_count = fd_count () in
+    if current_fd_count <> initial_fd_count then
+      fail "File descriptor leak detected initially %d files, now %d"
+        initial_fd_count current_fd_count
+  in
+  (* this weird function will open and close "num" file descriptors
+     and returns the last (now closed) of them, mainly to get an invalid
+     file descriptor with some closed one before *)
+  let rec waste_fds num =
+    let fd = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o0 in
+    let ret = if num = 0 then fd else waste_fds (num - 1) in
+    Unix.close fd ; ret
+  in
+  let fd = waste_fds 20 in
+  let args = ["sleep"] in
+  try
+    Forkhelpers.safe_close_and_exec None (Some fd) None [] exe args |> ignore ;
+    fail "Expected an exception"
+  with
+  | Fd_send_recv.Unix_error _ ->
+      leak_fd_detect ()
+  | e ->
+      fail "Failed with unexpected exception: %s" (Printexc.to_string e)
+
 let master fds =
   Printf.printf "\nPerforming timeout tests\n%!" ;
   test_delay () ;
@@ -196,6 +235,8 @@ let master fds =
   Printf.printf "\nPerforming input/output tests\n%!" ;
   test_output () ;
   test_input () ;
+  Printf.printf "\nPerforming internal failure test\n%!" ;
+  test_internal_failure_error () ;
   let combinations = shuffle (all_combinations fds) in
   Printf.printf "Starting %d tests\n%!" (List.length combinations) ;
   let i = ref 0 in
@@ -215,28 +256,14 @@ let master fds =
 
 let slave = function
   | [] ->
-      failwith "Error, at least one fd expected"
+      fail "Error, at least one fd expected"
   | total_fds :: rest ->
       let total_fds = int_of_string total_fds in
       let fds =
         List.filter (fun x -> not (List.mem x irrelevant_strings)) rest
       in
       (* Check that these fds are present *)
-      let pid = Unix.getpid () in
-      let path = Printf.sprintf "/proc/%d/fd" pid in
-      let raw =
-        List.filter (* get rid of the fd used to read the directory *)
-          (fun x ->
-            try
-              ignore (Unix.readlink (Filename.concat path x)) ;
-              true
-            with _ -> false
-          )
-          (Array.to_list (Sys.readdir path))
-      in
-      let pairs =
-        List.map (fun x -> (x, Unix.readlink (Filename.concat path x))) raw
-      in
+      let pairs = fd_list () in
       (* Filter any of stdin,stdout,stderr which have been mapped to /dev/null *)
       let filtered =
         List.filter
@@ -257,18 +284,16 @@ let slave = function
       List.iter
         (fun fd ->
           if not (List.mem fd (List.map fst filtered)) then
-            fail (Printf.sprintf "fd %s not in /proc/%d/fd [ %s ]" fd pid ls)
+            fail "fd %s not in /proc/self/fd [ %s ]" fd ls
         )
         fds ;
       (* Check that we have the expected number *)
       (*
 		  Printf.fprintf stderr "%s %d\n" total_fds (List.length present - 1)
 		*)
       if total_fds <> List.length filtered then
-        fail
-          (Printf.sprintf "Expected %d fds; /proc/%d/fd has %d: %s" total_fds
-             pid (List.length filtered) ls
-          )
+        fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds
+          (List.length filtered) ls
 
 let sleep () = Unix.sleep 3 ; Printf.printf "Ok\n"
 

ocaml/idl/datamodel_cluster.ml

@@ -194,6 +194,12 @@ let t =
              (Some (VString Constants.default_smapiv3_cluster_stack))
            "Simply the string 'corosync'. No other cluster stacks are \
             currently supported"
+       ; field ~qualifier:StaticRO ~lifecycle ~ty:Int "cluster_stack_version"
+           ~default_value:(Some (VInt 2L))
+           "Version of cluster stack, not writable via the API. Defaulting to \
+            2 for backwards compatibility when upgrading from a cluster \
+            without this field, which means it is necessarily running version \
+            2 of corosync, the only cluster stack supported so far."
        ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:Bool "is_quorate"
            ~default_value:(Some (VBool false))
            "Whether the cluster stack thinks the cluster is quorate"

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 = "8c3cb4546e7dc9e8d9d05c8194d8a3d6"
+let last_known_schema_hash = "2b8b5b107eb465e97d35a68274ac18ef"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/libs/tracing/dune

@@ -24,3 +24,9 @@
   zstd)
  (preprocess
   (pps ppx_deriving_rpc)))
+
+(test
+ (name test_tracing)
+ (modules test_tracing)
+ (package xapi-tracing)
+ (libraries tracing alcotest uuid))