CP-48838: Various build system and testing improvements

.github/workflows/main.yml

@@ -38,7 +38,7 @@ jobs:
     name: Ocaml tests
     runs-on: ubuntu-20.04
     env:
-      package: "xapi-cli-protocol xapi-client xapi-consts xapi-datamodel xapi-types xapi xe xen-api-sdk xen-api-client xen-api-client-lwt xen-api-client-async xapi-rrdd xapi-rrdd-plugin xapi-rrd-transport xapi-rrd-transport-utils rrd-transport rrdd-plugin rrdd-plugins rrddump gzip http-lib pciutil safe-resources sexpr stunnel uuid xapi-compression xml-light2 zstd vhd-tool xapi-networkd xapi-squeezed xapi-xenopsd xapi-xenopsd-cli xapi-xenopsd-simulator xapi-xenopsd-xc message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-storage-cli wsproxy xapi-nbd varstored-guard xapi-log xapi-open-uri vhd-format vhd-format-lwt"
+      package: "xapi-cli-protocol xapi-client xapi-consts xapi-datamodel xapi-types xapi xe xen-api-sdk xen-api-client xen-api-client-lwt xen-api-client-async xapi-rrdd xapi-rrdd-plugin xapi-rrd-transport xapi-rrd-transport-utils rrd-transport rrdd-plugin rrdd-plugins rrddump http-lib safe-resources sexpr stunnel uuid xml-light2 vhd-tool xapi-networkd xapi-squeezed xapi-xenopsd-cli xapi-xenopsd-simulator xapi-xenopsd-xc message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-storage-cli wsproxy xapi-nbd varstored-guard xapi-log xapi-open-uri vhd-format vhd-format-lwt"
       XAPI_VERSION: "v0.0.0-${{ github.sha }}"
 
     steps:

Makefile

@@ -194,7 +194,7 @@ install: build doc sdk doc-json
 	dune install --destdir=$(DESTDIR) --prefix=$(PREFIX) --libdir=$(LIBDIR) --mandir=$(MANDIR) \
 		xapi-client xapi-schema xapi-consts xapi-cli-protocol xapi-datamodel xapi-types \
 		xen-api-client xen-api-client-lwt xen-api-client-async rrdd-plugin rrd-transport \
-		gzip http-lib pciutil sexpr stunnel uuid xml-light2 zstd xapi-compression safe-resources \
+		http-lib sexpr stunnel uuid xml-light2 safe-resources \
 		message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt \
 		message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-storage-cli \
 		xapi-nbd varstored-guard xapi-log xapi-open-uri
@@ -216,7 +216,7 @@ uninstall:
 	dune uninstall --destdir=$(DESTDIR) --prefix=$(PREFIX) --libdir=$(LIBDIR) --mandir=$(MANDIR) \
 		xapi-client xapi-schema xapi-consts xapi-cli-protocol xapi-datamodel xapi-types \
 		xen-api-client xen-api-client-lwt xen-api-client-async rrdd-plugin rrd-transport \
-		gzip http-lib pciutil sexpr stunnel uuid xml-light2 zstd xapi-compression safe-resources \
+		http-lib sexpr stunnel uuid xml-light2 safe-resources \
 		message-switch message-switch-async message-switch-cli message-switch-core message-switch-lwt \
 		message-switch-unix xapi-idl forkexec xapi-forkexecd xapi-storage xapi-storage-script xapi-log \
 		xapi-open-uri

README.markdown

@@ -58,7 +58,7 @@ To build xen-api from source, we recommend using [opam](https://opam.ocaml.org/d
 6) Install all the Packages.
 
     ```bash
-    PACKAGES="xapi-cli-protocol xapi-client xapi-consts xapi-datamodel xapi-types xapi xe xen-api-sdk xen-api-client xen-api-client-lwt xen-api-client-async xapi-rrdd xapi-rrdd-plugin xapi-rrd-transport xapi-rrd-transport-utils rrd-transport rrdd-plugin rrdd-plugins rrddump gzip http-lib pciutil safe-resources sexpr stunnel uuid xapi-compression xml-light2 zstd vhd-tool xs-toolstack"
+    PACKAGES="xapi-cli-protocol xapi-client xapi-consts xapi-datamodel xapi-types xapi xe xen-api-sdk xen-api-client xen-api-client-lwt xen-api-client-async xapi-rrdd xapi-rrdd-plugin xapi-rrd-transport xapi-rrd-transport-utils rrd-transport rrdd-plugin rrdd-plugins rrddump http-lib pciutil safe-resources sexpr stunnel uuid xml-light2 vhd-tool xs-toolstack"
 
     # NOT needed with opam>=2.1.0) Install all the dependencies (Including OS):
     opam --yes depext --yes -u $PACKAGES # The first '--yes' is to install depext itself

dune

@@ -3,7 +3,7 @@
     (ocamlopt_flags (:standard -g -p -w -39))
     (flags (:standard -w -39))
   )
-  (dev (flags (:standard -g -w -39)))
+  (dev (flags (:standard -g -w -39 -warn-error -32-38-67-69)))
   (release
     (flags (:standard -w -39-6))
     (env-vars (ALCOTEST_COMPACT 1))

dune-project

@@ -1,3 +1,4 @@
-(lang dune 2.0)
+(lang dune 3.7)
 
+(implicit_transitive_deps false)
 (formatting (enabled_for ocaml))

message-switch-async.opam

@@ -12,7 +12,7 @@ build: [
 ]
 depends: [
   "ocaml"
-  "dune" {build & >= "1.4"}
+  "dune" {build & >= "3.7"}
   "odoc" {with-doc}
   "async" {>= "v0.9.0"}
   "cohttp-async" {>= "1.0.2"}

message-switch-cli.opam

@@ -12,7 +12,7 @@ build: [
 ]
 depends: [
   "ocaml"
-  "dune" {build & >= "1.4"}
+  "dune" {build & >= "3.7"}
   "odoc" {with-doc}
   "cmdliner"
   "message-switch-unix"

message-switch-core.opam

@@ -12,7 +12,7 @@ build: [
 ]
 depends: [
   "ocaml"
-  "dune" {build & >= "1.4"}
+  "dune" {build & >= "3.7"}
   "odoc" {with-doc}
   "astring"
   "cohttp" {>= "0.21.1"}

message-switch-lwt.opam

@@ -12,7 +12,7 @@ build: [
 ]
 depends: [
   "ocaml"
-  "dune" {build & >= "1.4"}
+  "dune" {build & >= "3.7"}
   "odoc" {with-doc}
   "cohttp-lwt-unix"
   "lwt" {>= "3.0.0"}

message-switch-unix.opam

@@ -12,7 +12,7 @@ build: [
 ]
 depends: [
   "ocaml"
-  "dune" {build & >= "1.4"}
+  "dune" {build & >= "3.7"}
   "odoc" {with-doc}
   "base-threads"
   "message-switch-core"

message-switch.opam

@@ -13,7 +13,7 @@ build: [
 ]
 depends: [
   "ocaml"
-  "dune" {build & >= "1.4"}
+  "dune" {build & >= "3.7"}
   "odoc" {with-doc}
   "cmdliner"
   "cohttp-async" {with-test}

ocaml/alerts/certificate/dune

@@ -1,6 +1,7 @@
 (library
   (name certificate_check)
   (modules certificate_check)
+  (modes best)
   (libraries
     astring
     xapi-client

ocaml/auth/dune

@@ -1,4 +1,5 @@
 (library
+  (modes best)
   (foreign_stubs
     (language c)
     (names xa_auth xa_auth_stubs)

ocaml/cdrommon/cdrommon.ml

@@ -14,16 +14,13 @@
 let oldnotify = ref false
 
 let disc_inserted name =
-  let args = [|"xe"; "host-notify"; "type=cdrom"; "params=inserted:" ^ name|] in
-  let ret = Xapi_stdext_unix.Unixext.spawnvp args.(0) args in
+  let cmd =
+    Filename.quote_command "xe"
+      ["host-notify"; "type=cdrom"; "params=inserted:" ^ name]
+  in
+  let ret = Sys.command cmd in
   (* check if we got an error, and record the fact *)
-  match ret with
-  | Unix.WEXITED 0 ->
-      oldnotify := false
-  | Unix.WEXITED _ ->
-      oldnotify := true
-  | _ ->
-      oldnotify := true
+  match ret with 0 -> oldnotify := false | _ -> oldnotify := true
 
 let disc_removed (_ : string) =
   (* we don't need to do anything *)
@@ -63,6 +60,5 @@ let () =
     Printf.eprintf "usage: %s <cdrompath>\n" Sys.argv.(0) ;
     exit 1
   ) ;
-  Xapi_stdext_unix.Unixext.daemonize () ;
   (* check every 2 seconds *)
   check 2 Sys.argv.(1)

ocaml/cdrommon/dune

@@ -5,9 +5,6 @@
   (package xapi)
   (libraries
     cdrom
-    threads
-    unix
-    xapi-stdext-unix
   )
 )
 

ocaml/database/dune

@@ -16,11 +16,12 @@
     xapi-stdext-encodings
   )
   (wrapped false)
-  (preprocess (pps ppx_sexp_conv))
+  (preprocess (per_module ((pps ppx_sexp_conv) Schema)))
 )
 
 (library
   (name xapi_database)
+  (modes best)
   (modules
     (:standard \ database_server_main db_cache_test db_names db_exn
       block_device_io string_marshall_helper string_unmarshall_helper schema
@@ -49,7 +50,10 @@
     xmlm
   )
   (wrapped false)
-  (preprocess (pps ppx_deriving_rpc))
+  (preprocess
+    (per_module
+     ((pps ppx_deriving_rpc)
+      Db_cache_types Db_filter_types Db_rpc_common_v2 Db_secret_string)))
 )
 
 (executable

ocaml/forkexecd/lib/dune

@@ -13,5 +13,4 @@
    xapi-stdext-pervasives
    xapi-stdext-unix
  )
- (preprocess
-  (pps ppx_deriving_rpc)))
+ (preprocess (per_module ((pps ppx_deriving_rpc) Fe))))

ocaml/forkexecd/lib/fe_systemctl.ml

@@ -18,54 +18,127 @@ type status = {
   ; active_state: string
 }
 
+module StringMap = Map.Make (String)
+
+type 'a string_map = 'a StringMap.t
+
 let systemctl = "/usr/bin/systemctl"
 
-let action ~service action =
-  let _, _stderr =
-    Forkhelpers.execute_command_get_output systemctl [action; service]
+let test_mode = ref false
+
+let execute_command_get_output cmd args =
+  (* for systemctl --user to work it needs env vars *)
+  let env, args =
+    if !test_mode then
+      (Some (Unix.environment ()), "--user" :: args)
+    else
+      (None, args)
   in
+  Forkhelpers.execute_command_get_output ?env cmd args
+
+let action ?(args = []) ~service action =
+  let _, _ = execute_command_get_output systemctl (action :: service :: args) in
   ()
 
-let default_env = ["PATH=" ^ String.concat ":" Forkhelpers.default_path]
+let default_env =
+  StringMap.singleton "PATH" @@ String.concat ":" Forkhelpers.default_path
 
 let run_path = "/run/systemd/system/"
 
-let start_transient ?(env = Array.of_list default_env) ?(properties = [])
-    ~service cmd args =
+(* see https://www.freedesktop.org/software/systemd/man/systemd.syntax.html#Quoting
+   Neither [Filename.quote] or [String.escaped] would produce correct results
+*)
+let systemd_quote s =
+  let b = Buffer.create (String.length s) in
+  Buffer.add_char b '\'' ;
+  let () =
+    s
+    |> String.iter @@ function
+       | '\\' ->
+           Buffer.add_string b {|\\|}
+       | '\'' ->
+           (* these hex escapes work regardless what outer quotes are used *)
+           Buffer.add_string b {|\x27|}
+       | '"' ->
+           Buffer.add_string b {|\x22|}
+       | c when Astring.Char.Ascii.is_print c ->
+           Buffer.add_char b c
+       | _ ->
+           invalid_arg ("Values can only contain printable characters: " ^ s)
+  in
+  Buffer.add_char b '\'' ; Buffer.contents b
+
+let env_pair (k, v) = Printf.sprintf "%s=%s" k v
+
+let environment env =
+  env
+  |> StringMap.bindings
+  |> List.map env_pair
+  |> List.map (fun v -> ("Environment", [v]))
+(* we could build just a single environment line, but might be too long and
+   difficult to debug *)
+
+let build_properties env base properties =
+  "[Service]"
+  :: (List.concat [environment env; base; properties]
+     |> List.map (fun (k, v) ->
+            String.concat ""
+              [k; "="; List.map systemd_quote v |> String.concat " "]
+        )
+     )
+
+let start_transient ?(env = default_env) ?(properties = []) ~service cmd args =
   let syslog_key = service in
   let service = syslog_key ^ ".service" in
   let destination = Filename.concat run_path service in
-  properties
-  |> List.append
-       [
-         ( "Environment"
-         , env |> Array.to_list |> List.map Filename.quote |> String.concat " "
-         )
-       ; ("SyslogIdentifier", syslog_key)
-       ; ("SyslogLevel", "debug")
-       ; ("StandardOutput", "syslog")
-       ; ("StandardError", "inherit")
-       ; ("StartLimitInterval", "0") (* no rate-limit, for bootstorms *)
-       ; ("ExecStart", String.concat " " (cmd :: List.map Filename.quote args))
-       ; ("Type", "simple")
-         (* our systemd is too old, and doesn't support 'exec' *)
-       ; ("Restart", "no")
-         (* can't restart the device-model, it would've lost all state already *)
-       ; ("Slice", "system.slice")
-       ; ("TimeoutStopSec", "10")
-       ]
-  |> List.map (fun (k, v) -> k ^ "=" ^ v)
+  build_properties env
+    [
+      ("SyslogIdentifier", [syslog_key])
+    ; ("SyslogLevel", ["debug"])
+    ; ("StandardOutput", ["syslog"])
+    ; ("StandardError", ["inherit"])
+    ; ("StartLimitInterval", ["0"]) (* no rate-limit, for bootstorms *)
+    ; ("ExecStart", cmd :: args)
+    ; ("Type", ["simple"])
+      (* our systemd is too old, and doesn't support 'exec' *)
+    ; ("Restart", ["no"])
+      (* can't restart the device-model, it would've lost all state already *)
+    ; ("Slice", ["system.slice"])
+    ; ("TimeoutStopSec", ["10"])
+    ]
+    properties
   |> List.append
        [
          "[Unit]"
        ; "Description=transient unit for " ^ syslog_key
        ; "DefaultDependencies=no" (* lifecycle tied to domain, not systemd *)
-       ; "[Service]"
        ]
   |> String.concat "\n"
   |> Xapi_stdext_unix.Unixext.write_string_to_file destination ;
   action ~service "start"
 
+let unit_path () =
+  if !test_mode then
+    let home = Sys.getenv_opt "HOME" |> Option.value ~default:"/root" in
+    Filename.concat home ".config/systemd/user"
+  else
+    "/etc/systemd/system"
+
+let drop_in_path service =
+  Printf.sprintf "%s/%s.service.d/10-xapi.conf" (unit_path ()) service
+
+let set_properties ?(env = StringMap.empty) ?(properties = []) ~service () =
+  let path = drop_in_path service in
+  Xapi_stdext_unix.Unixext.mkdir_rec (Filename.dirname path) 0o700 ;
+  build_properties env [] properties
+  |> String.concat "\n"
+  |> Xapi_stdext_unix.Unixext.write_string_to_file ~perms:0o600 path ;
+  let _, _ = execute_command_get_output systemctl ["daemon-reload"] in
+  ()
+
+let start_templated ~template ~instance =
+  action ~service:(Printf.sprintf "%s@%s" template instance) "start"
+
 let show ~service =
   let result = "Result" in
   let exec_main_pid = "ExecMainPID" in
@@ -75,7 +148,7 @@ let show ~service =
     [result; exec_main_pid; exec_main_status; active_state] |> String.concat ","
     |> fun properties ->
     ["show"; "-p"; properties; service]
-    |> Forkhelpers.execute_command_get_output systemctl
+    |> execute_command_get_output systemctl
     |> fst
     |> Astring.String.cuts ~sep:"\n"
     |> List.to_seq
@@ -104,6 +177,9 @@ let stop ~service =
   ) ;
   let destination = Filename.concat run_path (service ^ ".service") in
   Xapi_stdext_unix.Unixext.unlink_safe destination ;
+  let dropin = drop_in_path service in
+  Xapi_stdext_unix.Unixext.unlink_safe dropin ;
+  let () = try Unix.rmdir (Filename.dirname dropin) with _ -> () in
   status
 
 let is_active ~service =
@@ -135,3 +211,5 @@ let start_transient ?env ?properties ~service cmd args =
       with _ -> ()
     ) ;
     raise e
+
+let set_test () = test_mode := true