From 587940ce3c69a6600606272e4dfc2ac19f4076fe Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 20 Mar 2020 14:58:04 +0000 Subject: [PATCH 01/42] Remove bisect_ppx instrumentation This removes stale code for instrumentation with bisect_ppx which we have not used for a long time and whose integration into the dune build system is likely to change in the future. Signed-off-by: Christian Lindig --- cluster/dune | 13 ++----------- example/dune | 13 ++----------- gpumon/dune | 13 ++----------- lib/dune | 30 ++---------------------------- lib/xcp_coverage.mli | 17 ----------------- lib/xcp_service.ml | 1 - lib_test/dune | 16 +++------------- memory/dune | 13 ++----------- network/dune | 13 ++----------- rrd/dune | 17 ++++------------- v6/dune | 14 ++------------ xen/dune | 18 +++--------------- 12 files changed, 24 insertions(+), 154 deletions(-) delete mode 100644 lib/xcp_coverage.mli diff --git a/cluster/dune b/cluster/dune index 42bb0132..ab04221f 100644 --- a/cluster/dune +++ b/cluster/dune @@ -1,11 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xcp_cluster) @@ -14,7 +6,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (flags (:standard -w -39)) (libraries xapi-idl threads rpclib.core) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (executable @@ -31,6 +23,5 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (alias (name runtest) (deps (:x cluster_cli.exe)) - (action (run %%{x})) + (action (run %{x})) ) -|} coverage_rewriter diff --git a/example/dune b/example/dune index c40c5cdc..21659d67 100644 --- a/example/dune +++ b/example/dune @@ -1,11 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (executable (name example) @@ -14,12 +6,11 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| rpclib.core xapi-idl ) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (alias (name runtest) (deps (:x example.exe)) - (action (run %%{x})) + (action (run %{x})) ) -|} coverage_rewriter diff --git a/gpumon/dune b/gpumon/dune index 26c5877b..1058963e 100644 --- a/gpumon/dune +++ b/gpumon/dune @@ -1,11 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xapi_gpumon) @@ -18,7 +10,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (executable @@ -35,6 +27,5 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (alias (name runtest) (deps (:x gpumon_cli.exe)) - (action (run %%{x})) + (action (run %{x})) ) -|} coverage_rewriter diff --git a/lib/dune b/lib/dune index bb5a078c..8a7fe520 100644 --- a/lib/dune +++ b/lib/dune @@ -1,27 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let runtime_coverage_enabled, coverage_dep = - let use_bisect_runtime = - match Sys.getenv "BISECT_RUNTIME" with - | "YES" -> true - | _ -> false - | exception Not_found -> false in - if use_bisect_runtime then - "enabled.ml", "bisect_ppx.runtime" - else - "disabled.ml", "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| - -(rule - (targets xcp_coverage.ml) - (action (copy coverage/%s %%{targets})) -) (library (name xcp) @@ -30,7 +6,6 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (modules (:standard \ scheduler task_server updates)) (c_names syslog_stubs) (libraries - %s cmdliner cohttp fd-send-recv @@ -53,7 +28,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xmlm ) (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc %s)) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc )) ) (library @@ -63,6 +38,5 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (modules updates task_server scheduler) (libraries xapi-idl) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) -|} runtime_coverage_enabled coverage_dep coverage_rewriter coverage_rewriter diff --git a/lib/xcp_coverage.mli b/lib/xcp_coverage.mli deleted file mode 100644 index 0eaaea0b..00000000 --- a/lib/xcp_coverage.mli +++ /dev/null @@ -1,17 +0,0 @@ -(* The build system chooses either 'coverage/enabled.ml' or - * 'coverage/disabled.ml' as an implementation. - * Executables need to make exactly one call to exactly one of - * [init], [dispatcher_init] or [Xcp_service.configure2]. - * *) - -(** [init name] sets up coverage profiling for binary [name]. You could - * use [Sys.argv.(0)] for [name]. - *) - -val init: string -> unit - -(** [dispatcher_init name] only initializes the toplevel coverage API dispatcher on a system. - * This is meant to be called only by XAPI, which will have to call both [init] - * and [dispatcher_init]. - *) -val dispatcher_init : string -> unit diff --git a/lib/xcp_service.ml b/lib/xcp_service.ml index c60ced4f..41a05a0e 100644 --- a/lib/xcp_service.ml +++ b/lib/xcp_service.ml @@ -361,7 +361,6 @@ type ('a, 'b) error = [ let configure2 ~name ~version ~doc ?(options=[]) ?(resources=[]) () = try - Xcp_coverage.init name; configure_common ~options ~resources (fun config_spec -> match Term.eval (command_of ~name ~version ~doc config_spec) with diff --git a/lib_test/dune b/lib_test/dune index aea0fcd4..394e2e23 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -1,12 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (executables (names test) @@ -29,19 +20,18 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl.v6 xapi-idl.xen ) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (alias (name runtest) (deps (:x test.exe) (source_tree test_data)) - (action (run %%{x})) + (action (run %{x})) ) (alias (name runtest-quick) (deps (:x test.exe) (source_tree test_data)) - (action (run %%{x} -q)) + (action (run %{x} -q)) ) -|} coverage_rewriter diff --git a/memory/dune b/memory/dune index cc67c2f9..a8b816b0 100644 --- a/memory/dune +++ b/memory/dune @@ -1,11 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xcp_memory) @@ -18,7 +10,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (executable @@ -35,7 +27,6 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (alias (name runtest) (deps (:x memory_cli.exe)) - (action (run %%{x})) + (action (run %{x})) ) -|} coverage_rewriter diff --git a/network/dune b/network/dune index f5f2c576..5fa0131d 100644 --- a/network/dune +++ b/network/dune @@ -1,11 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xcp_network) @@ -18,7 +10,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (executable @@ -35,7 +27,6 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (alias (name runtest) (deps (:x network_cli.exe)) - (action (run %%{x})) + (action (run %{x})) ) -|} coverage_rewriter diff --git a/rrd/dune b/rrd/dune index 90cde1cd..0453555b 100644 --- a/rrd/dune +++ b/rrd/dune @@ -1,11 +1,3 @@ -(* -*- tuareg -*- *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xcp_rrd_interface_types) @@ -19,7 +11,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (library @@ -35,7 +27,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl.rrd.interface.types ) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (library @@ -51,7 +43,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl.rrd.interface ) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (executable @@ -68,7 +60,6 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (alias (name runtest) (deps (:x rrd_cli.exe)) - (action (run %%{x})) + (action (run %{x})) ) -|} coverage_rewriter coverage_rewriter coverage_rewriter diff --git a/v6/dune b/v6/dune index 88af0f49..ba51474d 100644 --- a/v6/dune +++ b/v6/dune @@ -1,12 +1,3 @@ -(* -*- tuareg -*- *) - -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xcp_v6) @@ -19,7 +10,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc %s)) + (preprocess (pps ppx_deriving_rpc )) ) (executable @@ -36,7 +27,6 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| (alias (name runtest) (deps (:x v6_cli.exe)) - (action (run %%{x})) + (action (run %{x})) ) -|} coverage_rewriter diff --git a/xen/dune b/xen/dune index 577fec17..336b1bf9 100644 --- a/xen/dune +++ b/xen/dune @@ -1,14 +1,3 @@ -(* -*- tuareg -*- *) - -(* (preprocess (pps)) doesn't work with camlp4 and the other ppx derivers, - it complains about missing rpc_of_t *) -let coverage_rewriter = - match Sys.getenv "BISECT_ENABLE" with - | "YES" -> "bisect_ppx" - | _ -> "" - | exception Not_found -> "" - -let () = Printf.ksprintf Jbuild_plugin.V1.send {| (library (name xcp_xen_interface_types) @@ -21,7 +10,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl ) (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv %s)) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv )) ) (library @@ -36,7 +25,7 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl.xen.interface.types ) (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv %s)) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv )) ) (library @@ -51,6 +40,5 @@ let () = Printf.ksprintf Jbuild_plugin.V1.send {| xapi-idl.xen.interface ) (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv %s)) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv )) ) -|} coverage_rewriter coverage_rewriter coverage_rewriter From 54dbca28d3669cb6b2c38d571f0b44aaf0297770 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 20 Mar 2020 15:29:37 +0000 Subject: [PATCH 02/42] CA-337000 escape non-printable characters in log msgs To ensure that non-printable characters are logged in a readable way, escape them using an efficient implementation: - Any \ (0x5C) escaped to the sequence \\ (0x5C,0x5C). - Any byte in the ranges 0x00..0x1F and 0x7F..0xFF escaped by an e hexadecimal \xHH escape with H a capital hexadecimal number. These bytes are the US-ASCII control characters and non US-ASCII bytes. - Any other byte is left unchanged. The escaping of \ could be considered unnecessary. The main motivation was using an existing efficient implementation. Signed-off-by: Christian Lindig --- lib/debug.ml | 9 +++++++-- lib/dune | 1 + 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/lib/debug.ml b/lib/debug.ml index 6bcdf775..190d9e2b 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -69,6 +69,11 @@ let gettimestring () = tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec (int_of_float (1000.0 *. msec)) +(** [escape str] efficiently escapes non-printable characters and in +* addition the backslash character. The function is efficient in the +* sense that it will allocate a new string only when necessary *) +let escape = Astring.String.Ascii.escape + let format include_time brand priority message = let id = get_thread_id () in let name = match ThreadLocalTable.find names with Some x -> x | None -> "" in @@ -110,7 +115,7 @@ let output_log brand level priority s = if !print_debug then Printf.printf "%s\n%!" (format true brand priority s); - Syslog.log (get_facility ()) level msg + Syslog.log (get_facility ()) level (escape msg) end let logs_reporter = @@ -265,7 +270,7 @@ module Make = functor(Brand: BRAND) -> struct Printf.kprintf (fun s -> let msg = if raw then s else format true Brand.name "audit" s in - Syslog.log Syslog.Local6 Syslog.Info msg; + Syslog.log Syslog.Local6 Syslog.Info (escape msg); msg ) fmt diff --git a/lib/dune b/lib/dune index 8a7fe520..afb059d8 100644 --- a/lib/dune +++ b/lib/dune @@ -6,6 +6,7 @@ (modules (:standard \ scheduler task_server updates)) (c_names syslog_stubs) (libraries + astring cmdliner cohttp fd-send-recv From f6ade3087378eac14db5e13d564d2ff112966e32 Mon Sep 17 00:00:00 2001 From: Arne Wendt Date: Thu, 12 Mar 2020 20:56:54 +0000 Subject: [PATCH 03/42] add Sriov.enable_action_result Manual_successful, for manual sr-iov/vf configuration support Signed-off-by: Arne Wendt --- network/network_interface.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/network/network_interface.ml b/network/network_interface.ml index 92c91bb6..9fd40139 100644 --- a/network/network_interface.ml +++ b/network/network_interface.ml @@ -651,6 +651,7 @@ module Interface_API(R : RPC) = struct | Modprobe_successful_requires_reboot | Modprobe_successful | Sysfs_successful + | Manual_successful [@@deriving rpcty] type enable_result = From 434da2e02faf2e3578d146778bd050b967f2dac6 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 7 Apr 2020 21:21:47 +0100 Subject: [PATCH 04/42] Revert "add Sriov.enable_action_result Manual_successful, for manual sr-iov/vf configuration support" This reverts commit f6ade3087378eac14db5e13d564d2ff112966e32. --- network/network_interface.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/network/network_interface.ml b/network/network_interface.ml index 9fd40139..92c91bb6 100644 --- a/network/network_interface.ml +++ b/network/network_interface.ml @@ -651,7 +651,6 @@ module Interface_API(R : RPC) = struct | Modprobe_successful_requires_reboot | Modprobe_successful | Sysfs_successful - | Manual_successful [@@deriving rpcty] type enable_result = From b888d356c6281a0615a4cec77e8b59e280dd1908 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 Apr 2020 11:25:06 +0100 Subject: [PATCH 05/42] maintenance: remove ambiguity of doc comment Adding an empty line removes the ambiguity for the ocaml compiler Signed-off-by: Pau Ruiz Safont --- storage/storage_interface.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/storage/storage_interface.ml b/storage/storage_interface.ml index 4d2ce17a..c5297a42 100644 --- a/storage/storage_interface.ml +++ b/storage/storage_interface.ml @@ -668,6 +668,7 @@ module StorageAPI (R : RPC) = struct declare "VDI.epoch_begin" [] (dbg_p @-> sr_p @-> vdi_p @-> vm_p @-> persistent_p @-> returning unit_p err) let read_write_p = Param.mk ~name:"read_write" Types.bool + (** [attach task dp sr vdi read_write] returns the [params] for a given [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] is true. @@ -680,7 +681,7 @@ module StorageAPI (R : RPC) = struct (** [attach2 task dp sr vdi read_write] returns the [params] for a given [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] - is true. + is true. @deprecated This function is deprecated, and is only here to keep backward compatibility with old xapis that call Remote.VDI.attach2 during SXM. Use the attach3 function instead. *) @@ -696,7 +697,7 @@ module StorageAPI (R : RPC) = struct declare "VDI.attach3" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> read_write_p @-> returning backend_p err) (** [activate task dp sr vdi] signals the desire to immediately use [vdi]. - This client must have called [attach] on the [vdi] first. + This client must have called [attach] on the [vdi] first. @deprecated This function is deprecated, and is only here to keep backward compatibility with old xapis that call Remote.VDI.activate during SXM. Use the activate3 function instead. *) From 81b3fc6a7865804eb7f6db26a761f2e17b3cd207 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 Apr 2020 11:35:27 +0100 Subject: [PATCH 06/42] maintenance: Tweak comments This means promoting them to doc-comments so they can be attached to the apropriate field or marking them as unwrappable. Signed-off-by: Pau Ruiz Safont --- cluster/cluster_interface.ml | 6 ++--- lib/task_server.ml | 31 ++++++++++++----------- lib/updates.ml | 8 +++--- lib_test/channel_test.ml | 6 +++-- lib_test/http_test.ml | 3 ++- memory/memory.ml | 49 +++++++++++++++++++----------------- network/network_stats.ml | 18 ++++++------- storage/storage_test.ml | 5 ++-- xen/xenops_types.ml | 26 +++++++++---------- 9 files changed, 80 insertions(+), 72 deletions(-) diff --git a/cluster/cluster_interface.ml b/cluster/cluster_interface.ml index 383176d9..b955b466 100644 --- a/cluster/cluster_interface.ml +++ b/cluster/cluster_interface.ml @@ -71,9 +71,9 @@ type cluster_config_and_all_members = cluster_config * all_members [@@deriving r be in this type. *) type diagnostics = { config_valid : bool; - live_cluster_config : cluster_config option; (* live corosync config *) - next_cluster_config : cluster_config option; (* next corosync config *) - saved_cluster_config : cluster_config option; (* xapi-clusterd DB *) + live_cluster_config : cluster_config option; (** live corosync config *) + next_cluster_config : cluster_config option; (** next corosync config *) + saved_cluster_config : cluster_config option; (** xapi-clusterd DB *) is_enabled : bool; all_members : all_members option; node_id : nodeid option; diff --git a/lib/task_server.ml b/lib/task_server.ml index 01b9c85a..8eff28f2 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -68,24 +68,24 @@ module Task = functor (Interface : INTERFACE) -> struct module SMap = Map.Make(struct type t = string let compare = compare end) - (* Tasks are stored in an id -> t map *) + (** Tasks are stored in an id -> t map *) type id = string - (* A task is associated with every running operation *) + (** A task is associated with every running operation *) type task_handle = { tasks : tasks; - id: id; (* unique task id *) - ctime: float; (* created timestamp *) - dbg: string; (* token sent by client *) - mutable state: Interface.Task.state; (* current completion state *) - mutable subtasks: (string * Interface.Task.state) list; (* one level of "subtasks" *) - f: task_handle -> Interface.Task.async_result option; (* body of the function *) - tm: Mutex.t; (* protects cancelling state: *) - mutable cancelling: bool; (* set by cancel *) - mutable cancel: (unit -> unit) list; (* attempt to cancel [f] *) - mutable cancel_points_seen: int; (* incremented every time we pass a cancellation point *) - test_cancel_at: int option; (* index of the cancel point to trigger *) - mutable backtrace: Backtrace.t; (* on error, a backtrace *) + id: id; (** unique task id *) + ctime: float; (** created timestamp *) + dbg: string; (** token sent by client *) + mutable state: Interface.Task.state; (** current completion state *) + mutable subtasks: (string * Interface.Task.state) list; (** one level of "subtasks" *) + f: task_handle -> Interface.Task.async_result option; (** body of the function *) + tm: Mutex.t; (** protects cancelling state *) + mutable cancelling: bool; (** set by cancel *) + mutable cancel: (unit -> unit) list; (** attempt to cancel [f] *) + mutable cancel_points_seen: int; (** incremented every time we pass a cancellation point *) + test_cancel_at: int option; (** index of the cancel point to trigger *) + mutable backtrace: Backtrace.t; (** on error, a backtrace *) mutable cancellable: bool; } @@ -140,7 +140,8 @@ module Task = functor (Interface : INTERFACE) -> struct cancel_points_seen = 0; test_cancel_at = (match tasks.test_cancel_trigger with | Some (dbg', n) when dbg = dbg' -> - clear_cancel_trigger tasks; (* one shot *) + (* one shot *) + clear_cancel_trigger tasks; Some n | _ -> None); backtrace = Backtrace.empty; diff --git a/lib/updates.ml b/lib/updates.ml index cbdeab1a..3bd9165a 100644 --- a/lib/updates.ml +++ b/lib/updates.ml @@ -26,13 +26,13 @@ module Updates = functor(Interface : INTERFACE) -> struct (* Type for inner snapshot that we create when injecting a barrier *) type barrier = { - bar_id: int; (* This int is a token from outside. *) - map_s: int M.t; (* Snapshot of main map *) - event_id: id (* Snapshot of "next" from when barrier was injected *) + bar_id: int; (** This int is a token from outside. *) + map_s: int M.t; (** Snapshot of main map *) + event_id: id (** Snapshot of "next" from when barrier was injected *) } type t = { - map: int M.t; (* Events with incrementing ids from "next" *) + map: int M.t; (** Events with incrementing ids from "next" *) barriers: barrier list; next: id } diff --git a/lib_test/channel_test.ml b/lib_test/channel_test.ml index d87162ee..c62a4a61 100644 --- a/lib_test/channel_test.ml +++ b/lib_test/channel_test.ml @@ -50,11 +50,13 @@ let check_for_leak_proxy () = let a, b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in let before = count_fds () in let c = dup_proxy a in - Thread.delay 1.0; (* background fd closing *) + (* background fd closing *) + Thread.delay 1.0; let after = count_fds () in Alcotest.(check int) "fds" (before + 2) after; Unix.close c; - Thread.delay 1.0; (* background fd closing *) + (* background fd closing *) + Thread.delay 1.0; let after' = count_fds () in Alcotest.(check int) "fds" before after' diff --git a/lib_test/http_test.ml b/lib_test/http_test.ml index eb5b2432..fa47118a 100644 --- a/lib_test/http_test.ml +++ b/lib_test/http_test.ml @@ -20,7 +20,8 @@ let unbuffered_headers () = let ic = { header_buffer = Some "HTTP/200 OK\r\nHeader1: Val1\r\nHeader2: Val2\r\n\r\n"; header_buffer_idx = 0; - fd = Unix.stdin; (* unused *) + (* unused *) + fd = Unix.stdin; } in Alcotest.(check (option string)) "header line 1" (Some "HTTP/200 OK") (read_line ic); Alcotest.(check (option string)) "header line 2" (Some "Header1: Val1") (read_line ic); diff --git a/memory/memory.ml b/memory/memory.ml index 38fec636..cfd1bacf 100644 --- a/memory/memory.ml +++ b/memory/memory.ml @@ -84,29 +84,32 @@ let mib_of_pages_used value = divide_rounding_up value pages_per_mib (* === Domain memory breakdown ======================================================= *) -(* ╤ ╔══════════╗ ╤ *) -(* │ ║ shadow ║ │ *) -(* │ ╠══════════╣ │ *) -(* overhead │ ║ extra ║ │ *) -(* │ ║ external ║ │ *) -(* │ ╠══════════╣ ╤ │ *) -(* │ ║ extra ║ │ │ *) -(* │ ║ internal ║ │ │ *) -(* │ ╠══════════╣ ╤ ╤ ╤ │ │ footprint *) -(* │ ║ shim ║ │ │ │ │ │ *) -(* ╪ ╠══════════╣ ╧ ╧ ╤ │ │ xen │ *) -(* │ ║ video ║ │ │ actual │ maximum │ *) -(* │ ╠══════════╣ ╤ ╤ │ │ / │ │ *) -(* │ ║ ║ │ │ build │ target │ total │ │ *) -(* │ ║ guest ║ │ │ start │ │ │ │ *) -(* static │ ║ ║ │ │ │ │ │ │ *) -(* maximum │ ╟──────────╢ │ ╧ ╧ ╧ ╧ ╧ *) -(* │ ║ ║ │ *) -(* │ ║ ║ │ *) -(* │ ║ balloon ║ │ build *) -(* │ ║ ║ │ maximum *) -(* │ ║ ║ │ *) -(* ╧ ╚══════════╝ ╧ *) +(* + ╤ ╔══════════╗ ╤ + │ ║ shadow ║ │ + │ ╠══════════╣ │ + overhead │ ║ extra ║ │ + │ ║ external ║ │ + │ ╠══════════╣ ╤ │ + │ ║ extra ║ │ │ + │ ║ internal ║ │ │ + │ ╠══════════╣ ╤ ╤ ╤ │ │ footprint + │ ║ shim ║ │ │ │ │ │ + ╪ ╠══════════╣ ╧ ╧ ╤ │ │ xen │ + │ ║ video ║ │ │ actual │ maximum │ + │ ╠══════════╣ ╤ ╤ │ │ / │ │ + │ ║ ║ │ │ build │ target │ total │ │ + │ ║ guest ║ │ │ start │ │ │ │ + static │ ║ ║ │ │ │ │ │ │ + maximum │ ╟──────────╢ │ ╧ ╧ ╧ ╧ ╧ + │ ║ ║ │ + │ ║ ║ │ + │ ║ balloon ║ │ build + │ ║ ║ │ maximum + │ ║ ║ │ + ╧ ╚══════════╝ ╧ + *) + [@@ocamlformat "wrap-comments=false"] (* === Domain memory breakdown: HVM guests =========================================== *) diff --git a/network/network_stats.ml b/network/network_stats.ml index 85336f2f..6534bf92 100644 --- a/network/network_stats.ml +++ b/network/network_stats.ml @@ -29,12 +29,12 @@ let checksum_bytes = 32 let length_bytes = 8 type iface_stats = { - tx_bytes: int64; (* bytes emitted *) - tx_pkts: int64; (* packets emitted *) - tx_errors: int64; (* error emitted *) - rx_bytes: int64; (* bytes received *) - rx_pkts: int64; (* packets received *) - rx_errors: int64; (* error received *) + tx_bytes: int64; (** bytes emitted *) + tx_pkts: int64; (** packets emitted *) + tx_errors: int64; (** error emitted *) + rx_bytes: int64; (** bytes received *) + rx_pkts: int64; (** packets received *) + rx_errors: int64; (** error received *) carrier: bool; speed: int; duplex: duplex; @@ -85,16 +85,16 @@ module File_helpers = struct (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) - let fd_blocks_fold block_size f start fd = + let fd_blocks_fold block_size f start fd = let block = Bytes.create block_size in - let rec fold acc = + let rec fold acc = let n = Unix.read fd block 0 block_size in (* Consider making the interface explicitly use Substrings *) let s = if n = block_size then (Bytes.to_string block) else Bytes.sub_string block 0 n in if n = 0 then acc else fold (f acc s) in fold start - let buffer_of_fd fd = + let buffer_of_fd fd = fd_blocks_fold 1024 (fun b s -> Buffer.add_string b s; b) (Buffer.create 1024) fd let buffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 buffer_of_fd diff --git a/storage/storage_test.ml b/storage/storage_test.ml index 384fd691..dc661714 100644 --- a/storage/storage_test.ml +++ b/storage/storage_test.ml @@ -36,7 +36,8 @@ let _vdi_resize = "VDI_RESIZE" (* Names which are likely to cause problems *) let names = [ - "simple"; (* start with an easy one *) + (* start with an easy one *) + "simple"; ""; "."; ".."; @@ -194,4 +195,4 @@ let cmd = Term.(const start $ verbose $ queue $ sr), Term.info "test" ~doc ~man -let () = Term.exit @@ Term.eval ~catch:true cmd \ No newline at end of file +let () = Term.exit @@ Term.eval ~catch:true cmd diff --git a/xen/xenops_types.ml b/xen/xenops_types.ml index 211c12d9..6f52cc36 100644 --- a/xen/xenops_types.ml +++ b/xen/xenops_types.ml @@ -17,14 +17,14 @@ end module Vgpu = struct type gvt_g = { - physical_pci_address: address option; (* unused; promoted to Vgpu.t *) + physical_pci_address: address option; (** unused; promoted to Vgpu.t *) low_gm_sz: int64; high_gm_sz: int64; fence_sz: int64; monitor_config_file: string option; } [@@deriving sexp, rpcty] - (* Example for nvidia: + (** Example for nvidia: { physical_pci_address : None config_file: None @@ -35,16 +35,16 @@ module Vgpu = struct } *) type nvidia = { - physical_pci_address: address option; (* unused; promoted to Vgpu.t *) + physical_pci_address: address option; (** unused; promoted to Vgpu.t *) config_file: string option; virtual_pci_address: address [@default {domain = 0000; bus = 0; dev = 11; fn = 0}]; type_id: string option; uuid: string option; - extra_args: string [@default ""]; (* string is passed on as is and no structure is assumed *) + extra_args: string [@default ""]; (** string is passed on as is and no structure is assumed *) } [@@deriving sexp, rpcty] type mxgpu = { - physical_function: address option; (* unused; promoted to Vgpu.t *) + physical_function: address option; (** unused; promoted to Vgpu.t *) vgpus_per_pgpu: int64; framebufferbytes: int64; } [@@deriving sexp, rpcty] @@ -155,8 +155,8 @@ module Vm = struct [@@deriving rpcty, sexp] type scheduler_params = { - priority: (int * int) option; (* weight, cap *) - affinity: int list list (* vcpu -> pcpu list *) + priority: (int * int) option; (** weight, cap *) + affinity: int list list (** vcpu -> pcpu list *) } [@@deriving rpcty, sexp] type t = { @@ -172,8 +172,8 @@ module Vm = struct memory_static_max: int64; memory_dynamic_max: int64; memory_dynamic_min: int64; - vcpu_max: int; (* boot-time maximum *) - vcpus: int; (* ideal number to use *) + vcpu_max: int; (** boot-time maximum *) + vcpus: int; (** ideal number to use *) scheduler_params: scheduler_params; on_crash: action list; on_shutdown: action list; @@ -208,8 +208,8 @@ module Vm = struct memory_target: int64; memory_actual: int64; memory_limit: int64; - vcpu_target: int; (* actual number of vcpus *) - shadow_multiplier_target: float; (* actual setting *) + vcpu_target: int; (** actual number of vcpus *) + shadow_multiplier_target: float; (** actual setting *) rtc_timeoffset: string; uncooperative_balloon_driver: bool; guest_agent: (string * string) list; @@ -217,8 +217,8 @@ module Vm = struct pv_drivers_detected: bool; last_start_time: float; hvm: bool; - nomigrate: bool; (* true: VM must not migrate *) - nested_virt: bool; (* true: VM uses nested virtualisation *) + nomigrate: bool; (** true means VM must not migrate *) + nested_virt: bool; (** true means VM uses nested virtualisation *) domain_type: domain_type; } [@@deriving rpcty, sexp] From 984015066fcd2297a7fadb3d1b941278e4bb2c0c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 Apr 2020 13:36:28 +0100 Subject: [PATCH 07/42] Maintenance: add ocamlformat configuration Signed-off-by: Pau Ruiz Safont --- .ocamlformat | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 00000000..b4d356a7 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,9 @@ +profile=ocamlformat +version=0.14.1 +indicate-multiline-delimiters=closing-on-separate-line +if-then-else=fit-or-vertical +dock-collection-brackets=true +break-struct=natural +break-separators=before +break-infix=fit-or-vertical +break-infix-before-func=false From dcb108fbac6cfbef18d187161d540ef6e3591158 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 Apr 2020 14:47:15 +0100 Subject: [PATCH 08/42] maintenance: update dune to 2.0 using `dune upgrade` and tweaking the output to reduce the diff Signed-off-by: Pau Ruiz Safont --- cluster/dune | 44 ++++++------- dune-project | 5 +- example/dune | 25 ++++---- gpumon/dune | 49 +++++++------- lib/dune | 80 +++++++++++------------ lib_test/dune | 60 +++++++---------- memory/dune | 51 +++++++-------- misc/dune | 19 +++--- network/dune | 51 +++++++-------- rrd/dune | 106 +++++++++++++++--------------- storage/dune | 128 +++++++++++++++++-------------------- v6/dune | 51 +++++++-------- varstore/deprivileged/dune | 40 +++++++----- varstore/privileged/dune | 39 ++++++----- xen/dune | 74 ++++++++++----------- 15 files changed, 390 insertions(+), 432 deletions(-) diff --git a/cluster/dune b/cluster/dune index ab04221f..ac4d09be 100644 --- a/cluster/dune +++ b/cluster/dune @@ -1,27 +1,27 @@ (library - (name xcp_cluster) - (public_name xapi-idl.cluster) - (modules (:standard \ cluster_cli)) - (flags (:standard -w -39)) - (libraries xapi-idl threads rpclib.core) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_cluster) + (public_name xapi-idl.cluster) + (modules (:standard \ cluster_cli)) + (flags (:standard -w -39)) + (libraries + xapi-idl + threads + rpclib.core + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name cluster_cli) - (modules cluster_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.cluster - ) -) + (name cluster_cli) + (modules cluster_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.cluster)) -(alias - (name runtest) - (deps (:x cluster_cli.exe)) - (action (run %{x})) -) +(rule + (alias runtest) + (deps (:x cluster_cli.exe)) + (action (run %{x}))) diff --git a/dune-project b/dune-project index 42bd9c40..50497862 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,5 @@ -(lang dune 1.9) +(lang dune 2.0) + (allow_approximate_merlin) + +(formatting (enabled_for ocaml)) diff --git a/example/dune b/example/dune index 21659d67..edd4cb64 100644 --- a/example/dune +++ b/example/dune @@ -1,16 +1,13 @@ - (executable - (name example) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-idl - ) - (preprocess (pps ppx_deriving_rpc )) -) + (name example) + (flags (:standard -w -39)) + (libraries + rpclib.core + xapi-idl + ) + (preprocess (pps ppx_deriving_rpc))) -(alias - (name runtest) - (deps (:x example.exe)) - (action (run %{x})) -) +(rule + (alias runtest) + (deps (:x example.exe)) + (action (run %{x}))) diff --git a/gpumon/dune b/gpumon/dune index 1058963e..5a7d2672 100644 --- a/gpumon/dune +++ b/gpumon/dune @@ -1,31 +1,26 @@ - (library - (name xapi_gpumon) - (public_name xapi-idl.gpumon) - (flags (:standard -w -39-33)) - (modules (:standard \ gpumon_cli )) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xapi_gpumon) + (public_name xapi-idl.gpumon) + (flags (:standard -w -39-33)) + (modules (:standard \ gpumon_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name gpumon_cli) - (modules gpumon_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.gpumon - ) -) + (name gpumon_cli) + (modules gpumon_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.gpumon)) -(alias - (name runtest) - (deps (:x gpumon_cli.exe)) - (action (run %{x})) -) +(rule + (alias runtest) + (deps (:x gpumon_cli.exe)) + (action (run %{x}))) diff --git a/lib/dune b/lib/dune index afb059d8..079181b4 100644 --- a/lib/dune +++ b/lib/dune @@ -1,43 +1,43 @@ - (library - (name xcp) - (public_name xapi-idl) - (flags (:standard -w -39 -warn-error -3)) - (modules (:standard \ scheduler task_server updates)) - (c_names syslog_stubs) - (libraries - astring - cmdliner - cohttp - fd-send-recv - logs - message-switch-core - message-switch-unix - ppx_sexp_conv.runtime-lib - re - rpclib.core - rpclib.xml - sexplib - threads - unix - uri - xapi-backtrace - xapi-stdext-monadic - xapi-stdext-pervasives - xapi-stdext-threads - xapi-inventory - xmlm - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc )) -) + (name xcp) + (public_name xapi-idl) + (flags (:standard -w -39 -warn-error -3)) + (modules (:standard \ scheduler task_server updates)) + (foreign_stubs + (language c) + (names syslog_stubs)) + (libraries + astring + cmdliner + cohttp + fd-send-recv + logs + message-switch-core + message-switch-unix + ppx_sexp_conv.runtime-lib + re + rpclib.core + rpclib.json + rpclib.xml + sexplib + threads + unix + uri + xapi-backtrace + xapi-stdext-monadic + xapi-stdext-pervasives + xapi-stdext-threads + xapi-inventory + xmlm + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (library - (name xcp_updates) - (public_name xapi-idl.updates) - (flags (:standard -w -39)) - (modules updates task_server scheduler) - (libraries xapi-idl) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_updates) + (public_name xapi-idl.updates) + (flags (:standard -w -39)) + (modules updates task_server scheduler) + (libraries xapi-idl) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) diff --git a/lib_test/dune b/lib_test/dune index 394e2e23..9fd12b09 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -1,37 +1,23 @@ - -(executables - (names test) - (flags (:standard -w -39)) - (libraries - alcotest - rpclib.core - rpclib.markdown - threads - xapi-idl - xapi-idl.cluster - xapi-idl.rrd - xapi-idl.memory - xapi-idl.updates - xapi-idl.network - xapi-idl.gpumon - xapi-idl.storage - xapi-idl.varstore.privileged - xapi-idl.varstore.deprivileged - xapi-idl.v6 - xapi-idl.xen - ) - (preprocess (pps ppx_deriving_rpc )) -) - -(alias - (name runtest) - (deps (:x test.exe) (source_tree test_data)) - (action (run %{x})) -) - -(alias - (name runtest-quick) - (deps (:x test.exe) (source_tree test_data)) - (action (run %{x} -q)) -) - +(test + (name test) + (deps (source_tree test_data)) + (flags (:standard -w -39)) + (libraries + alcotest + rpclib.core + rpclib.markdown + threads + xapi-idl + xapi-idl.cluster + xapi-idl.rrd + xapi-idl.memory + xapi-idl.updates + xapi-idl.network + xapi-idl.gpumon + xapi-idl.storage + xapi-idl.varstore.privileged + xapi-idl.varstore.deprivileged + xapi-idl.v6 + xapi-idl.xen + ) + (preprocess (pps ppx_deriving_rpc))) diff --git a/memory/dune b/memory/dune index a8b816b0..cf1e39ae 100644 --- a/memory/dune +++ b/memory/dune @@ -1,32 +1,27 @@ - (library - (name xcp_memory) - (public_name xapi-idl.memory) - (flags (:standard -w -39)) - (modules (:standard \ memory_cli)) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_memory) + (public_name xapi-idl.memory) + (flags (:standard -w -39)) + (modules (:standard \ memory_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name memory_cli) - (modules memory_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.memory - ) -) - -(alias - (name runtest) - (deps (:x memory_cli.exe)) - (action (run %{x})) -) + (name memory_cli) + (modules memory_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.memory + )) +(rule + (alias runtest) + (deps (:x memory_cli.exe)) + (action (run %{x}))) diff --git a/misc/dune b/misc/dune index 828e2c25..60dc72dd 100644 --- a/misc/dune +++ b/misc/dune @@ -1,11 +1,10 @@ (executable - (name channel_helper) - (modules channel_helper) - (libraries - cmdliner - lwt - lwt.unix - xapi-idl - ) - (preprocess (pps ppx_deriving_rpc)) -) + (name channel_helper) + (modules channel_helper) + (libraries + cmdliner + lwt + lwt.unix + xapi-idl + ) + (preprocess (pps ppx_deriving_rpc))) diff --git a/network/dune b/network/dune index 5fa0131d..c4f30b67 100644 --- a/network/dune +++ b/network/dune @@ -1,32 +1,27 @@ - (library - (name xcp_network) - (public_name xapi-idl.network) - (flags (:standard -w -39-33)) - (modules (:standard \ network_cli)) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_network) + (public_name xapi-idl.network) + (flags (:standard -w -39-33)) + (modules (:standard \ network_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name network_cli) - (modules network_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.network - ) -) - -(alias - (name runtest) - (deps (:x network_cli.exe)) - (action (run %{x})) -) + (name network_cli) + (modules network_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.network + )) +(rule + (alias runtest) + (deps (:x network_cli.exe)) + (action (run %{x}))) diff --git a/rrd/dune b/rrd/dune index 0453555b..99763bb1 100644 --- a/rrd/dune +++ b/rrd/dune @@ -1,65 +1,59 @@ - (library - (name xcp_rrd_interface_types) - (public_name xapi-idl.rrd.interface.types) - (modules data_source) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-rrd - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_rrd_interface_types) + (public_name xapi-idl.rrd.interface.types) + (modules data_source) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-rrd + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (library - (name xcp_rrd_interface) - (public_name xapi-idl.rrd.interface) - (modules rrd_interface) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-rrd - threads - xapi-idl - xapi-idl.rrd.interface.types - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_rrd_interface) + (public_name xapi-idl.rrd.interface) + (modules rrd_interface) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.rrd.interface.types + xapi-rrd + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (library - (name xcp_rrd) - (public_name xapi-idl.rrd) - (modules (:standard \ data_source rrd_interface rrd_cli)) - (flags (:standard -w -39)) - (libraries - rpclib.core - xapi-rrd - threads - xapi-idl - xapi-idl.rrd.interface - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_rrd) + (public_name xapi-idl.rrd) + (modules (:standard \ data_source rrd_interface rrd_cli)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.rrd.interface + xapi-rrd + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name rrd_cli) - (modules rrd_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.rrd - ) -) + (name rrd_cli) + (modules rrd_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.rrd + )) -(alias - (name runtest) - (deps (:x rrd_cli.exe)) - (action (run %{x})) -) +(rule + (alias runtest) + (deps (:x rrd_cli.exe)) + (action (run %{x}))) diff --git a/storage/dune b/storage/dune index 4706982d..855e79d5 100644 --- a/storage/dune +++ b/storage/dune @@ -1,76 +1,68 @@ (library - (name xcp_storage_interface_types) - (public_name xapi-idl.storage.interface.types) - (flags (:standard -w -39)) - (modules vdi_automaton) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name xcp_storage_interface_types) + (public_name xapi-idl.storage.interface.types) + (flags (:standard -w -39)) + (modules vdi_automaton) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (library - (name xcp_storage_interface) - (public_name xapi-idl.storage.interface) - (flags (:standard -w -39)) - (modules storage_interface) - (libraries - astring - rpclib.core - threads - xapi-stdext-date - xapi-idl - xapi-idl.storage.interface.types - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name xcp_storage_interface) + (public_name xapi-idl.storage.interface) + (flags (:standard -w -39)) + (modules storage_interface) + (libraries + astring + rpclib.core + threads + xapi-stdext-date + xapi-idl + xapi-idl.storage.interface.types + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (library - (name xcp_storage) - (public_name xapi-idl.storage) - (flags (:standard -w -39)) - (modules (:standard \ storage_interface storage_test vdi_automaton suite vdi_automaton_test)) - (libraries - rpclib.core - threads - xapi-stdext-date - xapi-idl - xapi-idl.storage.interface - ) - (wrapped false) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name xcp_storage) + (public_name xapi-idl.storage) + (flags (:standard -w -39)) + (modules + (:standard \ storage_interface storage_test vdi_automaton suite + vdi_automaton_test)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.storage.interface + xapi-stdext-date + ) + (wrapped false) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) (executable - (name storage_test) - (flags (:standard -w -39)) - (modules storage_test) - (libraries - cmdliner - alcotest - xapi-idl - xapi-idl.storage - ) - (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)) -) + (name storage_test) + (flags (:standard -w -39)) + (modules storage_test) + (libraries + alcotest + cmdliner + xapi-idl + xapi-idl.storage + ) + (preprocess (pps ppx_sexp_conv ppx_deriving_rpc))) -(executable - (name suite) - (flags (:standard -w -39)) - (modules suite vdi_automaton_test) - (libraries - alcotest - xapi-idl.storage.interface - xapi-idl.storage.interface.types - ) -) - -(alias - (name runtest) - (deps (:x suite.exe) storage_test.exe) - (action (run %{x})) -) +(test + (name suite) + (flags (:standard -w -39)) + (modules suite vdi_automaton_test) + (libraries + alcotest + xapi-idl.storage.interface + xapi-idl.storage.interface.types + ) + (deps storage_test.exe)) diff --git a/v6/dune b/v6/dune index ba51474d..8cf782c6 100644 --- a/v6/dune +++ b/v6/dune @@ -1,32 +1,27 @@ - (library - (name xcp_v6) - (public_name xapi-idl.v6) - (flags (:standard -w -39)) - (modules (:standard \ v6_cli )) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc )) -) + (name xcp_v6) + (public_name xapi-idl.v6) + (flags (:standard -w -39)) + (modules (:standard \ v6_cli)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name v6_cli) - (modules v6_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.v6 - ) -) - -(alias - (name runtest) - (deps (:x v6_cli.exe)) - (action (run %{x})) -) + (name v6_cli) + (modules v6_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.v6 + )) +(rule + (alias runtest) + (deps (:x v6_cli.exe)) + (action (run %{x}))) diff --git a/varstore/deprivileged/dune b/varstore/deprivileged/dune index 42659e20..0722d5df 100644 --- a/varstore/deprivileged/dune +++ b/varstore/deprivileged/dune @@ -1,22 +1,28 @@ (library - (name xapi_idl_varstore_deprivileged) - (public_name xapi-idl.varstore.deprivileged) - (modules (:standard \ varstore_deprivileged_cli)) - (flags (:standard -w -39)) - (libraries xcp threads rpclib.core xapi-idl.xen) - (wrapped false) - (preprocess (pps ppx_deriving_rpc))) + (name xapi_idl_varstore_deprivileged) + (public_name xapi-idl.varstore.deprivileged) + (modules (:standard \ varstore_deprivileged_cli)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl.xen + xcp + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name varstore_deprivileged_cli) - (modules varstore_deprivileged_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.varstore.deprivileged)) + (name varstore_deprivileged_cli) + (modules varstore_deprivileged_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.varstore.deprivileged + )) -(alias - (name runtest) - (deps varstore_deprivileged_cli.exe) +(rule + (alias runtest) + (deps varstore_deprivileged_cli.exe) (action (run %{deps}))) diff --git a/varstore/privileged/dune b/varstore/privileged/dune index c79ef6b5..5c8d8832 100644 --- a/varstore/privileged/dune +++ b/varstore/privileged/dune @@ -1,22 +1,27 @@ (library - (name xapi_idl_varstore_privileged) - (public_name xapi-idl.varstore.privileged) - (modules (:standard \ varstore_privileged_cli)) - (flags (:standard -w -39)) - (libraries xcp threads rpclib.core) - (wrapped false) - (preprocess (pps ppx_deriving_rpc))) + (name xapi_idl_varstore_privileged) + (public_name xapi-idl.varstore.privileged) + (modules (:standard \ varstore_privileged_cli)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xcp + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc))) (executable - (name varstore_privileged_cli) - (modules varstore_privileged_cli) - (libraries - cmdliner - rpclib.cmdliner - rpclib.markdown - xapi-idl.varstore.privileged)) + (name varstore_privileged_cli) + (modules varstore_privileged_cli) + (libraries + cmdliner + rpclib.cmdliner + rpclib.markdown + xapi-idl.varstore.privileged + )) -(alias - (name runtest) - (deps varstore_privileged_cli.exe) +(rule + (alias runtest) + (deps varstore_privileged_cli.exe) (action (run %{deps}))) diff --git a/xen/dune b/xen/dune index 336b1bf9..abd8acf6 100644 --- a/xen/dune +++ b/xen/dune @@ -1,44 +1,40 @@ - (library - (name xcp_xen_interface_types) - (public_name xapi-idl.xen.interface.types) - (modules xenops_types device_number) - (flags (:standard -w -39-32)) - (libraries - rpclib.core - threads - xapi-idl - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv )) -) + (name xcp_xen_interface_types) + (public_name xapi-idl.xen.interface.types) + (modules xenops_types device_number) + (flags (:standard -w -39-32)) + (libraries + rpclib.core + threads + xapi-idl + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) (library - (name xcp_xen_interface) - (public_name xapi-idl.xen.interface) - (modules xenops_interface) - (flags (:standard -w -39)) - (libraries - rpclib.core - threads - xapi-idl - xapi-idl.xen.interface.types - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv )) -) + (name xcp_xen_interface) + (public_name xapi-idl.xen.interface) + (modules xenops_interface) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.xen.interface.types + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) (library - (name xcp_xen) - (public_name xapi-idl.xen) - (modules (:standard \ device_number xenops_interface xenops_types)) - (flags (:standard -w -39)) - (libraries - rpclib.core - threads - xapi-idl - xapi-idl.xen.interface - ) - (wrapped false) - (preprocess (pps ppx_deriving_rpc ppx_sexp_conv )) -) + (name xcp_xen) + (public_name xapi-idl.xen) + (modules (:standard \ device_number xenops_interface xenops_types)) + (flags (:standard -w -39)) + (libraries + rpclib.core + threads + xapi-idl + xapi-idl.xen.interface + ) + (wrapped false) + (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))) From ff39018fd6d91985f9c893a56928771dfe9fa48d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 Apr 2020 14:48:19 +0100 Subject: [PATCH 09/42] format: format using ocamlformat 0.14 with the command `make format` Signed-off-by: Pau Ruiz Safont --- Makefile | 4 + cluster/cluster_cli.ml | 23 +- cluster/cluster_client.ml | 17 +- cluster/cluster_interface.ml | 267 +-- example/example.ml | 86 +- gpumon/gpumon_cli.ml | 32 +- gpumon/gpumon_client.ml | 16 +- gpumon/gpumon_interface.ml | 200 +-- lib/cohttp_posix_io.ml | 133 +- lib/coverage/disabled.ml | 1 + lib/coverage/enabled.ml | 150 +- lib/debug.ml | 264 +-- lib/debug.mli | 52 +- lib/open_uri.ml | 56 +- lib/posix_channel.ml | 312 ++-- lib/posix_channel.mli | 10 +- lib/scheduler.ml | 291 ++-- lib/scheduler.mli | 59 +- lib/syslog.ml | 153 +- lib/syslog.mli | 15 +- lib/task_server.ml | 480 +++--- lib/task_server.mli | 182 +- lib/updates.ml | 433 ++--- lib/updates.mli | 158 +- lib/xcp_channel.ml | 3 +- lib/xcp_channel.mli | 15 +- lib/xcp_channel_protocol.ml | 8 +- lib/xcp_channel_protocol.mli | 10 +- lib/xcp_client.ml | 194 ++- lib/xcp_const.ml | 3 +- lib/xcp_pci.ml | 15 +- lib/xcp_service.ml | 954 ++++++----- lib/xcp_service.mli | 59 +- lib_test/channel_test.ml | 46 +- lib_test/cluster_interface_test.ml | 8 +- lib_test/config_file_test.ml | 42 +- lib_test/debug_test.ml | 116 +- lib_test/device_number_test.ml | 157 +- lib_test/gpumon_interface_test.ml | 8 +- lib_test/http_test.ml | 34 +- lib_test/idl_test_common.ml | 484 +++--- lib_test/memory_interface_test.ml | 9 +- lib_test/network_interface_test.ml | 10 +- lib_test/rrd_interface_test.ml | 8 +- lib_test/scheduler_test.ml | 101 +- lib_test/storage_interface_test.ml | 8 +- lib_test/syslog_test.ml | 34 +- lib_test/task_server_test.ml | 456 ++--- lib_test/test.ml | 49 +- lib_test/updates_test.ml | 269 +-- lib_test/v6_interface_test.ml | 8 +- lib_test/varstore_interfaces_test.ml | 29 +- lib_test/xen_test.ml | 54 +- memory/memory.ml | 169 +- memory/memory_cli.ml | 32 +- memory/memory_client.ml | 13 +- memory/memory_interface.ml | 343 ++-- misc/channel_helper.ml | 219 ++- network/network_cli.ml | 31 +- network/network_client.ml | 35 +- network/network_interface.ml | 734 ++++---- network/network_stats.ml | 139 +- rrd/data_source.ml | 36 +- rrd/ds.ml | 47 +- rrd/rrd_cli.ml | 26 +- rrd/rrd_client.ml | 38 +- rrd/rrd_interface.ml | 647 ++++--- storage/storage_client.ml | 31 +- storage/storage_interface.ml | 1502 ++++++++++------- storage/storage_skeleton.ml | 101 +- storage/storage_skeleton_test.ml | 2 +- storage/storage_test.ml | 260 ++- storage/suite.ml | 15 +- storage/vdi_automaton.ml | 196 ++- storage/vdi_automaton_test.ml | 34 +- v6/v6_cli.ml | 31 +- v6/v6_client.ml | 39 +- v6/v6_interface.ml | 179 +- .../deprivileged/varstore_deprivileged_cli.ml | 14 +- .../varstore_deprivileged_interface.ml | 47 +- .../privileged/varstore_privileged_cli.ml | 27 +- .../privileged/varstore_privileged_client.ml | 4 +- .../varstore_privileged_interface.ml | 80 +- xen/device_number.ml | 345 ++-- xen/device_number.mli | 53 +- xen/xenops_client.ml | 85 +- xen/xenops_interface.ml | 312 ++-- xen/xenops_types.ml | 270 ++- 88 files changed, 7116 insertions(+), 5605 deletions(-) diff --git a/Makefile b/Makefile index b92b3bd0..b59de680 100644 --- a/Makefile +++ b/Makefile @@ -34,6 +34,10 @@ doc: gh-pages: bash .docgen.sh +# requires ocamlformat +format: + dune build @fmt --auto-promote + reindent: git ls-files '*.ml' '*.mli' | xargs ocp-indent --syntax cstruct -i diff --git a/cluster/cluster_cli.ml b/cluster/cluster_cli.ml index 2066de98..1dede1e3 100644 --- a/cluster/cluster_cli.ml +++ b/cluster/cluster_cli.ml @@ -2,21 +2,28 @@ open Cluster_interface -module Cmds = LocalAPI(Cmdlinergen.Gen ()) +module Cmds = LocalAPI (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the cluster API. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "cluster_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the cluster API. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "cluster_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = let rpc = Cluster_client.rpc_internal Cluster_client.json_url in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) let _ = cli () diff --git a/cluster/cluster_client.ml b/cluster/cluster_client.ml index 8d0f056f..18a8260e 100644 --- a/cluster/cluster_client.ml +++ b/cluster/cluster_client.ml @@ -1,17 +1,18 @@ let json_url () = "file:" ^ Cluster_interface.json_path -let json_http_rpc = Xcp_client.http_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string +let json_http_rpc = + Xcp_client.http_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string -module IDL = Idl.Make(Idl.IdM) +module IDL = Idl.Make (Idl.IdM) let rpc_internal url call = - if !Xcp_client.use_switch - then Xcp_client.json_switch_rpc Cluster_interface.queue_name call - else json_http_rpc ~srcstr:"clusterd" ~dststr:"clusterd" url call + if !Xcp_client.use_switch then + Xcp_client.json_switch_rpc Cluster_interface.queue_name call + else + json_http_rpc ~srcstr:"clusterd" ~dststr:"clusterd" url call -let rpc url call = - rpc_internal url call |> Idl.IdM.return +let rpc url call = rpc_internal url call |> Idl.IdM.return (* There is also a Remote API between clustering daemons on different hosts. * Call this a Local API because it is an API inside a host *) -module LocalClient = Cluster_interface.LocalAPI(IDL.GenClient ()) +module LocalClient = Cluster_interface.LocalAPI (IDL.GenClient ()) diff --git a/cluster/cluster_interface.ml b/cluster/cluster_interface.ml index b955b466..e87201ac 100644 --- a/cluster/cluster_interface.ml +++ b/cluster/cluster_interface.ml @@ -3,209 +3,232 @@ open Idl let service_name = "cluster" + let queue_name = Xcp_service.common_prefix ^ service_name + let json_path = "/var/xapi/cluster.json" (** An uninterpreted string associated with the operation. *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] (** Name of the cluster *) -type cluster_name = string -[@@deriving rpcty] +type cluster_name = string [@@deriving rpcty] (** An IPv4 address (a.b.c.d) *) -type address = IPv4 of string -[@@deriving rpcty] -let printaddr () = function | IPv4 s -> Printf.sprintf "IPv4(%s)" s +type address = IPv4 of string [@@deriving rpcty] + +let printaddr () = function IPv4 s -> Printf.sprintf "IPv4(%s)" s + let str_of_address address = match address with IPv4 a -> a type addresslist = address list [@@deriving rpcty] type nodeid = int32 [@@deriving rpcty] + type start = bool [@@deriving rpcty] let string_of_nodeid = Int32.to_string -(** This type describes an individual node in the cluster. It must have - a unique identity (an int32), and may have multiple IPv4 addresses on - which it can be contacted. *) -type node = { - addr: address; - id: nodeid; -} -[@@deriving rpcty] +(** This type describes an individual node in the cluster. It must have a unique + identity (an int32), and may have multiple IPv4 addresses on which it can be + contacted. *) +type node = {addr: address; id: nodeid} [@@deriving rpcty] type all_members = node list [@@deriving rpcty] -(** This type contains all of the information required to initialise - the cluster. All optional params will have the recommended defaults - if None. *) +(** This type contains all of the information required to initialise the + cluster. All optional params will have the recommended defaults if None. *) type init_config = { - local_ip : address; - token_timeout_ms : int64 option; - token_coefficient_ms : int64 option; - name : string option; + local_ip: address + ; token_timeout_ms: int64 option + ; token_coefficient_ms: int64 option + ; name: string option } [@@deriving rpcty] -(** This type contains all of the information required to configure - the cluster. This includes all details required for the corosync - configuration as well as anything else required for pacemaker and - SBD. All nodes have a local copy of this and we take pains to - ensure it is kept in sync. *) +(** This type contains all of the information required to configure the cluster. + This includes all details required for the corosync configuration as well as + anything else required for pacemaker and SBD. All nodes have a local copy of + this and we take pains to ensure it is kept in sync. *) type cluster_config = { - cluster_name : string; - enabled_members : node list; - authkey: string; - config_version: int64; - cluster_token_timeout_ms : int64; - cluster_token_coefficient_ms : int64; + cluster_name: string + ; enabled_members: node list + ; authkey: string + ; config_version: int64 + ; cluster_token_timeout_ms: int64 + ; cluster_token_coefficient_ms: int64 } [@@deriving rpcty] -type cluster_config_and_all_members = cluster_config * all_members [@@deriving rpcty] +type cluster_config_and_all_members = cluster_config * all_members +[@@deriving rpcty] -(** This type contains diagnostic information about the current state - of the cluster daemon. All state required for test purposes should - be in this type. *) +(** This type contains diagnostic information about the current state of the + cluster daemon. All state required for test purposes should be in this type. *) type diagnostics = { - config_valid : bool; - live_cluster_config : cluster_config option; (** live corosync config *) - next_cluster_config : cluster_config option; (** next corosync config *) - saved_cluster_config : cluster_config option; (** xapi-clusterd DB *) - is_enabled : bool; - all_members : all_members option; - node_id : nodeid option; - token : string option; - num_times_booted : int; - is_quorate : bool; - is_running : bool; - startup_finished : bool; + config_valid: bool + ; live_cluster_config: cluster_config option (** live corosync config *) + ; next_cluster_config: cluster_config option (** next corosync config *) + ; saved_cluster_config: cluster_config option (** xapi-clusterd DB *) + ; is_enabled: bool + ; all_members: all_members option + ; node_id: nodeid option + ; token: string option + ; num_times_booted: int + ; is_quorate: bool + ; is_running: bool + ; startup_finished: bool } [@@deriving rpcty] (** This secret token is used to authenticate remote API calls on a cluster *) -type token = string -[@@deriving rpcty] +type token = string [@@deriving rpcty] let token_p = Param.mk ~name:"token" token -type error = - | InternalError of string - | Unix_error of string -[@@deriving rpcty] +type error = InternalError of string | Unix_error of string [@@deriving rpcty] -module E = Error.Make(struct +module E = Error.Make (struct type t = error [@@deriving rpcty] + let internal_error_of _ = None - end) +end) + let err = E.error type named_unit = unit [@@deriving rpcty] + type my_string = string [@@deriving rpcty] +let unit_p = Param.mk ~name:"unit" ~description:["unit"] named_unit + +let string_p = Param.mk ~name:"string" ~description:["string"] my_string + +let address_p = + Param.mk ~name:"address" + ~description:["IPv4 address of a cluster member"] + address -let unit_p = Param.mk ~name:"unit" ~description:["unit"] named_unit -let string_p = Param.mk ~name:"string" ~description:["string"] my_string -let address_p = Param.mk ~name:"address" ~description:[ - "IPv4 address of a cluster member"; - ] address -let init_config_p = Param.mk ~name:"init_config" ~description:[ - "The initial config of the cluster member"; - ] init_config +let init_config_p = + Param.mk ~name:"init_config" + ~description:["The initial config of the cluster member"] + init_config -let debug_info_p = Param.mk ~name:"dbg" ~description:[ - "An uninterpreted string to associate with the operation." - ] debug_info +let debug_info_p = + Param.mk ~name:"dbg" + ~description:["An uninterpreted string to associate with the operation."] + debug_info type remove = bool [@@deriving rpcty] -module LocalAPI(R:RPC) = struct +module LocalAPI (R : RPC) = struct open R - let description = Interface.{ - name = "Local"; - namespace = None; - description = [ - "Local Cluster APIs. These are intended to be used to control the xapi-clusterd service"; - "There is no authentication on these, but they are only available on the local machine."; - ]; - version = (1,0,0); - } + let description = + Interface. + { + name= "Local" + ; namespace= None + ; description= + [ + "Local Cluster APIs. These are intended to be used to control the \ + xapi-clusterd service" + ; "There is no authentication on these, but they are only available \ + on the local machine." + ] + ; version= (1, 0, 0) + } let implementation = implement description - let create = declare - "create" - ["Creates the cluster. The call takes the initial config of"; - "the initial host to add to the cluster. This will be the"; - "address on which the rings will be created."] + let create = + declare "create" + [ + "Creates the cluster. The call takes the initial config of" + ; "the initial host to add to the cluster. This will be the" + ; "address on which the rings will be created." + ] (debug_info_p @-> init_config_p @-> returning token_p err) - let destroy = declare - "destroy" + let destroy = + declare "destroy" ["Destroys a created cluster"] (debug_info_p @-> returning unit_p err) - let leave = declare - "leave" - ["Causes this host to permanently leave the cluster, but leaves the rest of the cluster"; - "enabled. This is not a temporary removal - if the admin wants the hosts to rejoin the cluster again,"; - "he will have to call `join` rather than `enable`."] + let leave = + declare "leave" + [ + "Causes this host to permanently leave the cluster, but leaves the \ + rest of the cluster" + ; "enabled. This is not a temporary removal - if the admin wants the \ + hosts to rejoin the cluster again," + ; "he will have to call `join` rather than `enable`." + ] (debug_info_p @-> returning unit_p err) - let disable = declare - "disable" - ["Stop the cluster on this host; leave the rest of the cluster"; - "enabled. The cluster can be reenabled either by restarting the"; - "host, or by calling the `enable` API call."] + let disable = + declare "disable" + [ + "Stop the cluster on this host; leave the rest of the cluster" + ; "enabled. The cluster can be reenabled either by restarting the" + ; "host, or by calling the `enable` API call." + ] (debug_info_p @-> returning unit_p err) let enable = - declare - "enable" - ["Rejoins the cluster following a call to `disable`. The parameter"; - "passed is the cluster config to use (optional fields set to None"; - "unless updated) in case it changed while the host was disabled."; - "(Note that changing optional fields isn't yet supported, TODO)"] + declare "enable" + [ + "Rejoins the cluster following a call to `disable`. The parameter" + ; "passed is the cluster config to use (optional fields set to None" + ; "unless updated) in case it changed while the host was disabled." + ; "(Note that changing optional fields isn't yet supported, TODO)" + ] (debug_info_p @-> init_config_p @-> returning unit_p err) let join = let new_p = Param.mk ~name:"new_member" address in let existing_p = Param.mk ~name:"existing_members" addresslist in - declare - "join" - ["Adds a node to an initialised cluster. Takes the IPv4 address of"; - "the new member and a list of the addresses of all the existing"; - "members."] - (debug_info_p @-> token_p @-> new_p @-> existing_p @-> returning unit_p err) + declare "join" + [ + "Adds a node to an initialised cluster. Takes the IPv4 address of" + ; "the new member and a list of the addresses of all the existing" + ; "members." + ] + (debug_info_p + @-> token_p + @-> new_p + @-> existing_p + @-> returning unit_p err + ) let declare_changed_addrs = let changed_members_p = Param.mk ~name:"changed_members" addresslist in - declare - "declare-changed-addrs" - ["Declare that one or more hosts in the cluster have changed address."; - "Only use this command if unable to rejoin the cluster using `enable`"; - "because the IPv4 addresses of all nodes this node previously saw are now"; - "invalid. If any one of these addresses remains valid on an enabled node"; - "then this action is unnecessary."] + declare "declare-changed-addrs" + [ + "Declare that one or more hosts in the cluster have changed address." + ; "Only use this command if unable to rejoin the cluster using `enable`" + ; "because the IPv4 addresses of all nodes this node previously saw are \ + now" + ; "invalid. If any one of these addresses remains valid on an enabled \ + node" + ; "then this action is unnecessary." + ] (debug_info_p @-> changed_members_p @-> returning unit_p err) let declare_dead = let dead_members_p = Param.mk ~name:"dead_members" addresslist in - declare - "declare-dead" - ["Declare that some hosts in the cluster are permanently dead. Removes"; - "the hosts from the cluster. If the hosts do attempt to rejoin the"; - "cluster in future, this may lead to fencing of other hosts and/or"; - "data loss or data corruption."] + declare "declare-dead" + [ + "Declare that some hosts in the cluster are permanently dead. Removes" + ; "the hosts from the cluster. If the hosts do attempt to rejoin the" + ; "cluster in future, this may lead to fencing of other hosts and/or" + ; "data loss or data corruption." + ] (debug_info_p @-> dead_members_p @-> returning unit_p err) let diagnostics = let diagnostics_p = Param.mk ~name:"diagnostics" diagnostics in - declare - "diagnostics" + declare "diagnostics" ["Returns diagnostic information about the cluster"] (debug_info_p @-> returning diagnostics_p err) end diff --git a/example/example.ml b/example/example.ml index 4619ec25..1e496c19 100644 --- a/example/example.ml +++ b/example/example.ml @@ -15,54 +15,72 @@ open Xcp_service let ls = ref "/bin/ls" + let sh = ref "/bin/sh" -let resources = [ - { Xcp_service.name = "ls"; - description = "program used to list things"; - essential = true; - path = ls; - perms = [ Unix.X_OK ]; - }; { - Xcp_service.name = "sh"; - description = "interpreter for arcane programming language"; - essential = false; - path = sh; - perms = [ Unix.X_OK ]; - } -] +let resources = + [ + { + Xcp_service.name= "ls" + ; description= "program used to list things" + ; essential= true + ; path= ls + ; perms= [Unix.X_OK] + } + ; { + Xcp_service.name= "sh" + ; description= "interpreter for arcane programming language" + ; essential= false + ; path= sh + ; perms= [Unix.X_OK] + } + ] let socket_path = ref "/var/xapi/socket" let comma = Re.Str.regexp_string "," + let csv = Re.Str.split_delim comma -let queues : string list ref = ref [ - "org.xen.xapi.ffs"; -] +let queues : string list ref = ref ["org.xen.xapi.ffs"] let set_default_format _ = () + let get_default_format () = "vhd" let mount_path = ref "/mnt" -let options = [ - "socket-path", Arg.Set_string socket_path, (fun () -> !socket_path), "Path of listening socket"; - "queue-name", Arg.String (fun x -> queues := csv x), (fun () -> String.concat "," !queues), "Comma-separated list of queue names to listen on"; - "default-format", Arg.String set_default_format, get_default_format, "Default format for disk files"; - "sr-mount-path", Arg.Set_string mount_path, (fun () -> !mount_path), "Default mountpoint for mounting remote filesystems"; -] +let options = + [ + ( "socket-path" + , Arg.Set_string socket_path + , (fun () -> !socket_path) + , "Path of listening socket" ) + ; ( "queue-name" + , Arg.String (fun x -> queues := csv x) + , (fun () -> String.concat "," !queues) + , "Comma-separated list of queue names to listen on" ) + ; ( "default-format" + , Arg.String set_default_format + , get_default_format + , "Default format for disk files" ) + ; ( "sr-mount-path" + , Arg.Set_string mount_path + , (fun () -> !mount_path) + , "Default mountpoint for mounting remote filesystems" ) + ] let _ = - Debug.log_to_stdout (); - match configure2 - ~name:"Example-service" - ~version:"1.0" - ~doc:"This is an example service which demonstrates the configuration mechanism." - ~options - ~resources - () with - | `Ok () -> exit 0 + Debug.log_to_stdout () ; + match + configure2 ~name:"Example-service" ~version:"1.0" + ~doc: + "This is an example service which demonstrates the configuration \ + mechanism." + ~options ~resources () + with + | `Ok () -> + exit 0 | `Error m -> - Printf.fprintf stderr "Error: %s\n%!" m; - exit 1 + Printf.fprintf stderr "Error: %s\n%!" m ; + exit 1 diff --git a/gpumon/gpumon_cli.ml b/gpumon/gpumon_cli.ml index 0bc3792f..5c5b06e1 100644 --- a/gpumon/gpumon_cli.ml +++ b/gpumon/gpumon_cli.ml @@ -1,26 +1,28 @@ - (* Gpumon CLI *) -module Cmds = Gpumon_interface.RPC_API(Cmdlinergen.Gen ()) +module Cmds = Gpumon_interface.RPC_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the GPU monitoring API. This allows scripting of the gpumon daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "gpumon_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the GPU monitoring API. This allows scripting of the gpumon \ + daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "gpumon_cli" ~version:(version_str Cmds.description) ~doc + ) let cli () = let rpc = Gpumon_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) - -let _ = - match cli () with - | `Ok f -> f () - | _ -> () + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) +let _ = match cli () with `Ok f -> f () | _ -> () diff --git a/gpumon/gpumon_client.ml b/gpumon/gpumon_client.ml index 7fe18ae8..d6605ff7 100644 --- a/gpumon/gpumon_client.ml +++ b/gpumon/gpumon_client.ml @@ -15,11 +15,13 @@ let xml_url () = "file:" ^ Gpumon_interface.xml_path let rpc call = - if !Xcp_client.use_switch - then Xcp_client.json_switch_rpc Gpumon_interface.queue_name call - else Xcp_client.xml_http_rpc + if !Xcp_client.use_switch then + Xcp_client.json_switch_rpc Gpumon_interface.queue_name call + else + Xcp_client.xml_http_rpc ~srcstr:(Xcp_client.get_user_agent ()) - ~dststr:"gpumon" - xml_url - call -module Client = Gpumon_interface.RPC_API(Idl.Exn.GenClient(struct let rpc=rpc end)) + ~dststr:"gpumon" xml_url call + +module Client = Gpumon_interface.RPC_API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) diff --git a/gpumon/gpumon_interface.ml b/gpumon/gpumon_interface.ml index 0b2f1a5a..aec410a2 100644 --- a/gpumon/gpumon_interface.ml +++ b/gpumon/gpumon_interface.ml @@ -15,192 +15,204 @@ open Rpc open Idl -module D = Debug.Make(struct let name = "gpumon_interface" end) +module D = Debug.Make (struct let name = "gpumon_interface" end) + open D let service_name = "gpumon" + let queue_name = Xcp_service.common_prefix ^ service_name + let xml_path = "/var/xapi/" ^ service_name (** Uninterpreted string associated with the operation *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] (* Domain ID of VM *) -type domid = int -[@@deriving rpcty] +type domid = int [@@deriving rpcty] (** UUID of Nvidia Virtual GPU *) -type vgpu_uuid = string -[@@deriving rpcty] +type vgpu_uuid = string [@@deriving rpcty] (** Reason for incompatibility *) -type incompatibility_reason = - | Host_driver - | Guest_driver - | GPU - | Other +type incompatibility_reason = Host_driver | Guest_driver | GPU | Other [@@deriving rpcty] (** Compatibility between virtual and physical GPU *) -type compatibility = - | Compatible - | Incompatible of incompatibility_reason list +type compatibility = Compatible | Incompatible of incompatibility_reason list [@@deriving rpcty] (** PCI identifier of physical GPU *) -type pgpu_address = string -[@@deriving rpcty] +type pgpu_address = string [@@deriving rpcty] (** Metadata of Nvidia physical GPU *) -type nvidia_pgpu_metadata = string -[@@deriving rpcty] +type nvidia_pgpu_metadata = string [@@deriving rpcty] (** Metadata of Nvidia virtual GPU *) -type nvidia_vgpu_metadata = string -[@@deriving rpcty] +type nvidia_vgpu_metadata = string [@@deriving rpcty] (** List of Nvidia virtual GPU metadata records *) -type nvidia_vgpu_metadata_list = nvidia_vgpu_metadata list -[@@deriving rpcty] - +type nvidia_vgpu_metadata_list = nvidia_vgpu_metadata list [@@deriving rpcty] (** Error wrapper *) type gpu_errors = | NvmlInterfaceNotAvailable - (** Exception raised when gpumon is unable to load the nvml nvidia library *) + (** Exception raised when gpumon is unable to load the nvml nvidia library *) | NvmlFailure of string - (** Exception raised by the c bindings to the nvml nvidia library*) + (** Exception raised by the c bindings to the nvml nvidia library*) | Internal_error of string - (** Exception raised if an unexpected error is triggered by the library *) - | Gpumon_failure - (** Default exception raised upon daemon failure *) -[@@default Gpumon_failure] -[@@deriving rpcty] + (** Exception raised if an unexpected error is triggered by the library *) + | Gpumon_failure (** Default exception raised upon daemon failure *) +[@@default Gpumon_failure] [@@deriving rpcty] exception Gpumon_error of gpu_errors -let () = (* register printer *) +let () = + (* register printer *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal gpu_errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal gpu_errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | Gpumon_error e -> Some (sprintf "Gpumon_interface.Gpumon_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer (** Error handler *) -let gpu_err = Error. - { def = gpu_errors - ; raiser = (fun e -> - log_backtrace (); - let exn = Gpumon_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | Gpumon_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let gpu_err = + Error. + { + def= gpu_errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = Gpumon_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | Gpumon_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** Functor to autogenerate API calls *) -module RPC_API(R : RPC) = struct +module RPC_API (R : RPC) = struct open R let param = Param.mk let description = - Interface.{ name = "Gpumon" - ; namespace = None - ; description = - [ "This interface is used by Xapi and Gpumon to monitor " - ; "physical and virtual GPUs."] - ; version=(1,0,0) - } + Interface. + { + name= "Gpumon" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and Gpumon to monitor " + ; "physical and virtual GPUs." + ] + ; version= (1, 0, 0) + } let implementation = implement description (** Compatibility checking interface for Nvidia vGPUs *) module Nvidia = struct - (** common API call parameters *) - let debug_info_p = param ~description: - ["Uninterpreted string used for debugging."] - debug_info + let debug_info_p = + param ~description:["Uninterpreted string used for debugging."] debug_info - let domid_p = param ~description: - ["Domain ID of the VM in which the vGPU(s) is running."] + let domid_p = + param + ~description:["Domain ID of the VM in which the vGPU(s) is running."] domid - let vgpu_uuid_p = param ~description: - ["UUID of Nvidia virtual GPU."] - vgpu_uuid + let vgpu_uuid_p = + param ~description:["UUID of Nvidia virtual GPU."] vgpu_uuid - let pgpu_address_p = param ~description: - ["PCI bus ID of the pGPU in which the VM is currently running" - ;"in the form `domain:bus:device.function` PCI identifier."] + let pgpu_address_p = + param + ~description: + [ + "PCI bus ID of the pGPU in which the VM is currently running" + ; "in the form `domain:bus:device.function` PCI identifier." + ] pgpu_address - let nvidia_pgpu_metadata_p = param ~description: - ["Metadata of Nvidia physical GPU."] + let nvidia_pgpu_metadata_p = + param + ~description:["Metadata of Nvidia physical GPU."] nvidia_pgpu_metadata - let nvidia_vgpu_metadata_p = param ~description: - ["Metadata of Nvidia virtual GPU."] + let nvidia_vgpu_metadata_p = + param + ~description:["Metadata of Nvidia virtual GPU."] nvidia_vgpu_metadata - let nvidia_vgpu_metadata_list_p = param ~description: - ["Metadata list of Nvidia virtual GPU."] + let nvidia_vgpu_metadata_list_p = + param + ~description:["Metadata list of Nvidia virtual GPU."] nvidia_vgpu_metadata_list - let compatibility_p = param ~description: - [ "Value indicating whether two or more GPUs are compatible with each other." ] + let compatibility_p = + param + ~description: + [ + "Value indicating whether two or more GPUs are compatible with \ + each other." + ] compatibility let get_pgpu_metadata = declare "get_pgpu_metadata" - [ "Gets the metadata for a pGPU, given its address (PCI bus ID)." ] + ["Gets the metadata for a pGPU, given its address (PCI bus ID)."] (debug_info_p - @-> pgpu_address_p - @-> returning nvidia_pgpu_metadata_p gpu_err + @-> pgpu_address_p + @-> returning nvidia_pgpu_metadata_p gpu_err ) let get_pgpu_vm_compatibility = declare "get_pgpu_vm_compatibility" - [ "Checks compatibility between a VM's vGPU(s) and another pGPU." ] + ["Checks compatibility between a VM's vGPU(s) and another pGPU."] (debug_info_p - @-> pgpu_address_p - @-> domid_p - @-> nvidia_pgpu_metadata_p - @-> returning compatibility_p gpu_err + @-> pgpu_address_p + @-> domid_p + @-> nvidia_pgpu_metadata_p + @-> returning compatibility_p gpu_err ) let get_vgpu_metadata = declare "get_vgpu_metadata" - [ "Obtains metadata for all vGPUs running in a domain." ] - ( debug_info_p - @-> domid_p - @-> pgpu_address_p - @-> vgpu_uuid_p - @-> returning nvidia_vgpu_metadata_list_p gpu_err + ["Obtains metadata for all vGPUs running in a domain."] + (debug_info_p + @-> domid_p + @-> pgpu_address_p + @-> vgpu_uuid_p + @-> returning nvidia_vgpu_metadata_list_p gpu_err ) let get_pgpu_vgpu_compatibility = declare "get_pgpu_vgpu_compatibility" - [ "Checks compatibility between a pGPU (on a host) and a list of vGPUs " + [ + "Checks compatibility between a pGPU (on a host) and a list of vGPUs " ; "(assigned to a VM). Note: A VM may use several vGPUs." ; "The use case is VM.suspend/VM.resume:" ; "before VM.resume [nvidia_vgpu_metadata] of the suspended VM is " ; "checked against the [nvidia_pgpu_metadata] on the host where the VM " - ; "is resumed." ] - ( debug_info_p - @-> nvidia_pgpu_metadata_p - @-> nvidia_vgpu_metadata_list_p - @-> returning compatibility_p gpu_err) + ; "is resumed." + ] + (debug_info_p + @-> nvidia_pgpu_metadata_p + @-> nvidia_vgpu_metadata_list_p + @-> returning compatibility_p gpu_err + ) end end diff --git a/lib/cohttp_posix_io.ml b/lib/cohttp_posix_io.ml index 16e140ec..a24e5155 100644 --- a/lib/cohttp_posix_io.ml +++ b/lib/cohttp_posix_io.ml @@ -17,23 +17,25 @@ module Unbuffered_IO = struct (** Use as few Unix.\{read,write\} calls as we can (for efficiency) without - explicitly buffering the stream beyond the HTTP headers. This will - allow us to consume the headers and then pass the file descriptor - safely to another process *) + explicitly buffering the stream beyond the HTTP headers. This will allow + us to consume the headers and then pass the file descriptor safely to + another process *) type 'a t = 'a - let (>>=) x f = f x - let (>>) m n = m >>= fun _ -> n + let ( >>= ) x f = f x + + let ( >> ) m n = m >>= fun _ -> n let return x = x let iter = List.iter type ic = { - mutable header_buffer: string option; (** buffered headers *) - mutable header_buffer_idx: int; (** next char within the buffered headers *) - fd: Unix.file_descr; (** the underlying file descriptor *) + mutable header_buffer: string option (** buffered headers *) + ; mutable header_buffer_idx: int + (** next char within the buffered headers *) + ; fd: Unix.file_descr (** the underlying file descriptor *) } type oc = Unix.file_descr @@ -46,79 +48,77 @@ module Unbuffered_IO = struct let end_of_headers = "\r\n\r\n" in let tmp = Bytes.make (String.length end_of_headers) '\000' in let module Scanner = struct - type t = { - marker: string; - mutable i: int; - } - let make x = { marker = x; i = 0 } - let input x c = - if c = String.get x.marker x.i then x.i <- x.i + 1 else x.i <- 0 + type t = {marker: string; mutable i: int} + + let make x = {marker= x; i= 0} + + let input x c = if c = x.marker.[x.i] then x.i <- x.i + 1 else x.i <- 0 + let remaining x = String.length x.marker - x.i + let matched x = x.i = String.length x.marker end in let marker = Scanner.make end_of_headers in - - while not(Scanner.matched marker) do - (* We may be part way through reading the end of header marker, so - be pessimistic and only read enough bytes to read until the end of - the marker. *) + while not (Scanner.matched marker) do + (* We may be part way through reading the end of header marker, so be + pessimistic and only read enough bytes to read until the end of the + marker. *) let safe_to_read = Scanner.remaining marker in - let n = Unix.read fd tmp 0 safe_to_read in - if n = 0 then raise End_of_file; - + if n = 0 then raise End_of_file ; for j = 0 to n - 1 do - Scanner.input marker (Bytes.get tmp j); + Scanner.input marker (Bytes.get tmp j) ; Buffer.add_char buf (Bytes.get tmp j) - done; - done; + done + done ; Buffer.contents buf - (* Raises Not_found if there's no crlf *) let rec find_crlf str from = let cr = String.index_from str from '\r' in let lf = String.index_from str cr '\n' in - if lf=cr+1 then cr else find_crlf str cr + if lf = cr + 1 then cr else find_crlf str cr (* We assume read_line is only used to read the HTTP header *) - let rec read_line ic = match ic.header_buffer, ic.header_buffer_idx with - | None, _ -> - ic.header_buffer <- Some (read_http_headers ic.fd); - read_line ic - | Some buf, i when i < (String.length buf) -> - begin + let rec read_line ic = + match (ic.header_buffer, ic.header_buffer_idx) with + | None, _ -> + ic.header_buffer <- Some (read_http_headers ic.fd) ; + read_line ic + | Some buf, i when i < String.length buf -> ( try let eol = find_crlf buf i in let line = String.sub buf i (eol - i) in - ic.header_buffer_idx <- eol + 2; + ic.header_buffer_idx <- eol + 2 ; Some line with Not_found -> Some "" - end - | Some _, _ -> - Some "" + ) + | Some _, _ -> + Some "" let rec read_into_exactly ic buf ofs len = let n = Unix.read ic.fd buf ofs len in let remaining = len - n in - remaining = 0 || (n > 0 && (read_into_exactly ic buf (ofs + n) (len - n))) + remaining = 0 || (n > 0 && read_into_exactly ic buf (ofs + n) (len - n)) let read_exactly ic len = let buf = Bytes.create len in read_into_exactly ic buf 0 len >>= function - | true -> return (Some buf) - | false -> return None + | true -> + return (Some buf) + | false -> + return None let read ic n = let buf = Bytes.make n '\000' in let actually_read = Unix.read ic.fd buf 0 n in - if actually_read = n - then Bytes.unsafe_to_string buf - else Bytes.sub_string buf 0 actually_read + if actually_read = n then + Bytes.unsafe_to_string buf + else + Bytes.sub_string buf 0 actually_read let write oc x = - Unix.write oc (Bytes.unsafe_of_string x) 0 (String.length x) - |> ignore + Unix.write oc (Bytes.unsafe_of_string x) 0 (String.length x) |> ignore let flush _oc = () end @@ -126,41 +126,56 @@ end module Buffered_IO = struct type 'a t = 'a - let (>>=) x f = f x - let (>>) m n = m >>= fun _ -> n + let ( >>= ) x f = f x + + let ( >> ) m n = m >>= fun _ -> n let return x = x let iter = List.iter type ic = in_channel + type oc = out_channel + type conn = unit let read_line ic = try - Some (match input_line ic with - | "" -> "" - | x when x.[String.length x - 1] = '\r' -> String.sub x 0 (String.length x - 1) - | x -> x) + Some + ( match input_line ic with + | "" -> + "" + | x when x.[String.length x - 1] = '\r' -> + String.sub x 0 (String.length x - 1) + | x -> + x + ) with End_of_file -> None - let read_into_exactly ic buf ofs len = try really_input ic buf ofs len; true with _ -> false + let read_into_exactly ic buf ofs len = + try + really_input ic buf ofs len ; + true + with _ -> false let read_exactly ic len = let buf = Bytes.create len in read_into_exactly ic buf 0 len >>= function - | true -> return (Some buf) - | false -> return None + | true -> + return (Some buf) + | false -> + return None let read ic n = let buf = Bytes.make n '\000' in let actually_read = input ic buf 0 n in - if actually_read = n - then Bytes.unsafe_to_string buf - else Bytes.sub_string buf 0 actually_read + if actually_read = n then + Bytes.unsafe_to_string buf + else + Bytes.sub_string buf 0 actually_read - let write oc x = output_string oc x; flush oc + let write oc x = output_string oc x ; flush oc let flush oc = flush oc end diff --git a/lib/coverage/disabled.ml b/lib/coverage/disabled.ml index 65404608..ca9ae41a 100644 --- a/lib/coverage/disabled.ml +++ b/lib/coverage/disabled.ml @@ -1,2 +1,3 @@ let init _ = () + let dispatcher_init _ = () diff --git a/lib/coverage/enabled.ml b/lib/coverage/enabled.ml index fff55d7d..2b05579b 100644 --- a/lib/coverage/enabled.ml +++ b/lib/coverage/enabled.ml @@ -1,117 +1,133 @@ -(** This module sets up the env variable for bisect_ppx which describes - * where log files are written. - *) +(** This module sets up the env variable for bisect_ppx which describes * where + log files are written. *) + +module D = Debug.Make (struct let name = "coverage" end) -module D=Debug.Make(struct let name="coverage" end) let prefix = "org.xen.xapi.coverage" module Bisect = struct let bisect_file = "BISECT_FILE" + let dump jobid = let bisect_prefix = Unix.getenv bisect_file in - (* dump coverage information in same location as it would normally - get dumped on exit, except also embed the jobid to make it easier to group. - Relies on [open_temp_file] generating a unique filename given a prefix/suffix to - avoid clashes with filenames created at exit by bisect itself. *) - let tmp, ch = Filename.open_temp_file - ~temp_dir:(Filename.dirname bisect_prefix) - (Filename.basename bisect_prefix) - (Printf.sprintf ".%Ld.out" jobid) in + (* dump coverage information in same location as it would normally get + dumped on exit, except also embed the jobid to make it easier to group. + Relies on [open_temp_file] generating a unique filename given a + prefix/suffix to avoid clashes with filenames created at exit by bisect + itself. *) + let tmp, ch = + Filename.open_temp_file + ~temp_dir:(Filename.dirname bisect_prefix) + (Filename.basename bisect_prefix) + (Printf.sprintf ".%Ld.out" jobid) + in try - Bisect.Runtime.dump_counters_exn ch; - D.debug "Saved coverage data to %s" tmp; - close_out_noerr ch; + Bisect.Runtime.dump_counters_exn ch ; + D.debug "Saved coverage data to %s" tmp ; + close_out_noerr ch ; (* Keep file - will be collected by XenRT *) tmp with e -> - Sys.remove tmp; - D.warn "Failed to save coverage: %s" (Printexc.to_string e); + Sys.remove tmp ; + D.warn "Failed to save coverage: %s" (Printexc.to_string e) ; raise e let reset () = - Bisect.Runtime.reset_counters (); + Bisect.Runtime.reset_counters () ; D.debug "Coverage counters reset" let init_env name = - let (//) = Filename.concat in - let tmpdir = Filename.get_temp_dir_name () in - try - ignore (Sys.getenv bisect_file) + let ( // ) = Filename.concat in + let tmpdir = Filename.get_temp_dir_name () in + try ignore (Sys.getenv bisect_file) with Not_found -> Unix.putenv bisect_file (tmpdir // Printf.sprintf "bisect-%s-" name) let process body = match Stringext.split ~on:' ' body with - | ["reset"] -> reset (); "" - | ["dump"; jobid] -> jobid |> Int64.of_string |> dump - | _ -> failwith body + | ["reset"] -> + reset () ; "" + | ["dump"; jobid] -> + jobid |> Int64.of_string |> dump + | _ -> + failwith body let init name = - init_env name; + init_env name ; let queue_name = prefix ^ "." ^ name in - let (_:Thread.t) = - Thread.create (Message_switch_unix.Protocol_unix.Server.listen ~process - ~switch:!Xcp_client.switch_path ~queue:queue_name) () in - D.debug "Started coverage API thread on %s" queue_name; + let (_ : Thread.t) = + Thread.create + (Message_switch_unix.Protocol_unix.Server.listen ~process + ~switch:!Xcp_client.switch_path ~queue:queue_name) + () + in + D.debug "Started coverage API thread on %s" queue_name ; () end module Dispatcher = struct let self = prefix ^ ".dispatch" + open Message_switch_unix.Protocol_unix let rpc_ignore_err ~t ~body queue = - D.debug "Dispatching %s to %s" body queue; + D.debug "Dispatching %s to %s" body queue ; match Client.(rpc ~t ~queue ~body () |> error_to_msg) with - | `Ok x -> x + | `Ok x -> + x | `Error (`Msg e) -> - D.info "Failed to get coverage data from %s: %s" queue e; - "" + D.info "Failed to get coverage data from %s: %s" queue e ; + "" let string_of_result = function - | `Ok s -> s + | `Ok s -> + s | `Error (`Msg e) -> - D.info "Failed to get coverage data: %s" e; - "ERROR" + D.info "Failed to get coverage data: %s" e ; + "ERROR" - let process = fun body -> + let process body = let open Message_switch_core.Mresult in - D.debug "Coverage dispatcher received %s" body; - let result = begin - Client.connect ~switch:!Xcp_client.switch_path () >>= fun t -> - Client.list ~t ~prefix ~filter:`Alive () >>= fun queues -> - queues |> - (* filter out ourselves *) - List.filter (fun q -> self <> q) |> - - (* best-effort: collect and return all non-failed results, log errors *) - List.rev_map (rpc_ignore_err ~t ~body) |> - - (* multiple return values converted to a single string, suitable for use in a command like: - mv $(message-cli call org.xen.xapi.coverage.dispatch --timeout 60 --body 'dump {jobid}') /tmp/coverage/ - *) - String.concat " " |> - ok - end |> Client.error_to_msg |> string_of_result in - D.debug "Coverage dispatcher replying to '%s': %s" body result; + D.debug "Coverage dispatcher received %s" body ; + let result = + Client.connect ~switch:!Xcp_client.switch_path () + >>= (fun t -> + Client.list ~t ~prefix ~filter:`Alive () >>= fun queues -> + queues + |> (* filter out ourselves *) + List.filter (fun q -> self <> q) + |> (* best-effort: collect and return all non-failed results, log + errors *) + List.rev_map (rpc_ignore_err ~t ~body) + |> (* multiple return values converted to a single string, suitable + for use in a command like: mv $(message-cli call + org.xen.xapi.coverage.dispatch --timeout 60 --body 'dump + {jobid}') /tmp/coverage/ *) + String.concat " " + |> ok) + |> Client.error_to_msg + |> string_of_result + in + D.debug "Coverage dispatcher replying to '%s': %s" body result ; result let init () = (* receives command and dispatches to all other coverage message queues *) - let (_:Thread.t) = - Thread.create (Message_switch_unix.Protocol_unix.Server.listen ~process - ~switch:!Xcp_client.switch_path ~queue:self) () in - D.debug "Started coverage API dispatcher on %s" self; + let (_ : Thread.t) = + Thread.create + (Message_switch_unix.Protocol_unix.Server.listen ~process + ~switch:!Xcp_client.switch_path ~queue:self) + () + in + D.debug "Started coverage API dispatcher on %s" self ; () end -(** [init name] sets up coverage profiling for binary [name]. You could - * use [Sys.argv.(0)] for [name]. - *) +(** [init name] sets up coverage profiling for binary [name]. You could * use + [Sys.argv.(0)] for [name]. *) let init name = - D.info "About to initialize coverage runtime"; - Bisect.init name; + D.info "About to initialize coverage runtime" ; + Bisect.init name ; D.info "Coverage runtime initialized" -let dispatcher_init _name = - Dispatcher.init () +let dispatcher_init _name = Dispatcher.init () diff --git a/lib/debug.ml b/lib/debug.ml index 190d9e2b..c3901aa3 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -12,43 +12,35 @@ * GNU Lesser General Public License for more details. *) - module Mutex = struct include Mutex (** execute the function f with the mutex hold *) let execute lock f = - Mutex.lock lock; - let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in - Mutex.unlock lock; - r + Mutex.lock lock ; + let r = try f () with exn -> Mutex.unlock lock ; raise exn in + Mutex.unlock lock ; r end -let get_thread_id () = - try Thread.id (Thread.self ()) with _ -> -1 +let get_thread_id () = try Thread.id (Thread.self ()) with _ -> -1 -module IntMap = Map.Make(Int) +module IntMap = Map.Make (Int) module ThreadLocalTable = struct - type 'a t = { - mutable tbl: 'a IntMap.t; - m: Mutex.t; - } + type 'a t = {mutable tbl: 'a IntMap.t; m: Mutex.t} let make () = let tbl = IntMap.empty in let m = Mutex.create () in - { tbl; m } + {tbl; m} let add t v = let id = get_thread_id () in - Mutex.execute t.m (fun () -> - t.tbl <- IntMap.add id v t.tbl) + Mutex.execute t.m (fun () -> t.tbl <- IntMap.add id v t.tbl) let remove t = let id = get_thread_id () in - Mutex.execute t.m (fun () -> - t.tbl <- IntMap.remove id t.tbl) + Mutex.execute t.m (fun () -> t.tbl <- IntMap.remove id t.tbl) let find t = let id = get_thread_id () in @@ -62,11 +54,10 @@ let tasks = ThreadLocalTable.make () let gettimestring () = let time = Unix.gettimeofday () in let tm = Unix.gmtime time in - let msec = time -. (floor time) in - Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" - (1900 + tm.Unix.tm_year) - (tm.Unix.tm_mon + 1) tm.Unix.tm_mday - tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + let msec = time -. floor time in + Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year) + (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min + tm.Unix.tm_sec (int_of_float (1000.0 *. msec)) (** [escape str] efficiently escapes non-printable characters and in @@ -76,163 +67,183 @@ let escape = Astring.String.Ascii.escape let format include_time brand priority message = let id = get_thread_id () in - let name = match ThreadLocalTable.find names with Some x -> x | None -> "" in - let task = match ThreadLocalTable.find tasks with Some x -> x | None -> "" in - + let name = + match ThreadLocalTable.find names with Some x -> x | None -> "" + in + let task = + match ThreadLocalTable.find tasks with Some x -> x | None -> "" + in Printf.sprintf "[%s%5s||%d %s|%s|%s] %s" (if include_time then gettimestring () else "") priority id name task brand message let print_debug = ref false + let log_to_stdout () = print_debug := true module BrandLevelPair = struct type t = string * Syslog.level + let compare = Stdlib.compare end -module BrandLevelPairSet = Set.Make(BrandLevelPair) + +module BrandLevelPairSet = Set.Make (BrandLevelPair) let loglevel_m = Mutex.create () + let logging_disabled_for = ref BrandLevelPairSet.empty + let default_loglevel = Syslog.Debug + let loglevel = ref default_loglevel -let disabled_modules () = - BrandLevelPairSet.elements !logging_disabled_for +let disabled_modules () = BrandLevelPairSet.elements !logging_disabled_for let is_disabled brand level = - Syslog.is_masked ~threshold:!loglevel level || - BrandLevelPairSet.mem (brand, level) !logging_disabled_for - + Syslog.is_masked ~threshold:!loglevel level + || BrandLevelPairSet.mem (brand, level) !logging_disabled_for let facility = ref Syslog.Daemon + let set_facility f = facility := f + let get_facility () = !facility let output_log brand level priority s = - if not(is_disabled brand level) then begin + if not (is_disabled brand level) then ( let msg = format false brand priority s in - if !print_debug - then Printf.printf "%s\n%!" (format true brand priority s); - + if !print_debug then + Printf.printf "%s\n%!" (format true brand priority s) ; Syslog.log (get_facility ()) level (escape msg) - end + ) let logs_reporter = (* We convert Logs level to our own type to allow output_log to correctly filter logs coming from libraries using Logs *) let logs_to_syslog_level = function - (* In practice we only care about Syslog.Debug,Warning,Info,Err, - because these are the ones we use in the log functions in Debug.Make *) - | Logs.Debug -> Syslog.Debug - | Logs.Info -> Syslog.Info - | Logs.Warning -> Syslog.Warning - | Logs.Error -> Syslog.Err - (* This is used by applications, not libraries - we should not get this in practice *) - | Logs.App -> Syslog.Info + (* In practice we only care about Syslog.Debug,Warning,Info,Err, because + these are the ones we use in the log functions in Debug.Make *) + | Logs.Debug -> + Syslog.Debug + | Logs.Info -> + Syslog.Info + | Logs.Warning -> + Syslog.Warning + | Logs.Error -> + Syslog.Err + (* This is used by applications, not libraries - we should not get this in + practice *) + | Logs.App -> + Syslog.Info in - (* Ensure that logs from libraries will be displayed with the correct - priority *) + (* Ensure that logs from libraries will be displayed with the correct priority *) let logs_level_to_priority = function (* These string match the ones used by the logging functions in Debug.Make *) - | Logs.Debug -> "debug" - | Logs.Info -> "info" - | Logs.Warning -> "warn" - | Logs.Error -> "error" - (* This is used by applications, not libraries - we should not get this in practice *) - | Logs.App -> "app" + | Logs.Debug -> + "debug" + | Logs.Info -> + "info" + | Logs.Warning -> + "warn" + | Logs.Error -> + "error" + (* This is used by applications, not libraries - we should not get this in + practice *) + | Logs.App -> + "app" in let report src level ~over k msgf = let formatter ?header ?tags fmt = - ignore(header); - ignore(tags); + ignore header ; + ignore tags ; let buf = Buffer.create 80 in let buf_fmt = Format.formatter_of_buffer buf in let k _ = - Format.pp_print_flush buf_fmt (); + Format.pp_print_flush buf_fmt () ; let msg = Buffer.contents buf in (* We map the Logs source name to the "brand", so we have to use the name of the Logs source when enabling/disabling it *) let brand = Logs.Src.name src in - output_log brand (logs_to_syslog_level level) (logs_level_to_priority level) msg; - over (); + output_log brand + (logs_to_syslog_level level) + (logs_level_to_priority level) + msg ; + over () ; k () in Format.kfprintf k buf_fmt fmt in msgf formatter in - { Logs.report = report } + {Logs.report} let init_logs () = - Logs.set_reporter logs_reporter; - (* [output_log] will do the actual filtering based on levels, - but we only consider messages of level warning and above from libraries, - to avoid calling [output_log] too often. *) + Logs.set_reporter logs_reporter ; + (* [output_log] will do the actual filtering based on levels, but we only + consider messages of level warning and above from libraries, to avoid + calling [output_log] too often. *) Logs.set_level (Some Logs.Warning) let rec split_c c str = try let i = String.index str c in - String.sub str 0 i :: (split_c c (String.sub str (i+1) (String.length str - i - 1))) + String.sub str 0 i + :: split_c c (String.sub str (i + 1) (String.length str - i - 1)) with Not_found -> [str] -let log_backtrace_exn ?(level=Syslog.Err) ?(msg="error") exn _bt = - Backtrace.is_important exn; - let all = split_c '\n' (Backtrace.(to_string_hum (remove exn))) in +let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn _bt = + Backtrace.is_important exn ; + let all = split_c '\n' Backtrace.(to_string_hum (remove exn)) in (* Write to the log line at a time *) - output_log "backtrace" level msg (Printf.sprintf "Raised %s" (Printexc.to_string exn)); + output_log "backtrace" level msg + (Printf.sprintf "Raised %s" (Printexc.to_string exn)) ; List.iter (output_log "backtrace" level msg) all let log_backtrace e bt = log_backtrace_exn e bt let with_thread_associated task f x = - ThreadLocalTable.add tasks task; + ThreadLocalTable.add tasks task ; let result = Backtrace.with_backtraces (fun () -> f x) in - ThreadLocalTable.remove tasks; + ThreadLocalTable.remove tasks ; match result with | `Ok result -> - result + result | `Error (exn, bt) -> - (* This function is a top-level exception handler typically used on fresh - threads. This is the last chance to do something with the backtrace *) - output_log "backtrace" Syslog.Err "error" (Printf.sprintf "%s failed with exception %s" task (Printexc.to_string exn)); - log_backtrace exn bt; - raise exn + (* This function is a top-level exception handler typically used on fresh + threads. This is the last chance to do something with the backtrace *) + output_log "backtrace" Syslog.Err "error" + (Printf.sprintf "%s failed with exception %s" task + (Printexc.to_string exn)) ; + log_backtrace exn bt ; + raise exn let with_thread_named name f x = - ThreadLocalTable.add names name; + ThreadLocalTable.add names name ; try let result = f x in - ThreadLocalTable.remove names; + ThreadLocalTable.remove names ; result with e -> - Backtrace.is_important e; - ThreadLocalTable.remove names; + Backtrace.is_important e ; + ThreadLocalTable.remove names ; raise e module type BRAND = sig - val name: string + val name : string end -let all_levels = [Syslog.Debug; Syslog.Info; Syslog.Warning; Syslog.Err; Syslog.Crit] +let all_levels = + [Syslog.Debug; Syslog.Info; Syslog.Warning; Syslog.Err; Syslog.Crit] let add_to_stoplist brand level = - logging_disabled_for := BrandLevelPairSet.add (brand, level) !logging_disabled_for + logging_disabled_for := + BrandLevelPairSet.add (brand, level) !logging_disabled_for let disable ?level brand = - let levels = match level with - | None -> all_levels - | Some l -> [l] - in - Mutex.execute loglevel_m (fun () -> - List.iter (add_to_stoplist brand) levels - ) + let levels = match level with None -> all_levels | Some l -> [l] in + Mutex.execute loglevel_m (fun () -> List.iter (add_to_stoplist brand) levels) -let set_level level = - Mutex.execute loglevel_m (fun () -> - loglevel := level - ) +let set_level level = Mutex.execute loglevel_m (fun () -> loglevel := level) module type DEBUG = sig val debug : ('a, unit, string, unit) format4 -> 'a @@ -252,34 +263,41 @@ module type DEBUG = sig val log_and_ignore_exn : (unit -> unit) -> unit end -module Make = functor(Brand: BRAND) -> struct - - let output level priority (fmt: ('a, unit, string, 'b) format4) = - Printf.kprintf - (fun s -> - if not(is_disabled Brand.name level) - then output_log Brand.name level priority s - ) fmt - - let debug fmt = output Syslog.Debug "debug" fmt - let warn fmt = output Syslog.Warning "warn" fmt - let info fmt = output Syslog.Info "info" fmt - let error fmt = output Syslog.Err "error" fmt - let critical fmt = output Syslog.Crit "critical" fmt - let audit ?(raw=false) (fmt: ('a, unit, string, 'b) format4) = - Printf.kprintf - (fun s -> - let msg = if raw then s else format true Brand.name "audit" s in - Syslog.log Syslog.Local6 Syslog.Info (escape msg); - msg - ) fmt - - let log_backtrace () = - let backtrace = Printexc.get_backtrace () in - debug "%s" (String.escaped backtrace) - - let log_and_ignore_exn f = - try f () - with e -> log_backtrace_exn ~level:Syslog.Debug ~msg:"debug" e () -end +module Make = +functor + (Brand : BRAND) + -> + struct + let output level priority (fmt : ('a, unit, string, 'b) format4) = + Printf.kprintf + (fun s -> + if not (is_disabled Brand.name level) then + output_log Brand.name level priority s) + fmt + + let debug fmt = output Syslog.Debug "debug" fmt + + let warn fmt = output Syslog.Warning "warn" fmt + let info fmt = output Syslog.Info "info" fmt + + let error fmt = output Syslog.Err "error" fmt + + let critical fmt = output Syslog.Crit "critical" fmt + + let audit ?(raw = false) (fmt : ('a, unit, string, 'b) format4) = + Printf.kprintf + (fun s -> + let msg = if raw then s else format true Brand.name "audit" s in + Syslog.log Syslog.Local6 Syslog.Info (escape msg) ; + msg) + fmt + + let log_backtrace () = + let backtrace = Printexc.get_backtrace () in + debug "%s" (String.escaped backtrace) + + let log_and_ignore_exn f = + try f () + with e -> log_backtrace_exn ~level:Syslog.Debug ~msg:"debug" e () + end diff --git a/lib/debug.mli b/lib/debug.mli index 3b462ce1..ca224e72 100644 --- a/lib/debug.mli +++ b/lib/debug.mli @@ -20,15 +20,17 @@ val init_logs : unit -> unit (** {2 Associate a task to the current actions} *) -(** Do an action with a task name associated with the current thread *) val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b +(** Do an action with a task name associated with the current thread *) (** {2 Associate a name to the current thread} *) -(** Do an action with a name associated with the current thread *) val with_thread_named : string -> ('a -> 'b) -> 'a -> 'b +(** Do an action with a name associated with the current thread *) -module type BRAND = sig val name : string end +module type BRAND = sig + val name : string +end val gettimestring : unit -> string (** The current time of day in a format suitable for logging *) @@ -37,13 +39,13 @@ val set_facility : Syslog.facility -> unit (** Set the syslog facility that will be used by this program. *) val disable : ?level:Syslog.level -> string -> unit -(** [disable brand] Suppress all log output from the given [brand]. Specifying a [level] disables - * only this log level, otherwise all levels for the given [brand] are disabled. - * This function is idempotent. *) +(** [disable brand] Suppress all log output from the given [brand]. Specifying a + [level] disables * only this log level, otherwise all levels for the given + [brand] are disabled. * This function is idempotent. *) val set_level : Syslog.level -> unit -(** [set_level level] Disable all log output below [level]. - * This function is idempotent. *) +(** [set_level level] Disable all log output below [level]. * This function is + idempotent. *) val disabled_modules : unit -> (string * Syslog.level) list (** List describing which modules have logging currently disabled *) @@ -51,31 +53,31 @@ val disabled_modules : unit -> (string * Syslog.level) list val log_to_stdout : unit -> unit (** [log_to_stdout ()] will echo all log output to stdout (not the default) *) -val log_backtrace: exn -> Backtrace.t -> unit +val log_backtrace : exn -> Backtrace.t -> unit (** Write the backtrace associated with [exn] to the log *) module type DEBUG = sig - (** Debug function *) - val debug : ('a, unit, string, unit) format4 -> 'a + val debug : ('a, unit, string, unit) format4 -> 'a + (** Debug function *) - (** Warn function *) - val warn : ('a, unit, string, unit) format4 -> 'a + val warn : ('a, unit, string, unit) format4 -> 'a + (** Warn function *) - (** Info function *) - val info : ('a, unit, string, unit) format4 -> 'a + val info : ('a, unit, string, unit) format4 -> 'a + (** Info function *) - (** Error function *) - val error : ('a, unit, string, unit) format4 -> 'a + val error : ('a, unit, string, unit) format4 -> 'a + (** Error function *) - (** Critical function *) - val critical : ('a, unit, string, unit) format4 -> 'a + val critical : ('a, unit, string, unit) format4 -> 'a + (** Critical function *) - (** Audit function *) - val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a + val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a + (** Audit function *) - val log_backtrace : unit -> unit + val log_backtrace : unit -> unit - val log_and_ignore_exn : (unit -> unit) -> unit + val log_and_ignore_exn : (unit -> unit) -> unit end module Make : functor (Brand : BRAND) -> DEBUG @@ -83,5 +85,5 @@ module Make : functor (Brand : BRAND) -> DEBUG (** {3 Utility functions for the test code} *) val is_disabled : string -> Syslog.level -> bool -(** [is_disabled brand level] returns [true] if logging for [brand] at [level] is disabled, - * otherwise returns [false]. *) \ No newline at end of file +(** [is_disabled brand level] returns [true] if logging for [brand] at [level] + is disabled, * otherwise returns [false]. *) diff --git a/lib/open_uri.ml b/lib/open_uri.ml index eed2cacf..b63df639 100644 --- a/lib/open_uri.ml +++ b/lib/open_uri.ml @@ -17,41 +17,37 @@ open Xapi_stdext_pervasives.Pervasiveext -let handle_socket f s = - try - f s - with e -> - Backtrace.is_important e; - raise e +let handle_socket f s = try f s with e -> Backtrace.is_important e ; raise e let open_tcp f host port = let host_entry = Unix.gethostbyname host in - let sockaddr = Unix.ADDR_INET(host_entry.Unix.h_addr_list.(0), port) in + let sockaddr = Unix.ADDR_INET (host_entry.Unix.h_addr_list.(0), port) in let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - finally (fun () -> - Unix.connect s sockaddr; - handle_socket f s - ) (fun () -> - Unix.close s - ) + finally + (fun () -> Unix.connect s sockaddr ; handle_socket f s) + (fun () -> Unix.close s) let with_open_uri uri f = match Uri.scheme uri with - | Some "http" -> - begin match Uri.host uri, Uri.port uri with - | Some host, Some port -> open_tcp f host port - | Some host, None -> open_tcp f host 80 - | _, _ -> failwith (Printf.sprintf "Failed to parse host and port from URI: %s" (Uri.to_string uri)) - end + | Some "http" -> ( + match (Uri.host uri, Uri.port uri) with + | Some host, Some port -> + open_tcp f host port + | Some host, None -> + open_tcp f host 80 + | _, _ -> + failwith + (Printf.sprintf "Failed to parse host and port from URI: %s" + (Uri.to_string uri)) + ) | Some "file" -> - let filename = Uri.path_and_query uri in - let sockaddr = Unix.ADDR_UNIX filename in - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - finally (fun () -> - Unix.connect s sockaddr; - handle_socket f s - ) (fun () -> - Unix.close s - ) - | Some x -> failwith (Printf.sprintf "Unsupported URI scheme: %s" x) - | None -> failwith (Printf.sprintf "Failed to parse URI: %s" (Uri.to_string uri)) + let filename = Uri.path_and_query uri in + let sockaddr = Unix.ADDR_UNIX filename in + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + finally + (fun () -> Unix.connect s sockaddr ; handle_socket f s) + (fun () -> Unix.close s) + | Some x -> + failwith (Printf.sprintf "Unsupported URI scheme: %s" x) + | None -> + failwith (Printf.sprintf "Failed to parse URI: %s" (Uri.to_string uri)) diff --git a/lib/posix_channel.ml b/lib/posix_channel.ml index c7e3e8d5..da9dda04 100644 --- a/lib/posix_channel.ml +++ b/lib/posix_channel.ml @@ -1,211 +1,227 @@ let my_domid = 0 (* TODO: figure this out *) exception End_of_file + exception Channel_setup_failed module CBuf = struct (** A circular buffer constructed from a string *) type t = { - mutable buffer: bytes; - mutable len: int; (** bytes of valid data in [buffer] *) - mutable start: int; (** index of first valid byte in [buffer] *) - mutable r_closed: bool; (** true if no more data can be read due to EOF *) - mutable w_closed: bool; (** true if no more data can be written due to EOF *) - } - - let empty length = { - buffer = Bytes.create length; - len = 0; - start = 0; - r_closed = false; - w_closed = false; + mutable buffer: bytes + ; mutable len: int (** bytes of valid data in [buffer] *) + ; mutable start: int (** index of first valid byte in [buffer] *) + ; mutable r_closed: bool (** true if no more data can be read due to EOF *) + ; mutable w_closed: bool + (** true if no more data can be written due to EOF *) } - let drop (x: t) n = - if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len); - x.start <- (x.start + n) mod (Bytes.length x.buffer); + let empty length = + { + buffer= Bytes.create length + ; len= 0 + ; start= 0 + ; r_closed= false + ; w_closed= false + } + + let drop (x : t) n = + if n > x.len then failwith (Printf.sprintf "drop %d > %d" n x.len) ; + x.start <- (x.start + n) mod Bytes.length x.buffer ; x.len <- x.len - n - let should_read (x: t) = - not x.r_closed && (x.len < (Bytes.length x.buffer - 1)) - let should_write (x: t) = - not x.w_closed && (x.len > 0) + let should_read (x : t) = + (not x.r_closed) && x.len < Bytes.length x.buffer - 1 + + let should_write (x : t) = (not x.w_closed) && x.len > 0 - let end_of_reads (x: t) = x.r_closed && x.len = 0 - let end_of_writes (x: t) = x.w_closed + let end_of_reads (x : t) = x.r_closed && x.len = 0 - let write (x: t) fd = + let end_of_writes (x : t) = x.w_closed + + let write (x : t) fd = (* Offset of the character after the substring *) let next = min (Bytes.length x.buffer) (x.start + x.len) in let len = next - x.start in - let written = try Unix.single_write fd x.buffer x.start len with _e -> x.w_closed <- true; len in + let written = + try Unix.single_write fd x.buffer x.start len + with _e -> + x.w_closed <- true ; + len + in drop x written - let read (x: t) fd = + let read (x : t) fd = (* Offset of the next empty character *) - let next = (x.start + x.len) mod (Bytes.length x.buffer) in - let len = min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) in + let next = (x.start + x.len) mod Bytes.length x.buffer in + let len = + min (Bytes.length x.buffer - next) (Bytes.length x.buffer - x.len) + in let read = Unix.read fd x.buffer next len in - if read = 0 then x.r_closed <- true; + if read = 0 then x.r_closed <- true ; x.len <- x.len + read end -let proxy (a: Unix.file_descr) (b: Unix.file_descr) = +let proxy (a : Unix.file_descr) (b : Unix.file_descr) = let size = 64 * 1024 in (* [a'] is read from [a] and will be written to [b] *) (* [b'] is read from [b] and will be written to [a] *) let a' = CBuf.empty size and b' = CBuf.empty size in - Unix.set_nonblock a; - Unix.set_nonblock b; - + Unix.set_nonblock a ; + Unix.set_nonblock b ; try while true do - let r = (if CBuf.should_read a' then [ a ] else []) @ (if CBuf.should_read b' then [ b ] else []) in - let w = (if CBuf.should_write a' then [ b ] else []) @ (if CBuf.should_write b' then [ a ] else []) in - + let r = + (if CBuf.should_read a' then [a] else []) + @ if CBuf.should_read b' then [b] else [] + in + let w = + (if CBuf.should_write a' then [b] else []) + @ if CBuf.should_write b' then [a] else [] + in (* If we can't make any progress (because fds have been closed), then stop *) - if r = [] && w = [] then raise End_of_file; - + if r = [] && w = [] then raise End_of_file ; let r, w, _ = Unix.select r w [] (-1.0) in (* Do the writing before the reading *) - List.iter (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) w; - List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r; + List.iter + (fun fd -> if a = fd then CBuf.write b' a else CBuf.write a' b) + w ; + List.iter (fun fd -> if a = fd then CBuf.read a' a else CBuf.read b' b) r ; (* If there's nothing else to read or write then signal the other end *) List.iter (fun (buf, fd) -> - if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND; - if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE - ) [ a', b; b', a ] + if CBuf.end_of_reads buf then Unix.shutdown fd Unix.SHUTDOWN_SEND ; + if CBuf.end_of_writes buf then Unix.shutdown fd Unix.SHUTDOWN_RECEIVE) + [(a', b); (b', a)] done - with _ -> - (try Unix.clear_nonblock a with _ -> ()); - (try Unix.clear_nonblock b with _ -> ()) + with _ -> ( + (try Unix.clear_nonblock a with _ -> ()) ; + try Unix.clear_nonblock b with _ -> () + ) let finally f g = try let result = f () in - g (); - result - with e -> - g (); - raise e + g () ; result + with e -> g () ; raise e let ip = ref "127.0.0.1" let send proxy_socket = let to_close = ref [] in let to_unlink = ref [] in - finally (fun () -> let s_ip = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - to_close := s_ip :: !to_close; - Unix.bind s_ip (Unix.ADDR_INET(Unix.inet_addr_of_string !ip, 0)); - Unix.listen s_ip 5; - let port = match Unix.getsockname s_ip with - | Unix.ADDR_INET(_, port) -> port - | _ -> assert false in - + to_close := s_ip :: !to_close ; + Unix.bind s_ip (Unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) ; + Unix.listen s_ip 5 ; + let port = + match Unix.getsockname s_ip with + | Unix.ADDR_INET (_, port) -> + port + | _ -> + assert false + in let s_unix = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - to_close := s_unix :: !to_close; + to_close := s_unix :: !to_close ; let path = Filename.temp_file "channel" "" in - to_unlink := path :: !to_unlink; - if Sys.file_exists path then Unix.unlink path; - Unix.bind s_unix (Unix.ADDR_UNIX path); - Unix.listen s_unix 5; - + to_unlink := path :: !to_unlink ; + if Sys.file_exists path then Unix.unlink path ; + Unix.bind s_unix (Unix.ADDR_UNIX path) ; + Unix.listen s_unix 5 ; let token = "token" in let protocols = - let open Xcp_channel_protocol in - [ - TCP_proxy(!ip, port); - Unix_sendmsg(my_domid, path, token); - ] in - - (* We need to hang onto a copy of the proxy_socket so we can - run a proxy in a background thread, allowing the caller to - close their copy. *) + let open Xcp_channel_protocol in + [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] + in + (* We need to hang onto a copy of the proxy_socket so we can run a proxy + in a background thread, allowing the caller to close their copy. *) let proxy_socket = Unix.dup proxy_socket in - to_close := proxy_socket :: !to_close; - - let (_: Thread.t) = Thread.create (fun (fds, paths) -> - (* The thread takes over management of the listening sockets *) - let to_close = ref fds in - let to_unlink = ref paths in - - let close fd = - if List.mem fd !to_close then begin - to_close := List.filter (fun x -> x <> fd) !to_close; - Unix.close fd; - end in - - finally - (fun () -> - let readable, _, _ = Unix.select [ s_ip; s_unix ] [] [] (-1.0) in - if List.mem s_unix readable then begin - let fd, _peer = Unix.accept s_unix in - to_close := fd :: !to_close; - let buffer = Bytes.make (String.length token) '\000' in - let n = Unix.recv fd buffer 0 (Bytes.length buffer) [] in - let token' = Bytes.sub_string buffer 0 n in - if token = token' then begin - let (_: int) = Fd_send_recv.send_fd_substring fd token 0 (String.length token) [] proxy_socket in - () - end - end else if List.mem s_ip readable then begin - let fd, _peer = Unix.accept s_ip in - - List.iter close !to_close; - to_close := fd :: !to_close; - proxy fd proxy_socket - end else assert false (* can never happen *) - ) (fun () -> - List.iter close !to_close; - List.iter Unix.unlink !to_unlink; - ) - ) (!to_close, !to_unlink) in + to_close := proxy_socket :: !to_close ; + let (_ : Thread.t) = + Thread.create + (fun (fds, paths) -> + (* The thread takes over management of the listening sockets *) + let to_close = ref fds in + let to_unlink = ref paths in + let close fd = + if List.mem fd !to_close then ( + to_close := List.filter (fun x -> x <> fd) !to_close ; + Unix.close fd + ) + in + finally + (fun () -> + let readable, _, _ = Unix.select [s_ip; s_unix] [] [] (-1.0) in + if List.mem s_unix readable then ( + let fd, _peer = Unix.accept s_unix in + to_close := fd :: !to_close ; + let buffer = Bytes.make (String.length token) '\000' in + let n = Unix.recv fd buffer 0 (Bytes.length buffer) [] in + let token' = Bytes.sub_string buffer 0 n in + if token = token' then + let (_ : int) = + Fd_send_recv.send_fd_substring fd token 0 + (String.length token) [] proxy_socket + in + () + ) else if List.mem s_ip readable then ( + let fd, _peer = Unix.accept s_ip in + List.iter close !to_close ; + to_close := fd :: !to_close ; + proxy fd proxy_socket + ) else + assert false + (* can never happen *)) + (fun () -> + List.iter close !to_close ; + List.iter Unix.unlink !to_unlink)) + (!to_close, !to_unlink) + in (* Handover of listening sockets successful *) - to_close := []; - to_unlink := []; - protocols - ) (fun () -> - List.iter Unix.close !to_close; - List.iter Unix.unlink !to_unlink; - ) + to_close := [] ; + to_unlink := [] ; + protocols) + (fun () -> + List.iter Unix.close !to_close ; + List.iter Unix.unlink !to_unlink) let receive protocols = let open Xcp_channel_protocol in let weight = function - | TCP_proxy(_, _) -> 2 - | Unix_sendmsg(domid, _, _) -> if my_domid = domid then 3 else 0 - | V4V_proxy(_, _) -> 0 in - let protocol = match List.sort (fun a b -> compare (weight b) (weight a)) protocols with - | [] -> - raise Channel_setup_failed - | best :: _ -> - if weight best = 0 then begin - raise Channel_setup_failed - end else best in + | TCP_proxy (_, _) -> + 2 + | Unix_sendmsg (domid, _, _) -> + if my_domid = domid then 3 else 0 + | V4V_proxy (_, _) -> + 0 + in + let protocol = + match List.sort (fun a b -> compare (weight b) (weight a)) protocols with + | [] -> + raise Channel_setup_failed + | best :: _ -> + if weight best = 0 then raise Channel_setup_failed else best + in match protocol with - | V4V_proxy(_, _) -> assert false (* weight is 0 above *) - | TCP_proxy(ip, port) -> - let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - begin + | V4V_proxy (_, _) -> + assert false (* weight is 0 above *) + | TCP_proxy (ip, port) -> ( + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in try - Unix.connect s (Unix.ADDR_INET(Unix.inet_addr_of_string ip, port)); + Unix.connect s (Unix.ADDR_INET (Unix.inet_addr_of_string ip, port)) ; s - with e -> - Unix.close s; - raise e - end - | Unix_sendmsg(_, path, token) -> - let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - finally - (fun () -> - Unix.connect s (Unix.ADDR_UNIX path); - let (_: int) = Unix.send_substring s token 0 (String.length token) [] in - let buf = Bytes.create (String.length token) in - let (_, _, fd) = Fd_send_recv.recv_fd s buf 0 (Bytes.length buf) [] in - fd - ) (fun () -> Unix.close s) - + with e -> Unix.close s ; raise e + ) + | Unix_sendmsg (_, path, token) -> + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + finally + (fun () -> + Unix.connect s (Unix.ADDR_UNIX path) ; + let (_ : int) = + Unix.send_substring s token 0 (String.length token) [] + in + let buf = Bytes.create (String.length token) in + let _, _, fd = Fd_send_recv.recv_fd s buf 0 (Bytes.length buf) [] in + fd) + (fun () -> Unix.close s) diff --git a/lib/posix_channel.mli b/lib/posix_channel.mli index 1db458e6..8610f27a 100644 --- a/lib/posix_channel.mli +++ b/lib/posix_channel.mli @@ -12,10 +12,10 @@ * GNU Lesser General Public License for more details. *) -val send: Unix.file_descr -> Xcp_channel_protocol.t list -(** [send fd] attempts to send the channel represented by [fd] to a - remote process. Note the file descriptor remains open in the - original process and should still be closed normally. *) +val send : Unix.file_descr -> Xcp_channel_protocol.t list +(** [send fd] attempts to send the channel represented by [fd] to a remote + process. Note the file descriptor remains open in the original process and + should still be closed normally. *) -val receive: Xcp_channel_protocol.t list -> Unix.file_descr +val receive : Xcp_channel_protocol.t list -> Unix.file_descr (** [receive protocols] receives a channel from a remote. *) diff --git a/lib/scheduler.ml b/lib/scheduler.ml index eb15ed1e..b41e7542 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -15,214 +15,209 @@ let finally f g = try let result = f () in - g (); - result; - with - | e -> - g (); - raise e + g () ; result + with e -> g () ; raise e let mutex_execute m f = - Mutex.lock m; + Mutex.lock m ; finally f (fun () -> Mutex.unlock m) -module D = Debug.Make(struct let name = "scheduler" end) +module D = Debug.Make (struct let name = "scheduler" end) + open D -module Int64Map = Map.Make(struct type t = int64 let compare = Int64.compare end) +module Int64Map = Map.Make (struct + type t = int64 + + let compare = Int64.compare +end) module Delay = struct (* Concrete type is the ends of a pipe *) type t = { - (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option; - mutable pipe_in: Unix.file_descr option; - (* Indicates that a signal arrived before a wait: *) - mutable signalled: bool; - m: Mutex.t + (* A pipe is used to wake up a thread blocked in wait: *) + mutable pipe_out: Unix.file_descr option + ; mutable pipe_in: Unix.file_descr option + ; (* Indicates that a signal arrived before a wait: *) + mutable signalled: bool + ; m: Mutex.t } let make () = - { pipe_out = None; - pipe_in = None; - signalled = false; - m = Mutex.create () } + {pipe_out= None; pipe_in= None; signalled= false; m= Mutex.create ()} exception Pre_signalled - let wait (x: t) (seconds: float) = + let wait (x : t) (seconds : float) = let timeout = if seconds < 0.0 then 0.0 else seconds in - let to_close = ref [ ] in + let to_close = ref [] in let close' fd = - if List.mem fd !to_close then Unix.close fd; - to_close := List.filter (fun x -> fd <> x) !to_close in + if List.mem fd !to_close then Unix.close fd ; + to_close := List.filter (fun x -> fd <> x) !to_close + in finally (fun () -> - try - let pipe_out = mutex_execute x.m - (fun () -> - if x.signalled then begin - x.signalled <- false; - raise Pre_signalled; - end; - let pipe_out, pipe_in = Unix.pipe () in - (* these will be unconditionally closed on exit *) - to_close := [ pipe_out; pipe_in ]; - x.pipe_out <- Some pipe_out; - x.pipe_in <- Some pipe_in; - x.signalled <- false; - pipe_out) in - let r, _, _ = Unix.select [ pipe_out ] [] [] timeout in - (* flush the single byte from the pipe *) - if r <> [] then ignore(Unix.read pipe_out (Bytes.create 1) 0 1); - (* return true if we waited the full length of time, false if we were woken *) - r = [] - with Pre_signalled -> false - ) - (fun () -> - mutex_execute x.m - (fun () -> - x.pipe_out <- None; - x.pipe_in <- None; - List.iter close' !to_close) - ) - - let signal (x: t) = - mutex_execute x.m + try + let pipe_out = + mutex_execute x.m (fun () -> + if x.signalled then ( + x.signalled <- false ; + raise Pre_signalled + ) ; + let pipe_out, pipe_in = Unix.pipe () in + (* these will be unconditionally closed on exit *) + to_close := [pipe_out; pipe_in] ; + x.pipe_out <- Some pipe_out ; + x.pipe_in <- Some pipe_in ; + x.signalled <- false ; + pipe_out) + in + let r, _, _ = Unix.select [pipe_out] [] [] timeout in + (* flush the single byte from the pipe *) + if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; + (* return true if we waited the full length of time, false if we were + woken *) + r = [] + with Pre_signalled -> false) (fun () -> - match x.pipe_in with - | Some fd -> ignore(Unix.write fd (Bytes.of_string "X") 0 1) - | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) - ) + mutex_execute x.m (fun () -> + x.pipe_out <- None ; + x.pipe_in <- None ; + List.iter close' !to_close)) + + let signal (x : t) = + mutex_execute x.m (fun () -> + match x.pipe_in with + | Some fd -> + ignore (Unix.write fd (Bytes.of_string "X") 0 1) + | None -> + x.signalled <- true + (* If the wait hasn't happened yet then store up the signal *)) end -type item = { - id: int; - name: string; - fn: unit -> unit -} +type item = {id: int; name: string; fn: unit -> unit} type handle = int64 * int [@@deriving rpc] type t = { - mutable schedule : item list Int64Map.t; - mutable shutdown : bool; - delay : Delay.t; - mutable next_id : int; - mutable thread : Thread.t option; - m : Mutex.t; + mutable schedule: item list Int64Map.t + ; mutable shutdown: bool + ; delay: Delay.t + ; mutable next_id: int + ; mutable thread: Thread.t option + ; m: Mutex.t } -type time = - | Absolute of int64 - | Delta of int +type time = Absolute of int64 | Delta of int (*type t = int64 * int [@@deriving rpc]*) let now () = Unix.gettimeofday () |> ceil |> Int64.of_float module Dump = struct - type u = { - time: int64; - thing: string; - } [@@deriving rpc] + type u = {time: int64; thing: string} [@@deriving rpc] + type dump = u list [@@deriving rpc] + let make s = let now = now () in - mutex_execute s.m - (fun () -> - Int64Map.fold (fun time xs acc -> List.map (fun i -> { time = Int64.sub time now; thing = i.name }) xs @ acc) s.schedule [] - ) + mutex_execute s.m (fun () -> + Int64Map.fold + (fun time xs acc -> + List.map (fun i -> {time= Int64.sub time now; thing= i.name}) xs + @ acc) + s.schedule []) end -let one_shot s time (name: string) f = - let time = match time with - | Absolute x -> x - | Delta x -> Int64.(add (of_int x) (now ())) in - let id = mutex_execute s.m - (fun () -> - let existing = - try - Int64Map.find time s.schedule - with _ -> [] - in - let id = s.next_id in - s.next_id <- s.next_id + 1; - let item = { - id = id; - name = name; - fn = f - } in - s.schedule <- Int64Map.add time (item :: existing) s.schedule; - Delay.signal s.delay; - id - ) in +let one_shot s time (name : string) f = + let time = + match time with + | Absolute x -> + x + | Delta x -> + Int64.(add (of_int x) (now ())) + in + let id = + mutex_execute s.m (fun () -> + let existing = try Int64Map.find time s.schedule with _ -> [] in + let id = s.next_id in + s.next_id <- s.next_id + 1 ; + let item = {id; name; fn= f} in + s.schedule <- Int64Map.add time (item :: existing) s.schedule ; + Delay.signal s.delay ; + id) + in (time, id) let cancel s (time, id) = - mutex_execute s.m - (fun () -> - let existing = - if Int64Map.mem time s.schedule - then Int64Map.find time s.schedule - else [] in - s.schedule <- Int64Map.add time (List.filter (fun i -> i.id <> id) existing) s.schedule - ) + mutex_execute s.m (fun () -> + let existing = + if Int64Map.mem time s.schedule then + Int64Map.find time s.schedule + else + [] + in + s.schedule <- + Int64Map.add time + (List.filter (fun i -> i.id <> id) existing) + s.schedule) let process_expired s = let t = now () in let expired = - mutex_execute s.m - (fun () -> - let expired, unexpired = Int64Map.partition (fun t' _ -> t' <= t) s.schedule in - s.schedule <- unexpired; - Int64Map.fold (fun _ stuff acc -> acc @ stuff) expired [] |> List.rev) in + mutex_execute s.m (fun () -> + let expired, unexpired = + Int64Map.partition (fun t' _ -> t' <= t) s.schedule + in + s.schedule <- unexpired ; + Int64Map.fold (fun _ stuff acc -> acc @ stuff) expired [] |> List.rev) + in (* This might take a while *) List.iter (fun i -> - try - i.fn () - with e -> - debug "Scheduler ignoring exception: %s\n%!" (Printexc.to_string e) - ) expired; - expired <> [] (* true if work was done *) + try i.fn () + with e -> + debug "Scheduler ignoring exception: %s\n%!" (Printexc.to_string e)) + expired ; + expired <> [] + +(* true if work was done *) let rec main_loop s = - while process_expired s do () done; + while process_expired s do + () + done ; let sleep_until = - mutex_execute s.m - (fun () -> - try - Int64Map.min_binding s.schedule |> fst - with Not_found -> - Int64.add 3600L (now ()) - ) in + mutex_execute s.m (fun () -> + try Int64Map.min_binding s.schedule |> fst + with Not_found -> Int64.add 3600L (now ())) + in let seconds = Int64.sub sleep_until (now ()) in - let (_: bool) = Delay.wait s.delay (Int64.to_float seconds) in - if s.shutdown - then s.thread <- None - else main_loop s + let (_ : bool) = Delay.wait s.delay (Int64.to_float seconds) in + if s.shutdown then s.thread <- None else main_loop s let start s = - if s.shutdown then failwith "Scheduler was shutdown"; + if s.shutdown then failwith "Scheduler was shutdown" ; s.thread <- Some (Thread.create main_loop s) let make () = - let s = { - schedule = Int64Map.empty; - shutdown = false; - delay = Delay.make (); - next_id = 0; - m = Mutex.create (); - thread = None; - } in - start s; - s + let s = + { + schedule= Int64Map.empty + ; shutdown= false + ; delay= Delay.make () + ; next_id= 0 + ; m= Mutex.create () + ; thread= None + } + in + start s ; s let shutdown s = match s.thread with | Some th -> - s.shutdown <- true; - Delay.signal s.delay; - Thread.join th - | None -> () + s.shutdown <- true ; + Delay.signal s.delay ; + Thread.join th + | None -> + () diff --git a/lib/scheduler.mli b/lib/scheduler.mli index 85f521af..a634af95 100644 --- a/lib/scheduler.mli +++ b/lib/scheduler.mli @@ -1,54 +1,57 @@ - (** The Delay module here implements simple cancellable delays. *) -module Delay : - sig - type t +module Delay : sig + type t - (** Makes a Delay.t *) - val make : unit -> t + val make : unit -> t + (** Makes a Delay.t *) - (** Wait for the specified amount of time. Returns true if we waited - the full length of time, false if we were woken *) - val wait : t -> float -> bool + val wait : t -> float -> bool + (** Wait for the specified amount of time. Returns true if we waited the full + length of time, false if we were woken *) - (** Signal anyone currently waiting with the Delay.t *) - val signal : t -> unit - end + val signal : t -> unit + (** Signal anyone currently waiting with the Delay.t *) +end (** The type of a scheduler *) type t (** The handle for referring to an item that has been scheduled *) type handle + val rpc_of_handle : handle -> Rpc.t + val handle_of_rpc : Rpc.t -> handle -(** Creates a scheduler *) val make : unit -> t +(** Creates a scheduler *) -(** Items can be scheduled at an absolute time (measured in seconds since - unix epoch) or as a delta measured in for seconds from now. *) +(** Items can be scheduled at an absolute time (measured in seconds since unix + epoch) or as a delta measured in for seconds from now. *) type time = Absolute of int64 | Delta of int -(** Useful for Absolutely scheduled items *) val now : unit -> int64 +(** Useful for Absolutely scheduled items *) (** This module is for dumping the state of a scheduler *) -module Dump : - sig - type u = { time : int64; thing : string; } - type dump = u list - val rpc_of_dump : dump -> Rpc.t - val dump_of_rpc : Rpc.t -> dump - val make : t -> dump - end +module Dump : sig + type u = {time: int64; thing: string} + + type dump = u list + + val rpc_of_dump : dump -> Rpc.t + + val dump_of_rpc : Rpc.t -> dump + + val make : t -> dump +end -(** Insert a one-shot item into the scheduler. *) val one_shot : t -> time -> string -> (unit -> unit) -> handle +(** Insert a one-shot item into the scheduler. *) -(** Cancel an item *) val cancel : t -> handle -> unit +(** Cancel an item *) -(** shutdown a scheduler. Any item currently scheduled will not - be executed. The scheduler cannot be restarted. *) val shutdown : t -> unit +(** shutdown a scheduler. Any item currently scheduled will not be executed. The + scheduler cannot be restarted. *) diff --git a/lib/syslog.ml b/lib/syslog.ml index df348cd2..cdc62c6b 100644 --- a/lib/syslog.ml +++ b/lib/syslog.ml @@ -13,64 +13,123 @@ *) type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug -type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern - | Local0 | Local1 | Local2 | Local3 - | Local4 | Local5 | Local6 | Local7 - | Lpr | Mail | News | Syslog | User | Uucp + +type facility = + | Auth + | Authpriv + | Cron + | Daemon + | Ftp + | Kern + | Local0 + | Local1 + | Local2 + | Local3 + | Local4 + | Local5 + | Local6 + | Local7 + | Lpr + | Mail + | News + | Syslog + | User + | Uucp (* external init : string -> options list -> facility -> unit = "stub_openlog" *) external log : facility -> level -> string -> unit = "stub_syslog" + external close : unit -> unit = "stub_closelog" exception Unknown_facility of string + let facility_of_string s = - match s with - |"auth"->Auth - |"authpriv"->Authpriv - |"cron"->Cron - |"daemon"->Daemon - |"ftp"->Ftp - |"kern"->Kern - |"local0"->Local0 - |"local1"->Local1 - |"local2"->Local2 - |"local3"->Local3 - |"local4"->Local4 - |"local5"->Local5 - |"local6"->Local6 - |"local7"->Local7 - |"lpr"->Lpr - |"mail"->Mail - |"news"->News - |"syslog"->Syslog - |"user"->User - |"uucp"->Uucp - |_-> raise (Unknown_facility s) + match s with + | "auth" -> + Auth + | "authpriv" -> + Authpriv + | "cron" -> + Cron + | "daemon" -> + Daemon + | "ftp" -> + Ftp + | "kern" -> + Kern + | "local0" -> + Local0 + | "local1" -> + Local1 + | "local2" -> + Local2 + | "local3" -> + Local3 + | "local4" -> + Local4 + | "local5" -> + Local5 + | "local6" -> + Local6 + | "local7" -> + Local7 + | "lpr" -> + Lpr + | "mail" -> + Mail + | "news" -> + News + | "syslog" -> + Syslog + | "user" -> + User + | "uucp" -> + Uucp + | _ -> + raise (Unknown_facility s) exception Unknown_level of string + let level_of_string s = - match String.lowercase_ascii s with - | "emergency" -> Emerg - | "alert" -> Alert - | "critical" -> Crit - | "error" | "err" -> Err - | "warning" | "warn" -> Warning - | "notice" -> Notice - | "info" -> Info - | "debug" -> Debug - | _-> raise (Unknown_level s) + match String.lowercase_ascii s with + | "emergency" -> + Emerg + | "alert" -> + Alert + | "critical" -> + Crit + | "error" | "err" -> + Err + | "warning" | "warn" -> + Warning + | "notice" -> + Notice + | "info" -> + Info + | "debug" -> + Debug + | _ -> + raise (Unknown_level s) let string_of_level = function - | Emerg -> "emergency" - | Alert -> "alert" - | Crit -> "critical" - | Err -> "error" - | Warning -> "warning" - | Notice -> "notice" - | Info -> "info" - | Debug -> "debug" + | Emerg -> + "emergency" + | Alert -> + "alert" + | Crit -> + "critical" + | Err -> + "error" + | Warning -> + "warning" + | Notice -> + "notice" + | Info -> + "info" + | Debug -> + "debug" let is_masked ~threshold level = - (* This comparison relies on the order in which the constructors in - level are declared *) - threshold < level + (* This comparison relies on the order in which the constructors in level are + declared *) + threshold < level diff --git a/lib/syslog.mli b/lib/syslog.mli index e96214fb..762b38b4 100644 --- a/lib/syslog.mli +++ b/lib/syslog.mli @@ -13,8 +13,9 @@ *) type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug + type facility = - Auth + | Auth | Authpriv | Cron | Daemon @@ -36,19 +37,21 @@ type facility = | Uucp external log : facility -> level -> string -> unit = "stub_syslog" + external close : unit -> unit = "stub_closelog" val facility_of_string : string -> facility -(** [facility_of_string facility] Return the Syslog facility corresponding to [facility]. - Raises [Unknown_facility facility] if facility is unrecognized. *) +(** [facility_of_string facility] Return the Syslog facility corresponding to + [facility]. Raises [Unknown_facility facility] if facility is unrecognized. *) val level_of_string : string -> level (** [level_of_string level] Return the Syslog level corresponding to [level]. Raises [Unknown_level level] if level is unrecognized. *) val string_of_level : level -> string -(** [string_of_level level] Return the string corresponding to the Syslog level [level] *) +(** [string_of_level level] Return the string corresponding to the Syslog level + [level] *) val is_masked : threshold:level -> level -> bool -(** [is_masked ~threshold level] Return true if [level] is below [threshold] and should therefore - not be logged. *) +(** [is_masked ~threshold level] Return true if [level] is below [threshold] and + should therefore not be logged. *) diff --git a/lib/task_server.ml b/lib/task_server.ml index 8eff28f2..3b054f05 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -11,15 +11,15 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Xenops -*) + +(** * @group Xenops *) open Xapi_stdext_monadic + open Xapi_stdext_pervasives.Pervasiveext open Xapi_stdext_threads.Threadext +module D = Debug.Make (struct let name = "task_server" end) -module D = Debug.Make(struct let name = "task_server" end) open D type stringpair = string * string @@ -28,7 +28,9 @@ module type INTERFACE = sig val service_name : string val does_not_exist : string * string -> exn + val cancelled : string -> exn + val marshal_exn : exn -> Rpc.t module Task : sig @@ -36,10 +38,7 @@ module type INTERFACE = sig type async_result - type completion_t = { - duration : float; - result : async_result option - } + type completion_t = {duration: float; result: async_result option} type state = | Pending of float @@ -47,244 +46,245 @@ module type INTERFACE = sig | Failed of Rpc.t type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool; + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool } - end (* The following stuff comes from rpc-light.idl *) - end +module Task = +functor + (Interface : INTERFACE) + -> + struct + module SMap = Map.Make (struct + type t = string -module Task = functor (Interface : INTERFACE) -> struct - - module SMap = Map.Make(struct type t = string let compare = compare end) - - (** Tasks are stored in an id -> t map *) - type id = string - - (** A task is associated with every running operation *) - type task_handle = { - tasks : tasks; - id: id; (** unique task id *) - ctime: float; (** created timestamp *) - dbg: string; (** token sent by client *) - mutable state: Interface.Task.state; (** current completion state *) - mutable subtasks: (string * Interface.Task.state) list; (** one level of "subtasks" *) - f: task_handle -> Interface.Task.async_result option; (** body of the function *) - tm: Mutex.t; (** protects cancelling state *) - mutable cancelling: bool; (** set by cancel *) - mutable cancel: (unit -> unit) list; (** attempt to cancel [f] *) - mutable cancel_points_seen: int; (** incremented every time we pass a cancellation point *) - test_cancel_at: int option; (** index of the cancel point to trigger *) - mutable backtrace: Backtrace.t; (** on error, a backtrace *) - mutable cancellable: bool; - } - - and tasks = { - task_map : task_handle SMap.t ref; - mutable test_cancel_trigger : (string * int) option; - m : Mutex.t; - c : Condition.t; - } - - let empty () = - let task_map = ref SMap.empty in - let m = Mutex.create () in - let c = Condition.create () in - { task_map; test_cancel_trigger = None; m; c } - - (* [next_task_id ()] returns a fresh task id *) - let next_task_id = - let counter = ref 0 in - fun () -> - let result = string_of_int !counter in - incr counter; - result - - let set_cancel_trigger tasks dbg n = - Mutex.execute tasks.m - (fun () -> - tasks.test_cancel_trigger <- Some (dbg, n) - ) - - let clear_cancel_trigger tasks = - Mutex.execute tasks.m - (fun () -> - tasks.test_cancel_trigger <- None - ) - - let id_of_handle task_handle = task_handle.id - - (* [add dbg f] creates a fresh [t], registers and returns it *) - let add tasks dbg (f: task_handle -> Interface.Task.async_result option) = - let t = { - tasks = tasks; - id = next_task_id (); - ctime = Unix.gettimeofday (); - dbg = dbg; - state = Interface.Task.Pending 0.; - subtasks = []; - f = f; - tm = Mutex.create (); - cancelling = false; - cancel = []; - cancel_points_seen = 0; - test_cancel_at = (match tasks.test_cancel_trigger with - | Some (dbg', n) when dbg = dbg' -> - (* one shot *) - clear_cancel_trigger tasks; - Some n - | _ -> None); - backtrace = Backtrace.empty; - cancellable = true; - } in - Mutex.execute tasks.m - (fun () -> - tasks.task_map := SMap.add t.id t !(tasks.task_map) - ); - t - - (* [run t] executes the task body, updating the fields of [t] *) - let run item = - try - let start = Unix.gettimeofday () in - let result = item.f item in - let duration = Unix.gettimeofday () -. start in - item.state <- Interface.Task.Completed { Interface.Task.duration; result }; - debug "Task %s completed; duration = %.0f" item.id duration - with - | e -> - Backtrace.is_important e; - error "Task %s failed; %s" item.id (Printexc.to_string e); - item.backtrace <- Backtrace.remove e; - let e = e |> Interface.marshal_exn in - item.state <- Interface.Task.Failed e - - let find_locked tasks id = - try - SMap.find id !(tasks.task_map) - with - | _ -> raise (Interface.does_not_exist ("task", id)) - - let to_interface_task t = - { - Interface.Task.id = t.id; - dbg = t.dbg; - ctime = t.ctime; - state = t.state; - subtasks = t.subtasks; - debug_info = [ - "cancel_points_seen", string_of_int t.cancel_points_seen - ]; - backtrace = Sexplib.Sexp.to_string (Backtrace.sexp_of_t t.backtrace); - cancellable = t.cancellable; + let compare = compare + end) + + (** Tasks are stored in an id -> t map *) + type id = string + + (** A task is associated with every running operation *) + type task_handle = { + tasks: tasks + ; id: id (** unique task id *) + ; ctime: float (** created timestamp *) + ; dbg: string (** token sent by client *) + ; mutable state: Interface.Task.state (** current completion state *) + ; mutable subtasks: (string * Interface.Task.state) list + (** one level of "subtasks" *) + ; f: task_handle -> Interface.Task.async_result option + (** body of the function *) + ; tm: Mutex.t (** protects cancelling state *) + ; mutable cancelling: bool (** set by cancel *) + ; mutable cancel: (unit -> unit) list (** attempt to cancel [f] *) + ; mutable cancel_points_seen: int + (** incremented every time we pass a cancellation point *) + ; test_cancel_at: int option (** index of the cancel point to trigger *) + ; mutable backtrace: Backtrace.t (** on error, a backtrace *) + ; mutable cancellable: bool } - let handle_of_id tasks id = - Mutex.execute tasks.m (fun () -> find_locked tasks id) - - let get_state task = - task.state - - let set_state task state = - task.state <- state - - let get_dbg task_handle = - task_handle.dbg - - let replace_assoc key new_value existing = - (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) - - let with_subtask t name f = - let start = Unix.gettimeofday () in - try - t.subtasks <- (name, Interface.Task.Pending 0.) :: t.subtasks; - let result = f () in - let duration = Unix.gettimeofday () -. start in - t.subtasks <- replace_assoc name (Interface.Task.Completed {Interface.Task.duration; result=None}) t.subtasks; - result - with e -> - Backtrace.is_important e; - let e' = Interface.marshal_exn e in - t.subtasks <- replace_assoc name (Interface.Task.Failed e') t.subtasks; - raise e - - let list tasks = - Mutex.execute tasks.m - (fun () -> - SMap.bindings !(tasks.task_map) |> List.map snd - ) - - (* Remove the task from the id -> task mapping. NB any active thread will still continue. *) - let destroy task = - let tasks = task.tasks in - Mutex.execute tasks.m - (fun () -> - tasks.task_map := SMap.remove task.id !(tasks.task_map) - ) - - let cancel task = - let callbacks = Mutex.execute task.tm - (fun () -> - if not task.cancellable then begin - info "Task %s is not cancellable." task.id; - [] - end - else begin - task.cancelling <- true; - task.cancel - end - ) in - List.iter - (fun f -> - try - f () - with e -> - debug "Task.cancel %s: ignore exception %s" task.id (Printexc.to_string e) - ) callbacks - - let raise_cancelled task = - info "Task %s has been cancelled: raising Cancelled exception" task.id; - raise (Interface.cancelled task.id) - - let check_cancelling_locked task = - task.cancel_points_seen <- task.cancel_points_seen + 1; - if task.cancelling then raise_cancelled task; - Opt.iter (fun x -> if task.cancel_points_seen = x then begin - info "Task %s has been triggered by the test-case (cancel_point = %d)" task.id task.cancel_points_seen; - raise_cancelled task - end) task.test_cancel_at - - let check_cancelling t = - Mutex.execute t.tm (fun () -> check_cancelling_locked t) - - let with_cancel t cancel_fn f = - Mutex.execute t.tm (fun () -> - try - check_cancelling_locked t; - t.cancel <- cancel_fn :: t.cancel - with e -> - (try cancel_fn () with e -> debug "Task.cancel %s: ignore exception %s" t.id (Printexc.to_string e)); - raise e); - finally - (fun () -> - check_cancelling t; - f () - ) - (fun () -> Mutex.execute t.tm (fun () -> t.cancel <- List.tl t.cancel)) - - let prohibit_cancellation task = - Mutex.execute task.tm (fun () -> - (* If task is cancelling, just cancel it before setting it to not cancellable *) - check_cancelling_locked task; - task.cancellable <- false) -end + and tasks = { + task_map: task_handle SMap.t ref + ; mutable test_cancel_trigger: (string * int) option + ; m: Mutex.t + ; c: Condition.t + } + + let empty () = + let task_map = ref SMap.empty in + let m = Mutex.create () in + let c = Condition.create () in + {task_map; test_cancel_trigger= None; m; c} + + (* [next_task_id ()] returns a fresh task id *) + let next_task_id = + let counter = ref 0 in + fun () -> + let result = string_of_int !counter in + incr counter ; result + + let set_cancel_trigger tasks dbg n = + Mutex.execute tasks.m (fun () -> + tasks.test_cancel_trigger <- Some (dbg, n)) + + let clear_cancel_trigger tasks = + Mutex.execute tasks.m (fun () -> tasks.test_cancel_trigger <- None) + + let id_of_handle task_handle = task_handle.id + + (* [add dbg f] creates a fresh [t], registers and returns it *) + let add tasks dbg (f : task_handle -> Interface.Task.async_result option) = + let t = + { + tasks + ; id= next_task_id () + ; ctime= Unix.gettimeofday () + ; dbg + ; state= Interface.Task.Pending 0. + ; subtasks= [] + ; f + ; tm= Mutex.create () + ; cancelling= false + ; cancel= [] + ; cancel_points_seen= 0 + ; test_cancel_at= + ( match tasks.test_cancel_trigger with + | Some (dbg', n) when dbg = dbg' -> + (* one shot *) + clear_cancel_trigger tasks ; Some n + | _ -> + None + ) + ; backtrace= Backtrace.empty + ; cancellable= true + } + in + Mutex.execute tasks.m (fun () -> + tasks.task_map := SMap.add t.id t !(tasks.task_map)) ; + t + + (* [run t] executes the task body, updating the fields of [t] *) + let run item = + try + let start = Unix.gettimeofday () in + let result = item.f item in + let duration = Unix.gettimeofday () -. start in + item.state <- Interface.Task.Completed {Interface.Task.duration; result} ; + debug "Task %s completed; duration = %.0f" item.id duration + with e -> + Backtrace.is_important e ; + error "Task %s failed; %s" item.id (Printexc.to_string e) ; + item.backtrace <- Backtrace.remove e ; + let e = e |> Interface.marshal_exn in + item.state <- Interface.Task.Failed e + + let find_locked tasks id = + try SMap.find id !(tasks.task_map) + with _ -> raise (Interface.does_not_exist ("task", id)) + + let to_interface_task t = + { + Interface.Task.id= t.id + ; dbg= t.dbg + ; ctime= t.ctime + ; state= t.state + ; subtasks= t.subtasks + ; debug_info= [("cancel_points_seen", string_of_int t.cancel_points_seen)] + ; backtrace= Sexplib.Sexp.to_string (Backtrace.sexp_of_t t.backtrace) + ; cancellable= t.cancellable + } + + let handle_of_id tasks id = + Mutex.execute tasks.m (fun () -> find_locked tasks id) + + let get_state task = task.state + + let set_state task state = task.state <- state + + let get_dbg task_handle = task_handle.dbg + + let replace_assoc key new_value existing = + (key, new_value) :: List.filter (fun (k, _) -> k <> key) existing + + let with_subtask t name f = + let start = Unix.gettimeofday () in + try + t.subtasks <- (name, Interface.Task.Pending 0.) :: t.subtasks ; + let result = f () in + let duration = Unix.gettimeofday () -. start in + t.subtasks <- + replace_assoc name + (Interface.Task.Completed {Interface.Task.duration; result= None}) + t.subtasks ; + result + with e -> + Backtrace.is_important e ; + let e' = Interface.marshal_exn e in + t.subtasks <- replace_assoc name (Interface.Task.Failed e') t.subtasks ; + raise e + + let list tasks = + Mutex.execute tasks.m (fun () -> + SMap.bindings !(tasks.task_map) |> List.map snd) + + (* Remove the task from the id -> task mapping. NB any active thread will + still continue. *) + let destroy task = + let tasks = task.tasks in + Mutex.execute tasks.m (fun () -> + tasks.task_map := SMap.remove task.id !(tasks.task_map)) + + let cancel task = + let callbacks = + Mutex.execute task.tm (fun () -> + if not task.cancellable then ( + info "Task %s is not cancellable." task.id ; + [] + ) else ( + task.cancelling <- true ; + task.cancel + )) + in + List.iter + (fun f -> + try f () + with e -> + debug "Task.cancel %s: ignore exception %s" task.id + (Printexc.to_string e)) + callbacks + + let raise_cancelled task = + info "Task %s has been cancelled: raising Cancelled exception" task.id ; + raise (Interface.cancelled task.id) + + let check_cancelling_locked task = + task.cancel_points_seen <- task.cancel_points_seen + 1 ; + if task.cancelling then raise_cancelled task ; + Opt.iter + (fun x -> + if task.cancel_points_seen = x then ( + info + "Task %s has been triggered by the test-case (cancel_point = %d)" + task.id task.cancel_points_seen ; + raise_cancelled task + )) + task.test_cancel_at + + let check_cancelling t = + Mutex.execute t.tm (fun () -> check_cancelling_locked t) + + let with_cancel t cancel_fn f = + Mutex.execute t.tm (fun () -> + try + check_cancelling_locked t ; + t.cancel <- cancel_fn :: t.cancel + with e -> + ( try cancel_fn () + with e -> + debug "Task.cancel %s: ignore exception %s" t.id + (Printexc.to_string e) + ) ; + raise e) ; + finally + (fun () -> check_cancelling t ; f ()) + (fun () -> Mutex.execute t.tm (fun () -> t.cancel <- List.tl t.cancel)) + + let prohibit_cancellation task = + Mutex.execute task.tm (fun () -> + (* If task is cancelling, just cancel it before setting it to not + cancellable *) + check_cancelling_locked task ; + task.cancellable <- false) + end diff --git a/lib/task_server.mli b/lib/task_server.mli index 28a1a463..5ab32947 100644 --- a/lib/task_server.mli +++ b/lib/task_server.mli @@ -1,106 +1,116 @@ -(* Task_server: Helper for interfaces of a particular shape - * - * This module is a helper module for interfaces that implement a Task interface - * with which asynchronous calls are implemented. In particular, it handles - * subtasks, cancellation, reporting of backtraces and a way of injecting - * failures at particular points known as 'cancellation triggers' -*) +(* Task_server: Helper for interfaces of a particular shape * * This module is a + helper module for interfaces that implement a Task interface * with which + asynchronous calls are implemented. In particular, it handles * subtasks, + cancellation, reporting of backtraces and a way of injecting * failures at + particular points known as 'cancellation triggers' *) type stringpair = string * string -module type INTERFACE = -sig +module type INTERFACE = sig val service_name : string + val does_not_exist : stringpair -> exn + val cancelled : string -> exn + val marshal_exn : exn -> Rpc.t - module Task : - sig + module Task : sig type id = string + type async_result - type completion_t = { - duration : float; - result : async_result option; - } + + type completion_t = {duration: float; result: async_result option} + type state = - Pending of float + | Pending of float | Completed of completion_t | Failed of Rpc.t + type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool; + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool } end end -module Task : - functor (Interface : INTERFACE) -> - sig +module Task : functor (Interface : INTERFACE) -> sig + (* An [id] is a marshallable reference to a task in a [tasks] type *) + type id = string - (* An [id] is a marshallable reference to a task in a [tasks] type *) - type id = string + (* A [task_handle] is required for all operations on tasks *) + type task_handle - (* A [task_handle] is required for all operations on tasks *) - type task_handle - - (* A [tasks] record contains a list of tasks *) - type tasks - - (* Operations on [tasks] *) - val empty : unit -> tasks - val list : tasks -> task_handle list - - (* After running [set_cancel_trigger tasks dbg n], the next task added with - matching [dbg] will be cancelled on the [n]th time it checks for cancellation *) - val set_cancel_trigger : tasks -> string -> int -> unit - val clear_cancel_trigger : tasks -> unit - - (* Convert between task_handle and id and Interface.Task.t *) - val id_of_handle : task_handle -> id - val handle_of_id : tasks -> id -> task_handle - val to_interface_task : task_handle -> Interface.Task.t - - (* [add tasks dbg f] adds a new task with debug string [dbg] that will execute [f] when run *) - val add : tasks -> string -> (task_handle -> Interface.Task.async_result option) -> task_handle - val run : task_handle -> unit - - (* Query/Set the current state/dbg key of a task *) - val get_state : task_handle -> Interface.Task.state - val set_state : task_handle -> Interface.Task.state -> unit - val get_dbg : task_handle -> string - - (* Given a task, record a specific subtask happening. Subtasks are just for - labelling subsections of a task, and there is no real task hierarchy. *) - val with_subtask : task_handle -> id -> (unit -> 'a) -> 'a - - (* Destroy removes the task from the [tasks] list *) - val destroy : task_handle -> unit - - (* Cancel attempts to cancel a task. This is a cooperative thing, - the task must check ifself whether it has been cancelled. However, any - cancel function passed in via [with_cancel] will be executed after the - task has been marked as cancelled *) - val cancel : task_handle -> unit - - (* This will raise the appropriate exception to record that the - currently executing task has been cancelled. Should be called within the - context of the function [f] from the [add] function call *) - val raise_cancelled : task_handle -> 'a - - (* Checks to see whether the task has been asked to cancel. Raises the - Cancelled exception if it has, or if it has hit the cancellation point - set *) - val check_cancelling : task_handle -> unit - - (* Sets a cancellation function to be called if the task is cancelled *) - val with_cancel : task_handle -> (unit -> unit) -> (unit -> 'a) -> 'a - (* Set a task not cancellable *) - val prohibit_cancellation: task_handle -> unit - end + (* A [tasks] record contains a list of tasks *) + type tasks + + (* Operations on [tasks] *) + val empty : unit -> tasks + + val list : tasks -> task_handle list + + (* After running [set_cancel_trigger tasks dbg n], the next task added with + matching [dbg] will be cancelled on the [n]th time it checks for + cancellation *) + val set_cancel_trigger : tasks -> string -> int -> unit + + val clear_cancel_trigger : tasks -> unit + + (* Convert between task_handle and id and Interface.Task.t *) + val id_of_handle : task_handle -> id + + val handle_of_id : tasks -> id -> task_handle + + val to_interface_task : task_handle -> Interface.Task.t + + (* [add tasks dbg f] adds a new task with debug string [dbg] that will execute + [f] when run *) + val add : + tasks + -> string + -> (task_handle -> Interface.Task.async_result option) + -> task_handle + + val run : task_handle -> unit + + (* Query/Set the current state/dbg key of a task *) + val get_state : task_handle -> Interface.Task.state + + val set_state : task_handle -> Interface.Task.state -> unit + + val get_dbg : task_handle -> string + + (* Given a task, record a specific subtask happening. Subtasks are just for + labelling subsections of a task, and there is no real task hierarchy. *) + val with_subtask : task_handle -> id -> (unit -> 'a) -> 'a + + (* Destroy removes the task from the [tasks] list *) + val destroy : task_handle -> unit + + (* Cancel attempts to cancel a task. This is a cooperative thing, the task + must check ifself whether it has been cancelled. However, any cancel + function passed in via [with_cancel] will be executed after the task has + been marked as cancelled *) + val cancel : task_handle -> unit + + (* This will raise the appropriate exception to record that the currently + executing task has been cancelled. Should be called within the context of + the function [f] from the [add] function call *) + val raise_cancelled : task_handle -> 'a + + (* Checks to see whether the task has been asked to cancel. Raises the + Cancelled exception if it has, or if it has hit the cancellation point set *) + val check_cancelling : task_handle -> unit + + (* Sets a cancellation function to be called if the task is cancelled *) + val with_cancel : task_handle -> (unit -> unit) -> (unit -> 'a) -> 'a + + (* Set a task not cancellable *) + val prohibit_cancellation : task_handle -> unit +end diff --git a/lib/updates.ml b/lib/updates.ml index 3bd9165a..2934b6ea 100644 --- a/lib/updates.ml +++ b/lib/updates.ml @@ -9,225 +9,230 @@ module type INTERFACE = sig module Dynamic : sig type id + val rpc_of_id : id -> Rpc.t end end -module Updates = functor(Interface : INTERFACE) -> struct - - module UpdateRecorder = functor(Ord: Map.OrderedType) -> struct - (* Map of thing -> last update counter *) - module M = Map.Make(struct - type t = Ord.t - let compare = compare - end) - - type id = int - - (* Type for inner snapshot that we create when injecting a barrier *) - type barrier = { - bar_id: int; (** This int is a token from outside. *) - map_s: int M.t; (** Snapshot of main map *) - event_id: id (** Snapshot of "next" from when barrier was injected *) - } - - type t = { - map: int M.t; (** Events with incrementing ids from "next" *) - barriers: barrier list; - next: id - } - - let initial = 0 - - let empty = { - map = M.empty; - barriers = []; - next = initial + 1; - } - - let add x t = { - map = M.add x t.next t.map; - barriers = t.barriers; - next = t.next + 1 - }, t.next + 1 - - let remove x t = { - map = M.remove x t.map; - barriers = t.barriers; - next = t.next + 1 - }, t.next + 1 - - let filter f t = { - map = M.filter f t.map; - barriers = t.barriers; - next = t.next + 1 - }, t.next + 1 - - let inject_barrier id filterfn t = { - map = t.map; - barriers = { - bar_id = id; - map_s = M.filter filterfn t.map; - event_id = t.next - }::t.barriers; - next = t.next + 1 - }, t.next + 1 - - let remove_barrier id t = { - map = t.map; - barriers = List.filter (fun br -> br.bar_id <> id) t.barriers; - next = t.next + 1 - }, t.next + 1 - - let get from t = - (* [from] is the id of the most recent event already seen *) - let get_from_map map = - let _before, after = M.partition (fun _ time -> time <= from) map in - let xs, last = M.fold (fun key v (acc, m) -> (key, v) :: acc, max m v) after ([], from) in - let xs = List.sort (fun (_, v1) (_, v2) -> compare v1 v2) xs - |> List.map fst - in - xs, last +module Updates = +functor + (Interface : INTERFACE) + -> + struct + module UpdateRecorder = + functor + (Ord : Map.OrderedType) + -> + struct + (* Map of thing -> last update counter *) + module M = Map.Make (struct + type t = Ord.t + + let compare = compare + end) + + type id = int + + (* Type for inner snapshot that we create when injecting a barrier *) + type barrier = { + bar_id: int (** This int is a token from outside. *) + ; map_s: int M.t (** Snapshot of main map *) + ; event_id: id + (** Snapshot of "next" from when barrier was injected *) + } + + type t = { + map: int M.t (** Events with incrementing ids from "next" *) + ; barriers: barrier list + ; next: id + } + + let initial = 0 + + let empty = {map= M.empty; barriers= []; next= initial + 1} + + let add x t = + ( {map= M.add x t.next t.map; barriers= t.barriers; next= t.next + 1} + , t.next + 1 ) + + let remove x t = + ( {map= M.remove x t.map; barriers= t.barriers; next= t.next + 1} + , t.next + 1 ) + + let filter f t = + ( {map= M.filter f t.map; barriers= t.barriers; next= t.next + 1} + , t.next + 1 ) + + let inject_barrier id filterfn t = + ( { + map= t.map + ; barriers= + {bar_id= id; map_s= M.filter filterfn t.map; event_id= t.next} + :: t.barriers + ; next= t.next + 1 + } + , t.next + 1 ) + + let remove_barrier id t = + ( { + map= t.map + ; barriers= List.filter (fun br -> br.bar_id <> id) t.barriers + ; next= t.next + 1 + } + , t.next + 1 ) + + let get from t = + (* [from] is the id of the most recent event already seen *) + let get_from_map map = + let _before, after = M.partition (fun _ time -> time <= from) map in + let xs, last = + M.fold + (fun key v (acc, m) -> ((key, v) :: acc, max m v)) + after ([], from) + in + let xs = + List.sort (fun (_, v1) (_, v2) -> compare v1 v2) xs + |> List.map fst + in + (xs, last) + in + let rec filter_barriers bl acc = + match bl with + (* Stops at first too-old one, unlike List.filter *) + | x :: xs when x.event_id > from -> + filter_barriers xs (x :: acc) + | _ -> + List.rev acc + in + let recent_b = filter_barriers t.barriers [] in + let barriers = + List.map + (fun br -> (br.bar_id, get_from_map br.map_s |> fst)) + recent_b + in + let rest, last_event = get_from_map t.map in + let last = + match recent_b with + (* assumes recent_b is sorted newest-first *) + | [] -> + last_event + | x :: _ -> + max last_event x.event_id + in + (* Barriers are stored newest-first, reverse to return them in order *) + (List.rev barriers, rest, last) + + let last_id t = t.next - 1 + + (* let fold f t init = M.fold f t.map init *) + end + + open Xapi_stdext_threads.Threadext + + module U = UpdateRecorder (struct + type t = Interface.Dynamic.id + + let compare = compare + end) + + type id = U.id + + type t = {mutable u: U.t; c: Condition.t; s: Scheduler.t; m: Mutex.t} + + let empty scheduler = + {u= U.empty; c= Condition.create (); s= scheduler; m= Mutex.create ()} + + type get_result = + (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id + + let get dbg ?(with_cancel = fun _ f -> f ()) from timeout t = + let from = Opt.default U.initial from in + let cancel = ref false in + let cancel_fn () = + Mutex.execute t.m (fun () -> + cancel := true ; + Condition.broadcast t.c) in - let rec filter_barriers bl acc = - match bl with (* Stops at first too-old one, unlike List.filter *) - | x::xs when (x.event_id > from) -> - filter_barriers xs (x::acc) - | _ -> List.rev acc + let id = + Opt.map + (fun timeout -> + Scheduler.one_shot t.s (Scheduler.Delta timeout) dbg cancel_fn) + timeout in - let recent_b = filter_barriers t.barriers [] in - let barriers = List.map (fun (br) -> (br.bar_id,get_from_map br.map_s |> fst)) recent_b in - let rest,last_event = get_from_map t.map in - let last = match recent_b with - (* assumes recent_b is sorted newest-first *) - | [] -> last_event - | x::_ -> max last_event x.event_id in - (* Barriers are stored newest-first, reverse to return them in order *) - (List.rev barriers, rest, last) - - let last_id t = t.next - 1 - -(* let fold f t init = M.fold f t.map init *) - end - - open Xapi_stdext_threads.Threadext - - module U = UpdateRecorder(struct type t = Interface.Dynamic.id let compare = compare end) - - type id = U.id - - type t = { - mutable u: U.t; - c: Condition.t; - s: Scheduler.t; - m: Mutex.t; - } - - let empty scheduler = { - u = U.empty; - c = Condition.create (); - s = scheduler; - m = Mutex.create (); - } - - type get_result = - (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id - - let get dbg ?(with_cancel=(fun _ f -> f ())) from timeout t = - let from = Opt.default U.initial from in - let cancel = ref false in - let cancel_fn () = - Mutex.execute t.m - (fun () -> - cancel := true; - Condition.broadcast t.c - ) - in - let id = Opt.map (fun timeout -> - Scheduler.one_shot t.s (Scheduler.Delta timeout) dbg cancel_fn - ) timeout in - with_cancel cancel_fn (fun () -> - finally (fun () -> - Mutex.execute t.m (fun () -> - let is_empty (x,y,_) = x=[] && y=[] in - - let rec wait () = - let result = U.get from t.u in - if is_empty result && not (!cancel) then - begin Condition.wait t.c t.m; wait () end - else result - in - wait () - ) - ) (fun () -> Opt.iter (Scheduler.cancel t.s) id)) - - let last_id _dbg t = - Mutex.execute t.m - (fun () -> - U.last_id t.u - ) - - let add x t = - Mutex.execute t.m - (fun () -> - let result, _id = U.add x t.u in - t.u <- result; - Condition.broadcast t.c - ) - - let remove x t = - Mutex.execute t.m - (fun () -> - let result, _id = U.remove x t.u in - t.u <- result; - Condition.broadcast t.c - ) - - let filter f t = - Mutex.execute t.m - (fun () -> - let result, _id = U.filter (fun x _y -> f x) t.u in - t.u <- result; - Condition.broadcast t.c - ) - - let inject_barrier id filter t = - Mutex.execute t.m - (fun () -> - let result, _id = U.inject_barrier id filter t.u in - t.u <- result; - Condition.broadcast t.c) - - let remove_barrier id t = - Mutex.execute t.m - (fun () -> - let result, _id = U.remove_barrier id t.u in - t.u <- result; - Condition.broadcast t.c) - - module Dump = struct - type u = { - id: int; - v: string; - } [@@deriving rpc] - type dump = { - updates: u list; - barriers : (int * int * (u list)) list; - (* In barriers, first int is token id of barrier; - * second int is event id of snapshot (from "next") *) - } [@@deriving rpc] - let make_list updates = - U.M.fold (fun key v acc -> { id = v; v = (key |> Interface.Dynamic.rpc_of_id |> Jsonrpc.to_string) } :: acc) updates [] - let make_raw u = - { updates = make_list u.U.map; - barriers = List.map (fun (br) -> (br.U.bar_id, br.U.event_id, make_list br.U.map_s)) u.U.barriers; + with_cancel cancel_fn (fun () -> + finally + (fun () -> + Mutex.execute t.m (fun () -> + let is_empty (x, y, _) = x = [] && y = [] in + let rec wait () = + let result = U.get from t.u in + if is_empty result && not !cancel then ( + Condition.wait t.c t.m ; wait () + ) else + result + in + wait ())) + (fun () -> Opt.iter (Scheduler.cancel t.s) id)) + + let last_id _dbg t = Mutex.execute t.m (fun () -> U.last_id t.u) + + let add x t = + Mutex.execute t.m (fun () -> + let result, _id = U.add x t.u in + t.u <- result ; + Condition.broadcast t.c) + + let remove x t = + Mutex.execute t.m (fun () -> + let result, _id = U.remove x t.u in + t.u <- result ; + Condition.broadcast t.c) + + let filter f t = + Mutex.execute t.m (fun () -> + let result, _id = U.filter (fun x _y -> f x) t.u in + t.u <- result ; + Condition.broadcast t.c) + + let inject_barrier id filter t = + Mutex.execute t.m (fun () -> + let result, _id = U.inject_barrier id filter t.u in + t.u <- result ; + Condition.broadcast t.c) + + let remove_barrier id t = + Mutex.execute t.m (fun () -> + let result, _id = U.remove_barrier id t.u in + t.u <- result ; + Condition.broadcast t.c) + + module Dump = struct + type u = {id: int; v: string} [@@deriving rpc] + + type dump = { + updates: u list + ; barriers: (int * int * u list) list + (* In barriers, first int is token id of barrier; * second int is + event id of snapshot (from "next") *) } - let make t = - Mutex.execute t.m - (fun () -> - make_raw t.u - ) + [@@deriving rpc] + + let make_list updates = + U.M.fold + (fun key v acc -> + {id= v; v= key |> Interface.Dynamic.rpc_of_id |> Jsonrpc.to_string} + :: acc) + updates [] + + let make_raw u = + { + updates= make_list u.U.map + ; barriers= + List.map + (fun br -> (br.U.bar_id, br.U.event_id, make_list br.U.map_s)) + u.U.barriers + } + + let make t = Mutex.execute t.m (fun () -> make_raw t.u) + end end - - -end diff --git a/lib/updates.mli b/lib/updates.mli index 7e31d982..a054c558 100644 --- a/lib/updates.mli +++ b/lib/updates.mli @@ -1,83 +1,85 @@ -(** This module is a helper for interfaces of a particular shape. - * - * The idea is that updates are generated by a component when another - * component should be notified of events. For example, when a VM changes - * state, xenopsd uses this interface so that xapi knows something has - * changed. The updates contain no information other than that something - * has changed, so additionally the interface needs to have some sort of - * mechanism for querying the current state of the object in question. - * - * This module provides functions for adding updates, adding barriers - * (which contain a snapshot of the current updates), and a blocking call to - * that returns the latest set of updates, optionally given a token that - * represents the last set of updates received. -*) - -module type INTERFACE = -sig +(** This module is a helper for interfaces of a particular shape. * * The idea + is that updates are generated by a component when another * component should + be notified of events. For example, when a VM changes * state, xenopsd uses + this interface so that xapi knows something has * changed. The updates + contain no information other than that something * has changed, so + additionally the interface needs to have some sort of * mechanism for + querying the current state of the object in question. * * This module + provides functions for adding updates, adding barriers * (which contain a + snapshot of the current updates), and a blocking call to * that returns the + latest set of updates, optionally given a token that * represents the last + set of updates received. *) + +module type INTERFACE = sig val service_name : string - module Dynamic : - sig type id val rpc_of_id : id -> Rpc.t end + + module Dynamic : sig + type id + + val rpc_of_id : id -> Rpc.t + end end -module Updates : - functor (Interface : INTERFACE) -> - sig - type id = int - - (* Updates are kept in a `t` *) - type t - - (* Create an empty updates recorder using the given scheduler *) - val empty : Scheduler.t -> t - - (* last_id [dbg] [t] returns the last id that's in use in [t] *) - val last_id : string -> t -> int - - (* The return type for `get`. Returns a list of barriers, then a list of updates, then a token - to pass to the next invocation of `get` *) - type get_result = (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id - - (* [get dbg ?with_cancel from timeout t] is a blocking call that will return all the updates - recorded in [t] since [from] (or for all time if [from] is None). [timeout], if it is - not None, is the timeout in seconds to wait. [dbg] is a debug string. [with_cancel] is - a function passed in that allows this call to be cancelled. See Task_server.with_cancel - for an example function that may be used *) - val get : - string -> - ?with_cancel:((unit -> unit) -> - (unit -> get_result) -> get_result) -> - id option -> - int option -> t -> get_result - - (* Add an update to a particular type of item (e.g. 'VM' or 'VBD', defined in INTERFACE) *) - val add : Interface.Dynamic.id -> t -> unit - - (* Remove an update *) - val remove : Interface.Dynamic.id -> t -> unit - - (* Filter updates to remove those that don't satisfy the predicate passed in *) - val filter : (Interface.Dynamic.id -> bool) -> t -> unit - - (* [inject_barrier n p t] Inject a barrier identified by [n] into [t]. The barrier will contain a - snapshot of all current updates that match the predicate [p]. *) - val inject_barrier : int -> (Interface.Dynamic.id -> int -> bool) -> t -> unit - - (* Removes a barrier *) - val remove_barrier : int -> t -> unit - - (* The Dump module is to dump the internal state of the Updates value for debugging - purposes *) - module Dump : - sig - type u = { id : int; v : string; } - type dump = { - updates : u list; - barriers : (int * int * u list) list; - } - val rpc_of_dump : dump -> Rpc.t - val dump_of_rpc : Rpc.t -> dump - val make : t -> dump - end +module Updates : functor (Interface : INTERFACE) -> sig + type id = int + + (* Updates are kept in a `t` *) + type t + + (* Create an empty updates recorder using the given scheduler *) + val empty : Scheduler.t -> t + + (* last_id [dbg] [t] returns the last id that's in use in [t] *) + val last_id : string -> t -> int + + (* The return type for `get`. Returns a list of barriers, then a list of + updates, then a token to pass to the next invocation of `get` *) + type get_result = + (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id + + (* [get dbg ?with_cancel from timeout t] is a blocking call that will return + all the updates recorded in [t] since [from] (or for all time if [from] is + None). [timeout], if it is not None, is the timeout in seconds to wait. + [dbg] is a debug string. [with_cancel] is a function passed in that allows + this call to be cancelled. See Task_server.with_cancel for an example + function that may be used *) + val get : + string + -> ?with_cancel:((unit -> unit) -> (unit -> get_result) -> get_result) + -> id option + -> int option + -> t + -> get_result + + (* Add an update to a particular type of item (e.g. 'VM' or 'VBD', defined in + INTERFACE) *) + val add : Interface.Dynamic.id -> t -> unit + (* Remove an update *) + val remove : Interface.Dynamic.id -> t -> unit + + (* Filter updates to remove those that don't satisfy the predicate passed in *) + val filter : (Interface.Dynamic.id -> bool) -> t -> unit + + (* [inject_barrier n p t] Inject a barrier identified by [n] into [t]. The + barrier will contain a snapshot of all current updates that match the + predicate [p]. *) + val inject_barrier : int -> (Interface.Dynamic.id -> int -> bool) -> t -> unit + + (* Removes a barrier *) + val remove_barrier : int -> t -> unit + + (* The Dump module is to dump the internal state of the Updates value for + debugging purposes *) + module Dump : sig + type u = {id: int; v: string} + + type dump = {updates: u list; barriers: (int * int * u list) list} + + val rpc_of_dump : dump -> Rpc.t + + val dump_of_rpc : Rpc.t -> dump + + val make : t -> dump end +end diff --git a/lib/xcp_channel.ml b/lib/xcp_channel.ml index fa07fede..395da851 100644 --- a/lib/xcp_channel.ml +++ b/lib/xcp_channel.ml @@ -1,9 +1,11 @@ type t = Unix.file_descr let file_descr_of_t t = t + let t_of_file_descr t = t [@@@ocaml.warning "-34"] + type protocols = Xcp_channel_protocol.t list [@@deriving rpc] let rpc_of_t fd = @@ -13,4 +15,3 @@ let rpc_of_t fd = let t_of_rpc x = let protocols = protocols_of_rpc x in Posix_channel.receive protocols - diff --git a/lib/xcp_channel.mli b/lib/xcp_channel.mli index 6bb96802..35849a1e 100644 --- a/lib/xcp_channel.mli +++ b/lib/xcp_channel.mli @@ -1,10 +1,13 @@ type t -val rpc_of_t: t -> Rpc.t -val t_of_rpc: Rpc.t -> t +val rpc_of_t : t -> Rpc.t -val file_descr_of_t: t -> Unix.file_descr -val t_of_file_descr: Unix.file_descr -> t +val t_of_rpc : Rpc.t -> t -val protocols_of_rpc: Rpc.t -> Xcp_channel_protocol.t list -val rpc_of_protocols: Xcp_channel_protocol.t list -> Rpc.t +val file_descr_of_t : t -> Unix.file_descr + +val t_of_file_descr : Unix.file_descr -> t + +val protocols_of_rpc : Rpc.t -> Xcp_channel_protocol.t list + +val rpc_of_protocols : Xcp_channel_protocol.t list -> Rpc.t diff --git a/lib/xcp_channel_protocol.ml b/lib/xcp_channel_protocol.ml index f321484a..76730ba4 100644 --- a/lib/xcp_channel_protocol.ml +++ b/lib/xcp_channel_protocol.ml @@ -13,9 +13,7 @@ *) type t = - | TCP_proxy of string * int (** IP, port *) - | V4V_proxy of int * int (** domid, port *) - | Unix_sendmsg of int * string * string (** domid, path, token *) + | TCP_proxy of string * int (** IP, port *) + | V4V_proxy of int * int (** domid, port *) + | Unix_sendmsg of int * string * string (** domid, path, token *) [@@deriving rpc] - - diff --git a/lib/xcp_channel_protocol.mli b/lib/xcp_channel_protocol.mli index a432b2ff..4751e484 100644 --- a/lib/xcp_channel_protocol.mli +++ b/lib/xcp_channel_protocol.mli @@ -13,10 +13,10 @@ *) type t = - | TCP_proxy of string * int (** IP, port *) - | V4V_proxy of int * int (** domid, port *) - | Unix_sendmsg of int * string * string (** domid, path, token *) + | TCP_proxy of string * int (** IP, port *) + | V4V_proxy of int * int (** domid, port *) + | Unix_sendmsg of int * string * string (** domid, path, token *) -val rpc_of_t: t -> Rpc.t -val t_of_rpc: Rpc.t -> t +val rpc_of_t : t -> Rpc.t +val t_of_rpc : Rpc.t -> t diff --git a/lib/xcp_client.ml b/lib/xcp_client.ml index fafc8eba..ef12ac99 100644 --- a/lib/xcp_client.ml +++ b/lib/xcp_client.ml @@ -14,91 +14,115 @@ (* Generic RPC marshalling functions for XCP services *) -module Request = Cohttp.Request.Make(Cohttp_posix_io.Buffered_IO) -module Response = Cohttp.Response.Make(Cohttp_posix_io.Buffered_IO) +module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) +module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) let get_user_agent () = Sys.argv.(0) let switch_path = ref "/var/run/message-switch/sock" + let use_switch = ref true let get_ok = function - | `Ok x -> x + | `Ok x -> + x | `Error e -> let b = Buffer.create 16 in let fmt = Format.formatter_of_buffer b in - Message_switch_unix.Protocol_unix.Client.pp_error fmt e; - Format.pp_print_flush fmt (); + Message_switch_unix.Protocol_unix.Client.pp_error fmt e ; + Format.pp_print_flush fmt () ; failwith (Buffer.contents b) let switch_rpc ?timeout queue_name string_of_call response_of_string = - let t = get_ok (Message_switch_unix.Protocol_unix.Client.connect ~switch:!switch_path ()) in - fun call -> - response_of_string (get_ok (Message_switch_unix.Protocol_unix.Client.rpc ~t ?timeout ~queue:queue_name ~body:(string_of_call call) ())) + let t = + get_ok + (Message_switch_unix.Protocol_unix.Client.connect ~switch:!switch_path ()) + in + fun call -> + response_of_string + (get_ok + (Message_switch_unix.Protocol_unix.Client.rpc ~t ?timeout + ~queue:queue_name ~body:(string_of_call call) ())) let split_colon str = try let x = String.index str ':' in let uname = String.sub str 0 x in - let passwd = String.sub str (x+1) (String.length str - x - 1) in - [uname ; passwd] - with Not_found -> - [str] + let passwd = String.sub str (x + 1) (String.length str - x - 1) in + [uname; passwd] + with Not_found -> [str] (* Use HTTP to frame RPC messages *) [@@@ocaml.warning "-27"] -let http_rpc string_of_call response_of_string ?(srcstr="unset") ?(dststr="unset") url call = - let uri = Uri.of_string (url ()) in - let req = string_of_call call in - - let headers = Cohttp.Header.of_list [ - "User-agent", get_user_agent (); - "content-length", string_of_int (String.length req); - ] in - (* If we have a username:password@ then use basic authentication *) - let userinfo = Uri.userinfo uri in - let headers = match userinfo with - | Some x -> - begin match split_colon x with - | username :: password :: [] -> - Cohttp.Header.add_authorization headers (`Basic (username, password)) - | _ -> headers - end - | None -> headers in - - let http_req = Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers uri in +let http_rpc string_of_call response_of_string ?(srcstr = "unset") + ?(dststr = "unset") url call = + let uri = Uri.of_string (url ()) in + let req = string_of_call call in + let headers = + Cohttp.Header.of_list + [ + ("User-agent", get_user_agent ()) + ; ("content-length", string_of_int (String.length req)) + ] + in + (* If we have a username:password@ then use basic authentication *) + let userinfo = Uri.userinfo uri in + let headers = + match userinfo with + | Some x -> ( + match split_colon x with + | [username; password] -> + Cohttp.Header.add_authorization headers (`Basic (username, password)) + | _ -> + headers + ) + | None -> + headers + in + let http_req = + Cohttp.Request.make ~meth:`POST ~version:`HTTP_1_1 ~headers uri + in + Open_uri.with_open_uri uri (fun fd -> + let ic = Unix.in_channel_of_descr fd in + let oc = Unix.out_channel_of_descr fd in + Request.write (fun writer -> Request.write_body writer req) http_req oc ; + match Response.read ic with + | `Eof -> + failwith + (Printf.sprintf "Failed to read HTTP response from: %s" (url ())) + | `Invalid x -> + failwith + (Printf.sprintf "Failed to read HTTP response from: %s (got '%s')" + (url ()) x) + | `Ok response -> ( + let body = Buffer.create 16 in + let reader = Response.make_body_reader response ic in + let rec loop () = + match Response.read_body_chunk reader with + | Cohttp.Transfer.Chunk x -> + Buffer.add_string body x ; loop () + | Cohttp.Transfer.Final_chunk x -> + Buffer.add_string body x + | Cohttp.Transfer.Done -> + () + in + loop () ; + let body = Buffer.contents body |> response_of_string in + match Cohttp.Response.status response with + | `OK -> + body + | bad -> + failwith + (Printf.sprintf "Unexpected HTTP response code: %s" + (Cohttp.Code.string_of_status bad)) + )) - Open_uri.with_open_uri uri - (fun fd -> - let ic = Unix.in_channel_of_descr fd in - let oc = Unix.out_channel_of_descr fd in - Request.write (fun writer -> Request.write_body writer req) http_req oc; - match Response.read ic with - | `Eof -> failwith (Printf.sprintf "Failed to read HTTP response from: %s" (url ())) - | `Invalid x -> failwith (Printf.sprintf "Failed to read HTTP response from: %s (got '%s')" (url ()) x) - | `Ok response -> - let body = Buffer.create 16 in - let reader = Response.make_body_reader response ic in - let rec loop () = - match Response.read_body_chunk reader with - | Cohttp.Transfer.Chunk x -> - Buffer.add_string body x; - loop() - | Cohttp.Transfer.Final_chunk x -> - Buffer.add_string body x - | Cohttp.Transfer.Done -> - () - in - loop (); - let body = Buffer.contents body |> response_of_string in - begin match Cohttp.Response.status response with - | `OK -> body - | bad -> failwith (Printf.sprintf "Unexpected HTTP response code: %s" (Cohttp.Code.string_of_status bad)) - end - ) let xml_http_rpc = http_rpc Xmlrpc.string_of_call Xmlrpc.response_of_string -let json_switch_rpc ?timeout queue_name = switch_rpc ?timeout queue_name Jsonrpc.string_of_call Jsonrpc.response_of_string + +let json_switch_rpc ?timeout queue_name = + switch_rpc ?timeout queue_name Jsonrpc.string_of_call + Jsonrpc.response_of_string let () = Printexc.register_printer (function @@ -106,28 +130,30 @@ let () = Some (Printf.sprintf "Xmlm.Error(%d:%d, \"%s\")" line col (Xmlm.error_message error)) - | _ -> None ) + | _ -> + None) (* Use a binary 16-byte length to frame RPC messages *) -let binary_rpc string_of_call response_of_string ?(srcstr="unset") ?(dststr="unset") url (call: Rpc.call) : Rpc.response = - let uri = Uri.of_string (url ()) in - Open_uri.with_open_uri uri - (fun fd -> - let ic = Unix.in_channel_of_descr fd in - let oc = Unix.out_channel_of_descr fd in - let msg_buf = string_of_call call in - let len = Printf.sprintf "%016d" (String.length msg_buf) in - output_string oc len; - output_string oc msg_buf; - flush oc; - let len_buf = Bytes.make 16 '\000' in - really_input ic len_buf 0 16; - let len = int_of_string (Bytes.unsafe_to_string len_buf) in - let msg_buf = Bytes.make len '\000' in - really_input ic msg_buf 0 len; - let (response: Rpc.response) = response_of_string (Bytes.unsafe_to_string msg_buf) in - response - ) - -let json_binary_rpc = binary_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string - +let binary_rpc string_of_call response_of_string ?(srcstr = "unset") + ?(dststr = "unset") url (call : Rpc.call) : Rpc.response = + let uri = Uri.of_string (url ()) in + Open_uri.with_open_uri uri (fun fd -> + let ic = Unix.in_channel_of_descr fd in + let oc = Unix.out_channel_of_descr fd in + let msg_buf = string_of_call call in + let len = Printf.sprintf "%016d" (String.length msg_buf) in + output_string oc len ; + output_string oc msg_buf ; + flush oc ; + let len_buf = Bytes.make 16 '\000' in + really_input ic len_buf 0 16 ; + let len = int_of_string (Bytes.unsafe_to_string len_buf) in + let msg_buf = Bytes.make len '\000' in + really_input ic msg_buf 0 len ; + let (response : Rpc.response) = + response_of_string (Bytes.unsafe_to_string msg_buf) + in + response) + +let json_binary_rpc = + binary_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string diff --git a/lib/xcp_const.ml b/lib/xcp_const.ml index 81aee064..dcd7b295 100644 --- a/lib/xcp_const.ml +++ b/lib/xcp_const.ml @@ -1 +1,2 @@ -let good_ciphersuites = "ECDHE-RSA-AES256-SHA384:ECDHE-RSA-AES256-GCM-SHA384:AES256-SHA256:AES128-SHA256" +let good_ciphersuites = + "ECDHE-RSA-AES256-SHA384:ECDHE-RSA-AES256-GCM-SHA384:AES256-SHA256:AES128-SHA256" diff --git a/lib/xcp_pci.ml b/lib/xcp_pci.ml index 354d6294..bdeaf088 100644 --- a/lib/xcp_pci.ml +++ b/lib/xcp_pci.ml @@ -1,17 +1,12 @@ open Sexplib.Std -type address = { - domain: int; - bus: int; - dev: int; - fn: int; -} +type address = {domain: int; bus: int; dev: int; fn: int} [@@deriving sexp, rpc, rpcty] let address_of_string str = - Scanf.sscanf str "%04x:%02x:%02x.%x" - (fun domain bus dev fn -> {domain; bus; dev; fn}) + Scanf.sscanf str "%04x:%02x:%02x.%x" (fun domain bus dev fn -> + {domain; bus; dev; fn}) let string_of_address address = - Printf.sprintf "%04x:%02x:%02x.%x" - address.domain address.bus address.dev address.fn + Printf.sprintf "%04x:%02x:%02x.%x" address.domain address.bus address.dev + address.fn diff --git a/lib/xcp_service.ml b/lib/xcp_service.ml index 41a05a0e..2d1d1bb2 100644 --- a/lib/xcp_service.ml +++ b/lib/xcp_service.ml @@ -12,422 +12,528 @@ * GNU Lesser General Public License for more details. *) open Xapi_stdext_monadic -module StringSet = Set.Make(String) +module StringSet = Set.Make (String) (* Server configuration. We have built-in (hopefully) sensible defaults, - together with command-line arguments and a configuration file. They - are applied in order: (latest takes precedence) - defaults < arguments < config file -*) + together with command-line arguments and a configuration file. They are + applied in order: (latest takes precedence) defaults < arguments < config + file *) let default_service_name = Filename.basename Sys.argv.(0) + let config_file = ref (Printf.sprintf "/etc/%s.conf" default_service_name) + let config_dir = ref (Printf.sprintf "/etc/%s.conf.d" default_service_name) + let pidfile = ref (Printf.sprintf "/var/run/%s.pid" default_service_name) + let extra_search_path = ref [] + let log_destination = ref "syslog:daemon" + let log_level = ref Syslog.Debug + let daemon = ref false + let have_daemonized () = Unix.getppid () = 1 let common_prefix = "org.xen.xapi." let finally f g = - try - let result = f () in - g (); - result - with e -> - g (); - raise e + try + let result = f () in + g () ; result + with e -> g () ; raise e type opt = string * Arg.spec * (unit -> string) * string -module D = Debug.Make(struct let name = default_service_name end) +module D = Debug.Make (struct let name = default_service_name end) + open D module Config_file = struct - open Arg - - let apply v = function - | Unit f -> f () - | Bool f -> f (bool_of_string v) - | Set b -> b := (bool_of_string v) - | Clear b -> b := not (bool_of_string v) - | String f -> f v - | Set_string s -> s := v - | Int f -> f (int_of_string v) - | Set_int i -> i := (int_of_string v) - | Float f -> f (float_of_string v) - | Set_float f -> f := (float_of_string v) - | _ -> failwith "Unsupported type in config file" - - (* Trim trailing whitespace from a line *) - let trim_trailing_ws line = - let re_ws = Re.compile (Re.Emacs.re "[ \t]+$") in - try - let ofs = fst (Re.Group.all_offset (Re.exec re_ws line)).(0) in - String.sub line 0 ofs - with Not_found -> - line - - let trim_comment line = - try - let i = String.index line '#' in - String.sub line 0 i - with Not_found -> line - - let get_kv line = - let re = Re.compile (Re.Emacs.re "\\([^=\\ \t]+\\)[\\ \t]*=[\\ \t]*\\(.*\\)") in - let get (x,y) = String.sub line x (y-x) in - try - match Re.Group.all_offset (Re.exec re line) with - | [| _; key_ofs; v_ofs |] -> - (* First in array is always the full extent of all matches *) - Some (get key_ofs, get v_ofs) - | _ -> - None - with _ -> - None - - let strip_quotes (k,v) = - if String.length v < 2 - then (k,v) - else - let first = v.[0] and last = v.[String.length v - 1] in - if first = last && (first = '"' || first = '\'') - then (k,String.sub v 1 (String.length v - 2)) - else (k,v) - - let parse_line line = - (* Strip comments *) - let stripped = line |> trim_comment |> trim_trailing_ws in - let lift f x = Some (f x) in - let (>>=) m f = match m with Some x -> f x | None -> None in - get_kv stripped >>= lift strip_quotes - - let process_line data spec = - let spec = List.map (fun (a, b, _, _) -> a, b) spec in - match parse_line data with - | Some (key,v) -> - if List.mem_assoc key spec then apply v (List.assoc key spec) - | None -> () - - let parse filename spec = - (* Remove the unnecessary doc parameter *) - let ic = open_in filename in - finally - (fun () -> - try - while true do - let line = input_line ic in - process_line line spec - done - with End_of_file -> () - ) (fun () -> close_in ic) - - let dump spec = - List.iter (fun (name, _, printer, description) -> - debug "%s = %s (%s)" name (printer ()) description - ) spec - + open Arg + + let apply v = function + | Unit f -> + f () + | Bool f -> + f (bool_of_string v) + | Set b -> + b := bool_of_string v + | Clear b -> + b := not (bool_of_string v) + | String f -> + f v + | Set_string s -> + s := v + | Int f -> + f (int_of_string v) + | Set_int i -> + i := int_of_string v + | Float f -> + f (float_of_string v) + | Set_float f -> + f := float_of_string v + | _ -> + failwith "Unsupported type in config file" + + (* Trim trailing whitespace from a line *) + let trim_trailing_ws line = + let re_ws = Re.compile (Re.Emacs.re "[ \t]+$") in + try + let ofs = fst (Re.Group.all_offset (Re.exec re_ws line)).(0) in + String.sub line 0 ofs + with Not_found -> line + + let trim_comment line = + try + let i = String.index line '#' in + String.sub line 0 i + with Not_found -> line + + let get_kv line = + let re = + Re.compile (Re.Emacs.re "\\([^=\\ \t]+\\)[\\ \t]*=[\\ \t]*\\(.*\\)") + in + let get (x, y) = String.sub line x (y - x) in + try + match Re.Group.all_offset (Re.exec re line) with + | [|_; key_ofs; v_ofs|] -> + (* First in array is always the full extent of all matches *) + Some (get key_ofs, get v_ofs) + | _ -> + None + with _ -> None + + let strip_quotes (k, v) = + if String.length v < 2 then + (k, v) + else + let first = v.[0] and last = v.[String.length v - 1] in + if first = last && (first = '"' || first = '\'') then + (k, String.sub v 1 (String.length v - 2)) + else + (k, v) + + let parse_line line = + (* Strip comments *) + let stripped = line |> trim_comment |> trim_trailing_ws in + let lift f x = Some (f x) in + let ( >>= ) m f = match m with Some x -> f x | None -> None in + get_kv stripped >>= lift strip_quotes + + let process_line data spec = + let spec = List.map (fun (a, b, _, _) -> (a, b)) spec in + match parse_line data with + | Some (key, v) -> + if List.mem_assoc key spec then apply v (List.assoc key spec) + | None -> + () + + let parse filename spec = + (* Remove the unnecessary doc parameter *) + let ic = open_in filename in + finally + (fun () -> + try + while true do + let line = input_line ic in + process_line line spec + done + with End_of_file -> ()) + (fun () -> close_in ic) + + let dump spec = + List.iter + (fun (name, _, printer, description) -> + debug "%s = %s (%s)" name (printer ()) description) + spec end let rec split_c c str = try let i = String.index str c in - String.sub str 0 i :: (split_c c (String.sub str (i+1) (String.length str - i - 1))) + String.sub str 0 i + :: split_c c (String.sub str (i + 1) (String.length str - i - 1)) with Not_found -> [str] let setify = let rec loop acc = function - | [] -> acc - | x :: xs -> (if List.mem x acc then loop acc else loop (x :: acc)) xs in + | [] -> + acc + | x :: xs -> + (if List.mem x acc then loop acc else loop (x :: acc)) xs + in loop [] -let common_options = [ - "use-switch", Arg.Bool (fun b -> Xcp_client.use_switch := b), (fun () -> string_of_bool !Xcp_client.use_switch), "true if the message switch is to be enabled"; - "switch-path", Arg.Set_string Xcp_client.switch_path, (fun () -> !Xcp_client.switch_path), "Unix domain socket path on localhost where the message switch is listening"; - "search-path", Arg.String (fun s -> extra_search_path := (split_c ':' s) @ !extra_search_path), (fun () -> String.concat ":" !extra_search_path), "Search path for resources"; - "pidfile", Arg.Set_string pidfile, (fun () -> !pidfile), "Filename to write process PID"; - "log", Arg.Set_string log_destination, (fun () -> !log_destination), "Where to write log messages"; - "daemon", Arg.Bool (fun x -> daemon := x), (fun () -> string_of_bool !daemon), "True if we are to daemonise"; - "disable-logging-for", Arg.String - (fun x -> debug "Parsing [%s]" x; - try - let modules = List.filter (fun x -> x <> "") (split_c ' ' x) in - List.iter Debug.disable modules - with e -> - error "Processing disabled-logging-for = %s: %s" x (Printexc.to_string e) - ), (fun () -> String.concat " " (setify (List.map fst (Debug.disabled_modules ())))), "A space-separated list of debug modules to suppress logging from"; - - "loglevel", Arg.String - (fun x -> - debug "Parsing [%s]" x; - try - log_level := Syslog.level_of_string x; - Debug.set_level !log_level - with e -> - error "Processing loglevel = %s: %s" x (Printexc.to_string e)), - (fun () -> Syslog.string_of_level !log_level), "Log level"; - - "inventory", Arg.Set_string Inventory.inventory_filename, (fun () -> !Inventory.inventory_filename), "Location of the inventory file"; - "config", Arg.Set_string config_file, (fun () -> !config_file), "Location of configuration file"; - "config-dir", Arg.Set_string config_dir, (fun () -> !config_dir), "Location of directory containing configuration file fragments"; -] +let common_options = + [ + ( "use-switch" + , Arg.Bool (fun b -> Xcp_client.use_switch := b) + , (fun () -> string_of_bool !Xcp_client.use_switch) + , "true if the message switch is to be enabled" ) + ; ( "switch-path" + , Arg.Set_string Xcp_client.switch_path + , (fun () -> !Xcp_client.switch_path) + , "Unix domain socket path on localhost where the message switch is \ + listening" ) + ; ( "search-path" + , Arg.String + (fun s -> extra_search_path := split_c ':' s @ !extra_search_path) + , (fun () -> String.concat ":" !extra_search_path) + , "Search path for resources" ) + ; ( "pidfile" + , Arg.Set_string pidfile + , (fun () -> !pidfile) + , "Filename to write process PID" ) + ; ( "log" + , Arg.Set_string log_destination + , (fun () -> !log_destination) + , "Where to write log messages" ) + ; ( "daemon" + , Arg.Bool (fun x -> daemon := x) + , (fun () -> string_of_bool !daemon) + , "True if we are to daemonise" ) + ; ( "disable-logging-for" + , Arg.String + (fun x -> + debug "Parsing [%s]" x ; + try + let modules = List.filter (fun x -> x <> "") (split_c ' ' x) in + List.iter Debug.disable modules + with e -> + error "Processing disabled-logging-for = %s: %s" x + (Printexc.to_string e)) + , (fun () -> + String.concat " " (setify (List.map fst (Debug.disabled_modules ())))) + , "A space-separated list of debug modules to suppress logging from" ) + ; ( "loglevel" + , Arg.String + (fun x -> + debug "Parsing [%s]" x ; + try + log_level := Syslog.level_of_string x ; + Debug.set_level !log_level + with e -> + error "Processing loglevel = %s: %s" x (Printexc.to_string e)) + , (fun () -> Syslog.string_of_level !log_level) + , "Log level" ) + ; ( "inventory" + , Arg.Set_string Inventory.inventory_filename + , (fun () -> !Inventory.inventory_filename) + , "Location of the inventory file" ) + ; ( "config" + , Arg.Set_string config_file + , (fun () -> !config_file) + , "Location of configuration file" ) + ; ( "config-dir" + , Arg.Set_string config_dir + , (fun () -> !config_dir) + , "Location of directory containing configuration file fragments" ) + ] let loglevel () = !log_level module Term = Cmdliner.Term let rec list = function - | [] -> Term.pure [] - | x :: xs -> Term.app (Term.app (Term.pure (fun x y -> x :: y)) x) (list xs) + | [] -> + Term.pure [] + | x :: xs -> + Term.app (Term.app (Term.pure (fun x y -> x :: y)) x) (list xs) -let command_of ?(name = Sys.argv.(0)) ?(version = "unknown") ?(doc = "Please describe this command.") xs = +let command_of ?(name = Sys.argv.(0)) ?(version = "unknown") + ?(doc = "Please describe this command.") xs = let term_of_option (key, arg, get_fn, doc) = let default = get_fn () in match arg with | Arg.Unit f -> - let t = Cmdliner.Arg.(value & flag & info [ key ] ~doc) in - let make = function true -> f () | false -> () in - Term.(pure make $ t) + let t = Cmdliner.Arg.(value & flag & info [key] ~doc) in + let make = function true -> f () | false -> () in + Term.(pure make $ t) | Arg.Bool f -> - let t = Cmdliner.Arg.(value & opt bool (bool_of_string default) & info [ key ] ~doc) in - Term.(pure f $ t) + let t = + Cmdliner.Arg.( + value & opt bool (bool_of_string default) & info [key] ~doc) + in + Term.(pure f $ t) | Arg.Set b -> - let t = Cmdliner.Arg.(value & opt bool (bool_of_string default) & info [ key ] ~doc) in - let make v = b := v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt bool (bool_of_string default) & info [key] ~doc) + in + let make v = b := v in + Term.(pure make $ t) | Arg.Clear b -> - let t = Cmdliner.Arg.(value & opt bool (bool_of_string default) & info [ key ] ~doc) in - let make v = b := not v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt bool (bool_of_string default) & info [key] ~doc) + in + let make v = b := not v in + Term.(pure make $ t) | Arg.String f -> - let t = Cmdliner.Arg.(value & opt string default & info [ key ] ~doc) in - Term.(pure f $ t) + let t = Cmdliner.Arg.(value & opt string default & info [key] ~doc) in + Term.(pure f $ t) | Arg.Set_string s -> - let t = Cmdliner.Arg.(value & opt string default & info [ key ] ~doc) in - let make v = s := v in - Term.(pure make $ t) + let t = Cmdliner.Arg.(value & opt string default & info [key] ~doc) in + let make v = s := v in + Term.(pure make $ t) | Arg.Int f -> - let t = Cmdliner.Arg.(value & opt int (int_of_string default) & info [ key ] ~doc) in - Term.(pure f $ t) + let t = + Cmdliner.Arg.( + value & opt int (int_of_string default) & info [key] ~doc) + in + Term.(pure f $ t) | Arg.Set_int s -> - let t = Cmdliner.Arg.(value & opt int (int_of_string default) & info [ key ] ~doc) in - let make v = s := v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt int (int_of_string default) & info [key] ~doc) + in + let make v = s := v in + Term.(pure make $ t) | Arg.Float f -> - let t = Cmdliner.Arg.(value & opt float (float_of_string default) & info [ key ] ~doc) in - Term.(pure f $ t) + let t = + Cmdliner.Arg.( + value & opt float (float_of_string default) & info [key] ~doc) + in + Term.(pure f $ t) | Arg.Set_float s -> - let t = Cmdliner.Arg.(value & opt float (float_of_string default) & info [ key ] ~doc) in - let make v = s := v in - Term.(pure make $ t) + let t = + Cmdliner.Arg.( + value & opt float (float_of_string default) & info [key] ~doc) + in + let make v = s := v in + Term.(pure make $ t) | _ -> - let t = Cmdliner.Arg.(value & opt string default & info [ key ] ~doc) in - let make v = Config_file.apply v arg in - Term.(pure make $ t) in + let t = Cmdliner.Arg.(value & opt string default & info [key] ~doc) in + let make v = Config_file.apply v arg in + Term.(pure make $ t) + in let terms = List.map term_of_option xs in - let _common_options = "COMMON OPTIONS" in - let man = [ - `S "DESCRIPTION"; - `P doc; - `S _common_options; - `P "These options are common to all services."; - `S "BUGS"; - `P "Check bug reports at http://github.com/xapi-project/xcp-idl"; - ] in - Term.(ret(pure (fun (_: unit list) -> `Ok ()) $ (list terms))), - Term.info name ~version ~sdocs:_common_options ~man - -let arg_spec = List.map (fun (a, b, _, c) -> "-" ^ a, b, c) + let man = + [ + `S "DESCRIPTION" + ; `P doc + ; `S _common_options + ; `P "These options are common to all services." + ; `S "BUGS" + ; `P "Check bug reports at http://github.com/xapi-project/xcp-idl" + ] + in + ( Term.(ret (pure (fun (_ : unit list) -> `Ok ()) $ list terms)) + , Term.info name ~version ~sdocs:_common_options ~man ) + +let arg_spec = List.map (fun (a, b, _, c) -> ("-" ^ a, b, c)) type res = { - name: string; - description: string; - essential: bool; - path: string ref; - perms: Unix.access_permission list + name: string + ; description: string + ; essential: bool + ; path: string ref + ; perms: Unix.access_permission list } -let default_resources = [ -] +let default_resources = [] let canonicalise x = - if not(Filename.is_relative x) - then x - else begin - (* Search the PATH and XCP_PATH for the executable *) - let paths = split_c ':' (Sys.getenv "PATH") in - let first_hit = List.fold_left (fun found path -> match found with - | Some _hit -> found - | None -> - let possibility = Filename.concat path x in - if Sys.file_exists possibility - then Some possibility - else None - ) None (paths @ !extra_search_path) in - match first_hit with - | None -> - warn "Failed to find %s on $PATH ( = %s) or search_path option ( = %s)" x (Sys.getenv "PATH") (String.concat ":" !extra_search_path); - x - | Some hit -> - info "Found '%s' at '%s'" x hit; - hit - end - -let to_opt = List.map (fun f -> f.name, Arg.String (fun x -> f.path := canonicalise x), (fun () -> !(f.path)), f.description) + if not (Filename.is_relative x) then + x + else (* Search the PATH and XCP_PATH for the executable *) + let paths = split_c ':' (Sys.getenv "PATH") in + let first_hit = + List.fold_left + (fun found path -> + match found with + | Some _hit -> + found + | None -> + let possibility = Filename.concat path x in + if Sys.file_exists possibility then Some possibility else None) + None + (paths @ !extra_search_path) + in + match first_hit with + | None -> + warn "Failed to find %s on $PATH ( = %s) or search_path option ( = %s)" + x (Sys.getenv "PATH") + (String.concat ":" !extra_search_path) ; + x + | Some hit -> + info "Found '%s' at '%s'" x hit ; + hit + +let to_opt = + List.map (fun f -> + ( f.name + , Arg.String (fun x -> f.path := canonicalise x) + , (fun () -> !(f.path)) + , f.description )) let read_config_file x = - if Sys.file_exists !config_file then begin - (* Will raise exception if config is mis-formatted. It's up to the - caller to inspect and handle the failure. - *) - Config_file.parse !config_file x; - end; - (try Sys.readdir !config_dir with _ -> [||]) - |> Array.to_list - |> List.stable_sort compare - |> List.iter - (fun fragment -> - let path = Filename.concat !config_dir fragment in - Config_file.parse path x - ) + if Sys.file_exists !config_file then + (* Will raise exception if config is mis-formatted. It's up to the caller to + inspect and handle the failure. *) + Config_file.parse !config_file x ; + (try Sys.readdir !config_dir with _ -> [||]) + |> Array.to_list + |> List.stable_sort compare + |> List.iter (fun fragment -> + let path = Filename.concat !config_dir fragment in + Config_file.parse path x) let startswith prefix x = - let prefix' = String.length prefix and x' = String.length x in - prefix' <= x' && (String.sub x 0 prefix' = prefix) + let prefix' = String.length prefix and x' = String.length x in + prefix' <= x' && String.sub x 0 prefix' = prefix let configure_common ~options ~resources arg_parse_fn = - (* Register the Logs reporter to ensure we get log messages from libraries using Logs *) - Debug.init_logs (); - - let resources = default_resources @ resources in - let config_spec = common_options @ options @ (to_opt resources) in - + (* Register the Logs reporter to ensure we get log messages from libraries + using Logs *) + Debug.init_logs () ; + let resources = default_resources @ resources in + let config_spec = common_options @ options @ to_opt resources in (* It's very confusing if there are duplicate key names *) let keys = List.map (fun (k, _, _, _) -> k) config_spec in let rec check_for_duplicates seen_already = function - | [] -> () - | x :: xs -> - if List.mem x seen_already then begin - warn "Duplicate configuration keys in Xcp_service.configure: %s in [ %s ]" - x (String.concat "; " keys) - end; - check_for_duplicates (x :: seen_already) xs in - check_for_duplicates [] keys; - - arg_parse_fn config_spec; - read_config_file config_spec; - List.iter (fun r -> r.path := canonicalise !(r.path)) resources; - Config_file.dump config_spec; - (* Check the required binaries are all available *) - List.iter - (fun f -> - try - if f.essential - then Unix.access !(f.path) f.perms - with _ -> - let args = List.filter (fun x -> not(startswith ("--" ^ f.name) x)) (Array.to_list Sys.argv) in - let lines = [ - "Cannot access " ^ !(f.path); - Printf.sprintf "Please either add to %s" !config_file; - Printf.sprintf " %s=<%s>" f.name f.description; - "or add a command-line argument"; - Printf.sprintf " %s --%s=<%s>" (String.concat " " args) f.name f.description; - ] in - List.iter (fun x -> error "%s" x) lines; - failwith (String.concat "\n" lines) - ) resources; - - Sys.set_signal Sys.sigpipe Sys.Signal_ignore - -let configure ?(options=[]) ?(resources=[]) () = + | [] -> + () + | x :: xs -> + if List.mem x seen_already then + warn + "Duplicate configuration keys in Xcp_service.configure: %s in [ %s \ + ]" + x (String.concat "; " keys) ; + check_for_duplicates (x :: seen_already) xs + in + check_for_duplicates [] keys ; + arg_parse_fn config_spec ; + read_config_file config_spec ; + List.iter (fun r -> r.path := canonicalise !(r.path)) resources ; + Config_file.dump config_spec ; + (* Check the required binaries are all available *) + List.iter + (fun f -> + try if f.essential then Unix.access !(f.path) f.perms + with _ -> + let args = + List.filter + (fun x -> not (startswith ("--" ^ f.name) x)) + (Array.to_list Sys.argv) + in + let lines = + [ + "Cannot access " ^ !(f.path) + ; Printf.sprintf "Please either add to %s" !config_file + ; Printf.sprintf " %s=<%s>" f.name f.description + ; "or add a command-line argument" + ; Printf.sprintf " %s --%s=<%s>" (String.concat " " args) f.name + f.description + ] + in + List.iter (fun x -> error "%s" x) lines ; + failwith (String.concat "\n" lines)) + resources ; + Sys.set_signal Sys.sigpipe Sys.Signal_ignore + +let configure ?(options = []) ?(resources = []) () = try - configure_common ~options ~resources - (fun config_spec -> - Arg.parse (Arg.align (arg_spec config_spec)) + configure_common ~options ~resources (fun config_spec -> + Arg.parse + (Arg.align (arg_spec config_spec)) (fun _ -> failwith "Invalid argument") - (Printf.sprintf "Usage: %s [-config filename]" Sys.argv.(0)) - ) - with Failure _ -> - exit 1 + (Printf.sprintf "Usage: %s [-config filename]" Sys.argv.(0))) + with Failure _ -> exit 1 -type ('a, 'b) error = [ - | `Ok of 'a - | `Error of 'b -] +type ('a, 'b) error = [`Ok of 'a | `Error of 'b] -let configure2 ~name ~version ~doc ?(options=[]) ?(resources=[]) () = +let configure2 ~name ~version ~doc ?(options = []) ?(resources = []) () = try - configure_common ~options ~resources - (fun config_spec -> + configure_common ~options ~resources (fun config_spec -> match Term.eval (command_of ~name ~version ~doc config_spec) with - | `Ok () -> () - | `Error _ -> failwith "Failed to parse command-line arguments" - | _ -> exit 0 (* --help *) - ); + | `Ok () -> + () + | `Error _ -> + failwith "Failed to parse command-line arguments" + | _ -> + exit 0 + (* --help *)) ; `Ok () - with Failure m -> - `Error m + with Failure m -> `Error m let http_handler call_of_string string_of_response process s = - let ic = Unix.in_channel_of_descr s in - let oc = Unix.out_channel_of_descr s in - let module Request = Cohttp.Request.Make(Cohttp_posix_io.Buffered_IO) in - let module Response = Cohttp.Response.Make(Cohttp_posix_io.Buffered_IO) in - match Request.read ic with - | `Eof -> - debug "Failed to read HTTP request" - | `Invalid x -> - debug "Failed to read HTTP request. Got: '%s'" x - | `Ok req -> - begin match Cohttp.Request.meth req, Uri.path (Cohttp.Request.uri req) with - | `POST, _ -> - let headers = Cohttp.Request.headers req in - begin match Cohttp.Header.get headers "content-length" with - | None -> - debug "Failed to read content-length" - | Some content_length -> - let content_length = int_of_string content_length in - let request_txt = Bytes.make content_length '\000' in - really_input ic request_txt 0 content_length; - let rpc_call = call_of_string (Bytes.unsafe_to_string request_txt) in - debug "%s" (Rpc.string_of_call rpc_call); - let rpc_response = process rpc_call in - debug " %s" (Rpc.string_of_response rpc_response); - let response_txt = string_of_response rpc_response in - let content_length = String.length response_txt in - let headers = Cohttp.Header.of_list [ - "user-agent", default_service_name; - "content-length", string_of_int content_length; - ] in - let response = Cohttp.Response.make ~version:`HTTP_1_1 ~status:`OK ~headers ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) () in - Response.write (fun t -> Response.write_body t response_txt) response oc - end - | _, _ -> - let content_length = 0 in - let headers = Cohttp.Header.of_list [ - "user-agent", default_service_name; - "content-length", string_of_int content_length; - ] in - let response = Cohttp.Response.make ~version:`HTTP_1_1 ~status:`Not_found ~headers ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) () in - Response.write (fun _t -> ()) response oc - end - -let ign_int (t:int) = ignore t + let ic = Unix.in_channel_of_descr s in + let oc = Unix.out_channel_of_descr s in + let module Request = Cohttp.Request.Make (Cohttp_posix_io.Buffered_IO) in + let module Response = Cohttp.Response.Make (Cohttp_posix_io.Buffered_IO) in + match Request.read ic with + | `Eof -> + debug "Failed to read HTTP request" + | `Invalid x -> + debug "Failed to read HTTP request. Got: '%s'" x + | `Ok req -> ( + match (Cohttp.Request.meth req, Uri.path (Cohttp.Request.uri req)) with + | `POST, _ -> ( + let headers = Cohttp.Request.headers req in + match Cohttp.Header.get headers "content-length" with + | None -> + debug "Failed to read content-length" + | Some content_length -> + let content_length = int_of_string content_length in + let request_txt = Bytes.make content_length '\000' in + really_input ic request_txt 0 content_length ; + let rpc_call = + call_of_string (Bytes.unsafe_to_string request_txt) + in + debug "%s" (Rpc.string_of_call rpc_call) ; + let rpc_response = process rpc_call in + debug " %s" (Rpc.string_of_response rpc_response) ; + let response_txt = string_of_response rpc_response in + let content_length = String.length response_txt in + let headers = + Cohttp.Header.of_list + [ + ("user-agent", default_service_name) + ; ("content-length", string_of_int content_length) + ] + in + let response = + Cohttp.Response.make ~version:`HTTP_1_1 ~status:`OK ~headers + ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) + () + in + Response.write + (fun t -> Response.write_body t response_txt) + response oc + ) + | _, _ -> + let content_length = 0 in + let headers = + Cohttp.Header.of_list + [ + ("user-agent", default_service_name) + ; ("content-length", string_of_int content_length) + ] + in + let response = + Cohttp.Response.make ~version:`HTTP_1_1 ~status:`Not_found ~headers + ~encoding:(Cohttp.Transfer.Fixed (Int64.of_int content_length)) + () + in + Response.write (fun _t -> ()) response oc + ) + +let ign_int (t : int) = ignore t let default_raw_fn rpc_fn s = - http_handler Xmlrpc.call_of_string Xmlrpc.string_of_response rpc_fn s + http_handler Xmlrpc.call_of_string Xmlrpc.string_of_response rpc_fn s let mkdir_rec dir perm = - let rec p_mkdir dir = - let p_name = Filename.dirname dir in - if p_name <> "/" && p_name <> "." - then p_mkdir p_name; - (try Unix.mkdir dir perm with Unix.Unix_error(Unix.EEXIST, _, _) -> ()) in - p_mkdir dir + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." then p_mkdir p_name ; + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + in + p_mkdir dir type server = | Socket of Unix.file_descr * (Unix.file_descr -> unit) @@ -435,102 +541,110 @@ type server = (* Start accepting connections on sockets before we daemonize *) let make_socket_server path fn = - try - (try Unix.unlink path with Unix.Unix_error(Unix.ENOENT, _, _) -> ()); - mkdir_rec (Filename.dirname path) 0o0755; - let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unix.bind sock (Unix.ADDR_UNIX path); - Unix.listen sock 5; - info "Listening on %s" path; - Socket (sock, fn) - with e -> - error "Failed to listen on Unix domain socket %s. Raw error was: %s" path (Printexc.to_string e); - begin match e with - | Unix.Unix_error(Unix.EACCES, _, _) -> - error "Access was denied."; - error "Possible fixes include:"; - error "1. Run this program as root (recommended)"; - error "2. Make the permissions in the filesystem more permissive (my effective uid is %d)" (Unix.geteuid ()); - error "3. Adjust the sockets-path directive in %s" !config_file; - exit 1 - | _ -> () - end; - raise e - -let make_queue_server name fn = - Queue(name, fn) (* TODO: connect to the message switch *) + try + (try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> ()) ; + mkdir_rec (Filename.dirname path) 0o0755 ; + let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.bind sock (Unix.ADDR_UNIX path) ; + Unix.listen sock 5 ; + info "Listening on %s" path ; + Socket (sock, fn) + with e -> + error "Failed to listen on Unix domain socket %s. Raw error was: %s" path + (Printexc.to_string e) ; + ( match e with + | Unix.Unix_error (Unix.EACCES, _, _) -> + error "Access was denied." ; + error "Possible fixes include:" ; + error "1. Run this program as root (recommended)" ; + error + "2. Make the permissions in the filesystem more permissive (my \ + effective uid is %d)" + (Unix.geteuid ()) ; + error "3. Adjust the sockets-path directive in %s" !config_file ; + exit 1 + | _ -> + () + ) ; + raise e + +let make_queue_server name fn = Queue (name, fn) + +(* TODO: connect to the message switch *) let make ~path ~queue_name ?raw_fn ~rpc_fn () = - if !Xcp_client.use_switch - then make_queue_server queue_name rpc_fn - else make_socket_server path (match raw_fn with - | Some x -> x - | None -> default_raw_fn rpc_fn - ) + if !Xcp_client.use_switch then + make_queue_server queue_name rpc_fn + else + make_socket_server path + (match raw_fn with Some x -> x | None -> default_raw_fn rpc_fn) let serve_forever = function - | Socket(listening_sock, fn) -> - while true do - let this_connection, _ = Unix.accept listening_sock in - let (_: Thread.t) = Thread.create - (fun () -> - finally - (fun () -> fn this_connection) - (fun () -> Unix.close this_connection) - ) () in - () - done - | Queue(queue_name, fn) -> - let process x = Jsonrpc.string_of_response (fn (Jsonrpc.call_of_string x)) in - let _ = Message_switch_unix.Protocol_unix.Server.listen ~process ~switch:!Xcp_client.switch_path ~queue:queue_name () in - let rec forever () = - Thread.delay 3600.; - forever () in - forever () + | Socket (listening_sock, fn) -> + while true do + let this_connection, _ = Unix.accept listening_sock in + let (_ : Thread.t) = + Thread.create + (fun () -> + finally + (fun () -> fn this_connection) + (fun () -> Unix.close this_connection)) + () + in + () + done + | Queue (queue_name, fn) -> + let process x = + Jsonrpc.string_of_response (fn (Jsonrpc.call_of_string x)) + in + let _ = + Message_switch_unix.Protocol_unix.Server.listen ~process + ~switch:!Xcp_client.switch_path ~queue:queue_name () + in + let rec forever () = Thread.delay 3600. ; forever () in + forever () let pidfile_write filename = - let fd = Unix.openfile filename - [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] - 0o640 in - finally - (fun () -> - let pid = Unix.getpid () in - let buf = - string_of_int pid ^ "\n" - |> Bytes.of_string - in - let len = Bytes.length buf in - if Unix.write fd buf 0 len <> len - then failwith "pidfile_write failed") - (fun () -> Unix.close fd) - + let fd = + Unix.openfile filename [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o640 + in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" |> Bytes.of_string in + let len = Bytes.length buf in + if Unix.write fd buf 0 len <> len then + failwith "pidfile_write failed") + (fun () -> Unix.close fd) (* Cf Stevens et al, Advanced Programming in the UNIX Environment, Section 13.3 *) let daemonize ?start_fn () = - if not (have_daemonized ()) - then - ign_int (Unix.umask 0); - match Unix.fork () with - | 0 -> - if Unix.setsid () == -1 then failwith "Unix.setsid failed"; - Sys.set_signal Sys.sighup Sys.Signal_ignore; - (match Unix.fork () with - | 0 -> - Opt.iter (fun fn -> fn ()) start_fn; - Unix.chdir "/"; - mkdir_rec (Filename.dirname !pidfile) 0o755; - pidfile_write !pidfile; - let nullfd = Unix.openfile "/dev/null" [ Unix.O_RDWR ] 0 in - Unix.dup2 nullfd Unix.stdin; - Unix.dup2 nullfd Unix.stdout; - Unix.dup2 nullfd Unix.stderr; - Unix.close nullfd - | _ -> exit 0) - | _ -> exit 0 + if not (have_daemonized ()) then + ign_int (Unix.umask 0) ; + match Unix.fork () with + | 0 -> ( + if Unix.setsid () == -1 then failwith "Unix.setsid failed" ; + Sys.set_signal Sys.sighup Sys.Signal_ignore ; + match Unix.fork () with + | 0 -> + Opt.iter (fun fn -> fn ()) start_fn ; + Unix.chdir "/" ; + mkdir_rec (Filename.dirname !pidfile) 0o755 ; + pidfile_write !pidfile ; + let nullfd = Unix.openfile "/dev/null" [Unix.O_RDWR] 0 in + Unix.dup2 nullfd Unix.stdin ; + Unix.dup2 nullfd Unix.stdout ; + Unix.dup2 nullfd Unix.stderr ; + Unix.close nullfd + | _ -> + exit 0 + ) + | _ -> + exit 0 let maybe_daemonize ?start_fn () = - if !daemon then - daemonize ?start_fn () - else - Opt.iter (fun fn -> fn ()) start_fn + if !daemon then + daemonize ?start_fn () + else + Opt.iter (fun fn -> fn ()) start_fn diff --git a/lib/xcp_service.mli b/lib/xcp_service.mli index 3871be2b..74be71d8 100644 --- a/lib/xcp_service.mli +++ b/lib/xcp_service.mli @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -val common_prefix: string +val common_prefix : string type opt = string * Arg.spec * (unit -> string) * string @@ -21,44 +21,45 @@ module Config_file : sig end type res = { - name: string; - description: string; - essential: bool; - path: string ref; - perms: Unix.access_permission list; + name: string + ; description: string + ; essential: bool + ; path: string ref + ; perms: Unix.access_permission list } -val configure: ?options:opt list -> ?resources:res list -> unit -> unit +val configure : ?options:opt list -> ?resources:res list -> unit -> unit -type ('a, 'b) error = [ - | `Ok of 'a - | `Error of 'b -] +type ('a, 'b) error = [`Ok of 'a | `Error of 'b] -val configure2: - name:string -> - version:string -> - doc:string -> - ?options:opt list -> ?resources:res list -> unit -> - (unit, string) error +val configure2 : + name:string + -> version:string + -> doc:string + -> ?options:opt list + -> ?resources:res list + -> unit + -> (unit, string) error (** More advanced service configuration with manpage generation *) type server -val make_socket_server: string -> (Unix.file_descr -> unit) -> server +val make_socket_server : string -> (Unix.file_descr -> unit) -> server -val make: path:string -> - queue_name:string -> - ?raw_fn: (Unix.file_descr -> unit) -> - rpc_fn: (Rpc.call -> Rpc.response) -> - unit -> - server +val make : + path:string + -> queue_name:string + -> ?raw_fn:(Unix.file_descr -> unit) + -> rpc_fn:(Rpc.call -> Rpc.response) + -> unit + -> server -val serve_forever: server -> unit +val serve_forever : server -> unit -val daemon: bool ref -val loglevel: unit -> Syslog.level +val daemon : bool ref -val daemonize: ?start_fn:(unit -> unit) -> unit -> unit +val loglevel : unit -> Syslog.level -val maybe_daemonize: ?start_fn:(unit -> unit) -> unit -> unit +val daemonize : ?start_fn:(unit -> unit) -> unit -> unit + +val maybe_daemonize : ?start_fn:(unit -> unit) -> unit -> unit diff --git a/lib_test/channel_test.ml b/lib_test/channel_test.ml index c62a4a61..92901a74 100644 --- a/lib_test/channel_test.ml +++ b/lib_test/channel_test.ml @@ -20,11 +20,13 @@ let dup_automatic x = let dup_sendmsg x = let protos = Posix_channel.send x in - let proto = List.find (function - | Xcp_channel_protocol.Unix_sendmsg(_, _, _) -> true - | _ -> false - ) protos in - Posix_channel.receive [ proto ] + let proto = + List.find + (function + | Xcp_channel_protocol.Unix_sendmsg (_, _, _) -> true | _ -> false) + protos + in + Posix_channel.receive [proto] let count_fds () = Array.length (Sys.readdir "/proc/self/fd") @@ -33,38 +35,40 @@ let check_for_leak dup_function () = let before = count_fds () in let stdout2 = dup_function Unix.stdout in let after = count_fds () in - Alcotest.(check int) "fds" (before + 1) after; - Unix.close stdout2; + Alcotest.(check int) "fds" (before + 1) after ; + Unix.close stdout2 ; let after' = count_fds () in Alcotest.(check int) "fds" before after' let dup_proxy x = let protos = Posix_channel.send x in - let proto = List.find (function - | Xcp_channel_protocol.TCP_proxy(ip, port) -> true - | _ -> false - ) protos in - Posix_channel.receive [ proto ] + let proto = + List.find + (function + | Xcp_channel_protocol.TCP_proxy (ip, port) -> true | _ -> false) + protos + in + Posix_channel.receive [proto] let check_for_leak_proxy () = let a, b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in let before = count_fds () in let c = dup_proxy a in (* background fd closing *) - Thread.delay 1.0; + Thread.delay 1.0 ; let after = count_fds () in - Alcotest.(check int) "fds" (before + 2) after; - Unix.close c; + Alcotest.(check int) "fds" (before + 2) after ; + Unix.close c ; (* background fd closing *) - Thread.delay 1.0; + Thread.delay 1.0 ; let after' = count_fds () in Alcotest.(check int) "fds" before after' let tests = [ - "check_for_leak with automatic selection", `Quick, (check_for_leak dup_automatic); - "check_for_leak with sendmsg", `Quick, (check_for_leak dup_sendmsg); - "check_for_leak_proxy", `Quick, check_for_leak_proxy; + ( "check_for_leak with automatic selection" + , `Quick + , check_for_leak dup_automatic ) + ; ("check_for_leak with sendmsg", `Quick, check_for_leak dup_sendmsg) + ; ("check_for_leak_proxy", `Quick, check_for_leak_proxy) ] - - diff --git a/lib_test/cluster_interface_test.ml b/lib_test/cluster_interface_test.ml index 459da690..b5cb653e 100644 --- a/lib_test/cluster_interface_test.ml +++ b/lib_test/cluster_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "cluster_gen" end + module OldPath = struct let test_data_path = "test_data/cluster" end -module C = Cluster_interface.LocalAPI(GenTestData(GenPath)(TXmlrpc)) -module T = Cluster_interface.LocalAPI(TestOldRpcs(OldPath)(TXmlrpc)) +module C = Cluster_interface.LocalAPI (GenTestData (GenPath) (TXmlrpc)) +module T = Cluster_interface.LocalAPI (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/config_file_test.ml b/lib_test/config_file_test.ml index d95894df..5b8d410e 100644 --- a/lib_test/config_file_test.ml +++ b/lib_test/config_file_test.ml @@ -1,22 +1,26 @@ - let test_config_file () = let open Xcp_service.Config_file in - let tests = [ - "", None; - "# Foo", None; - "whatever", None; - "foo=true", Some ("foo","true"); - "n=2 # and no more", Some ("n","2"); - "n = 2 \t# and no more", Some ("n","2"); - "n = 'test' # comment", Some ("n","test"); - "n = \"test\" # comment", Some ("n","test"); - " n\t\t \t = 'foo bar baz'\t\t\t # comment", Some ("n","foo bar baz"); - " n\t\t \t = foo bar baz\t\t\t # comment", Some ("n","foo bar baz"); - "n = 'foo bar baz ' # comment", Some ("n","foo bar baz "); - ] in - List.iter (fun (x,y) -> Alcotest.(check (option (pair string string))) ("parse output for " ^ x) (parse_line x) y) tests + let tests = + [ + ("", None) + ; ("# Foo", None) + ; ("whatever", None) + ; ("foo=true", Some ("foo", "true")) + ; ("n=2 # and no more", Some ("n", "2")) + ; ("n = 2 \t# and no more", Some ("n", "2")) + ; ("n = 'test' # comment", Some ("n", "test")) + ; ("n = \"test\" # comment", Some ("n", "test")) + ; ( " n\t\t \t = 'foo bar baz'\t\t\t # comment" + , Some ("n", "foo bar baz") ) + ; ( " n\t\t \t = foo bar baz\t\t\t # comment" + , Some ("n", "foo bar baz") ) + ; ("n = 'foo bar baz ' # comment", Some ("n", "foo bar baz ")) + ] + in + List.iter + (fun (x, y) -> + Alcotest.(check (option (pair string string))) + ("parse output for " ^ x) (parse_line x) y) + tests -let tests = - [ - "check config file parsing", `Quick, test_config_file; - ] +let tests = [("check config file parsing", `Quick, test_config_file)] diff --git a/lib_test/debug_test.ml b/lib_test/debug_test.ml index 66d761a6..aa606ca2 100644 --- a/lib_test/debug_test.ml +++ b/lib_test/debug_test.ml @@ -1,73 +1,75 @@ - let assert_levels brand (crit, err, warn, info, debug) = - Alcotest.(check bool) (brand ^ " critical") (Debug.is_disabled brand Syslog.Crit) crit; - Alcotest.(check bool) (brand ^ " error") (Debug.is_disabled brand Syslog.Err) err; - Alcotest.(check bool) (brand ^ " warning") (Debug.is_disabled brand Syslog.Warning) warn; - Alcotest.(check bool) (brand ^ " info") (Debug.is_disabled brand Syslog.Info) info; - Alcotest.(check bool) (brand ^ " debug") (Debug.is_disabled brand Syslog.Debug) debug - + Alcotest.(check bool) + (brand ^ " critical") + (Debug.is_disabled brand Syslog.Crit) + crit ; + Alcotest.(check bool) + (brand ^ " error") + (Debug.is_disabled brand Syslog.Err) + err ; + Alcotest.(check bool) + (brand ^ " warning") + (Debug.is_disabled brand Syslog.Warning) + warn ; + Alcotest.(check bool) + (brand ^ " info") + (Debug.is_disabled brand Syslog.Info) + info ; + Alcotest.(check bool) + (brand ^ " debug") + (Debug.is_disabled brand Syslog.Debug) + debug let test_default_levels () = - assert_levels "some unused brand" (false, false, false, false, false); + assert_levels "some unused brand" (false, false, false, false, false) ; assert_levels "some other unused brand" (false, false, false, false, false) - let test_debug_disable () = - Debug.set_level Syslog.Debug; - - Debug.disable "xapi" ~level:Syslog.Info; - assert_levels "xapi" (false, false, false, true, false); - - Debug.disable "xenopsd" ~level:Syslog.Err; - assert_levels "xenopsd" (false, true, false, false, false); + Debug.set_level Syslog.Debug ; + Debug.disable "xapi" ~level:Syslog.Info ; + assert_levels "xapi" (false, false, false, true, false) ; + Debug.disable "xenopsd" ~level:Syslog.Err ; + assert_levels "xenopsd" (false, true, false, false, false) ; assert_levels "xapi" (false, false, false, true, false) - let test_debug_set_level () = - Debug.set_level Syslog.Debug; - assert_levels "brand1" (false, false, false, false, false); - assert_levels "other" (false, false, false, false, false); - - Debug.set_level Syslog.Info; - assert_levels "brand1" (false, false, false, false, true); - assert_levels "other" (false, false, false, false, true); - - Debug.set_level Syslog.Warning; - assert_levels "brand1" (false, false, false, true, true); - assert_levels "other" (false, false, false, true, true); - - Debug.set_level Syslog.Err; - assert_levels "brand1" (false, false, true, true, true); - assert_levels "other" (false, false, true, true, true); - - Debug.set_level Syslog.Crit; - assert_levels "brand1" (false, true, true, true, true); - assert_levels "other" (false, true, true, true, true) - + Debug.set_level Syslog.Debug ; + assert_levels "brand1" (false, false, false, false, false) ; + assert_levels "other" (false, false, false, false, false) ; + Debug.set_level Syslog.Info ; + assert_levels "brand1" (false, false, false, false, true) ; + assert_levels "other" (false, false, false, false, true) ; + Debug.set_level Syslog.Warning ; + assert_levels "brand1" (false, false, false, true, true) ; + assert_levels "other" (false, false, false, true, true) ; + Debug.set_level Syslog.Err ; + assert_levels "brand1" (false, false, true, true, true) ; + assert_levels "other" (false, false, true, true, true) ; + Debug.set_level Syslog.Crit ; + assert_levels "brand1" (false, true, true, true, true) ; + assert_levels "other" (false, true, true, true, true) let test_debug_set_level_multiple_loggers () = - let _ = (module Debug.Make(struct let name = "aaaa" end) : Debug.DEBUG) in - let _ = (module Debug.Make(struct let name = "bbbb" end) : Debug.DEBUG) in - - Debug.set_level Syslog.Debug; - assert_levels "aaaa" (false, false, false, false, false); - assert_levels "bbbb" (false, false, false, false, false); - + let _ = (module Debug.Make (struct let name = "aaaa" end) : Debug.DEBUG) in + let _ = (module Debug.Make (struct let name = "bbbb" end) : Debug.DEBUG) in + Debug.set_level Syslog.Debug ; + assert_levels "aaaa" (false, false, false, false, false) ; + assert_levels "bbbb" (false, false, false, false, false) ; (* Set level explicitly on aaaa *) - Debug.disable ~level:Syslog.Err "aaaa"; - assert_levels "aaaa" (false, true, false, false, false); - assert_levels "bbbb" (false, false, false, false, false); - - (* Set default level. Err should still be disabled for aaaa *) - Debug.set_level Syslog.Warning; - assert_levels "aaaa" (false, true, false, true, true); - assert_levels "bbbb" (false, false, false, true, true) + Debug.disable ~level:Syslog.Err "aaaa" ; + assert_levels "aaaa" (false, true, false, false, false) ; + assert_levels "bbbb" (false, false, false, false, false) ; + (* Set default level. Err should still be disabled for aaaa *) + Debug.set_level Syslog.Warning ; + assert_levels "aaaa" (false, true, false, true, true) ; + assert_levels "bbbb" (false, false, false, true, true) let tests = let open Alcotest in [ - test_case "Test default levels" `Quick test_default_levels; - test_case "Test Debug.disable" `Quick test_debug_disable; - test_case "Test Debug.set_level" `Quick test_debug_set_level; - test_case "Test Debug.set_level (multiple loggers)" `Quick test_debug_set_level_multiple_loggers; - ] \ No newline at end of file + test_case "Test default levels" `Quick test_default_levels + ; test_case "Test Debug.disable" `Quick test_debug_disable + ; test_case "Test Debug.set_level" `Quick test_debug_set_level + ; test_case "Test Debug.set_level (multiple loggers)" `Quick + test_debug_set_level_multiple_loggers + ] diff --git a/lib_test/device_number_test.ml b/lib_test/device_number_test.ml index 5d12dee3..24cca8b9 100644 --- a/lib_test/device_number_test.ml +++ b/lib_test/device_number_test.ml @@ -1,55 +1,65 @@ open Device_number -let device_number = Alcotest.testable (Fmt.of_to_string Device_number.to_debug_string) (=) +let device_number = + Alcotest.testable (Fmt.of_to_string Device_number.to_debug_string) ( = ) (* spec * linux string * xenstore key *) -let examples = [ - (Xen, 0, 0), "xvda", 51712; - (Xen, 0, 1), "xvda1", 51713; - (Ide, 0, 0), "hda", 768; - (Ide, 0, 1), "hda1", 769; - (Scsi, 0, 0), "sda", 2048; - (Scsi, 0, 1), "sda1", 2049; - (Scsi, 1, 3), "sdb3", 2067; - (Ide, 2, 2), "hdc2", 5634; - (Xen, 26, 0), "xvdaa", 268442112; -] +let examples = + [ + ((Xen, 0, 0), "xvda", 51712) + ; ((Xen, 0, 1), "xvda1", 51713) + ; ((Ide, 0, 0), "hda", 768) + ; ((Ide, 0, 1), "hda1", 769) + ; ((Scsi, 0, 0), "sda", 2048) + ; ((Scsi, 0, 1), "sda1", 2049) + ; ((Scsi, 1, 3), "sdb3", 2067) + ; ((Ide, 2, 2), "hdc2", 5634) + ; ((Xen, 26, 0), "xvdaa", 268442112) + ] -let deprecated = [ - (Ide, 4, 0), "hde", 8448; - (Ide, 5, 0), "hdf", 8512; - (Ide, 6, 0), "hdg", 8704; - (Ide, 7, 0), "hdh", 8768; - (Ide, 8, 0), "hdi", 14336; - (Ide, 15, 0), "hdp", 22848; -] +let deprecated = + [ + ((Ide, 4, 0), "hde", 8448) + ; ((Ide, 5, 0), "hdf", 8512) + ; ((Ide, 6, 0), "hdg", 8704) + ; ((Ide, 7, 0), "hdh", 8768) + ; ((Ide, 8, 0), "hdi", 14336) + ; ((Ide, 15, 0), "hdp", 22848) + ] let examples_to_test = let using_deprecated_ide = - try ignore(make (Ide, 4, 0)); true with _ -> false in - examples @ (if using_deprecated_ide then deprecated else []) + try + ignore (make (Ide, 4, 0)) ; + true + with _ -> false + in + examples @ if using_deprecated_ide then deprecated else [] -let equivalent = [ - "d0", "xvda"; - "d0", "0"; - "d5", "5"; - "xvdf", "5"; - "d0p0", "xvda"; - "d536p37", "xvdtq37"; -] +let equivalent = + [ + ("d0", "xvda") + ; ("d0", "0") + ; ("d5", "5") + ; ("xvdf", "5") + ; ("d0p0", "xvda") + ; ("d536p37", "xvdtq37") + ] let test_examples = let tests = List.map (fun (spec, linux, xenstore) -> - "test_examples " ^ linux, `Quick, (fun () -> - let of_spec = make spec in - let of_linux = of_linux_device linux in - let of_xenstore = of_xenstore_key xenstore in - Alcotest.check device_number "examples must be equal" - of_spec of_linux; - Alcotest.check device_number "examples must be equal" - of_spec of_xenstore)) + ( "test_examples " ^ linux + , `Quick + , fun () -> + let of_spec = make spec in + let of_linux = of_linux_device linux in + let of_xenstore = of_xenstore_key xenstore in + Alcotest.check device_number "examples must be equal" of_spec + of_linux ; + Alcotest.check device_number "examples must be equal" of_spec + of_xenstore )) examples_to_test in tests @@ -60,11 +70,12 @@ let test_deprecated = let tests = List.map (fun (_, linux, xenstore) -> - "test_deprecated " ^ linux, `Quick, (fun () -> - let of_linux = of_linux_device linux in - let of_xenstore = of_xenstore_key xenstore in - Alcotest.check device_number "must be equal" - of_linux of_xenstore)) + ( "test_deprecated " ^ linux + , `Quick + , fun () -> + let of_linux = of_linux_device linux in + let of_xenstore = of_xenstore_key xenstore in + Alcotest.check device_number "must be equal" of_linux of_xenstore )) deprecated in tests @@ -73,42 +84,50 @@ let test_equivalent = let tests = List.map (fun (x, y) -> - let test_name = Printf.sprintf "test_equivalent %s=%s" x y in - test_name, `Quick, (fun () -> - let x' = of_string false x in - let y' = of_string false y in - Alcotest.check device_number "must be equal" - x' y')) + let test_name = Printf.sprintf "test_equivalent %s=%s" x y in + ( test_name + , `Quick + , fun () -> + let x' = of_string false x in + let y' = of_string false y in + Alcotest.check device_number "must be equal" x' y' )) equivalent in tests let test_2_way_convert = - (* We now always convert Ide specs into xvd* linux devices, so they - become Xen specs when converted back. *) + (* We now always convert Ide specs into xvd* linux devices, so they become Xen + specs when converted back. *) let equal_linux old_t new_t = - match spec old_t, spec new_t with + match (spec old_t, spec new_t) with | (Ide, disk1, partition1), (Xen, disk2, partition2) - when disk1 = disk2 && partition1 = partition2 -> true - | old_spec, new_spec -> old_spec = new_spec + when disk1 = disk2 && partition1 = partition2 -> + true + | old_spec, new_spec -> + old_spec = new_spec + in + let device_number_equal_linux = + Alcotest.testable + (Fmt.of_to_string Device_number.to_debug_string) + equal_linux in - let device_number_equal_linux = Alcotest.testable (Fmt.of_to_string Device_number.to_debug_string) equal_linux in - ["test_2_way_convert", `Slow, (fun () -> - for disk_number = 0 to ((1 lsl 20) -1) do - List.iter - (fun hvm -> + [ + ( "test_2_way_convert" + , `Slow + , fun () -> + for disk_number = 0 to (1 lsl 20) - 1 do + List.iter + (fun hvm -> let original = of_disk_number hvm disk_number in let of_linux = of_linux_device (to_linux_device original) in let of_xenstore = of_xenstore_key (to_xenstore_key original) in - Alcotest.check device_number_equal_linux "of_linux must be equal to original" - original of_linux; - Alcotest.check device_number "of_xenstore must be equal to original" - original of_xenstore) - [true; false] - done)] + Alcotest.check device_number_equal_linux + "of_linux must be equal to original" original of_linux ; + Alcotest.check device_number + "of_xenstore must be equal to original" original of_xenstore) + [true; false] + done ) + ] let tests = - test_examples @ - test_deprecated @ - test_equivalent @ - test_2_way_convert + test_examples @ test_deprecated @ test_equivalent @ test_2_way_convert diff --git a/lib_test/gpumon_interface_test.ml b/lib_test/gpumon_interface_test.ml index 1e96643b..95010076 100644 --- a/lib_test/gpumon_interface_test.ml +++ b/lib_test/gpumon_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "gpu_gen" end + module OldPath = struct let test_data_path = "test_data/gpumon" end -module C = Gpumon_interface.RPC_API(GenTestData(GenPath)(TJsonrpc)) -module T = Gpumon_interface.RPC_API(TestOldRpcs(OldPath)(TJsonrpc)) +module C = Gpumon_interface.RPC_API (GenTestData (GenPath) (TJsonrpc)) +module T = Gpumon_interface.RPC_API (TestOldRpcs (OldPath) (TJsonrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/http_test.ml b/lib_test/http_test.ml index fa47118a..3eb449e0 100644 --- a/lib_test/http_test.ml +++ b/lib_test/http_test.ml @@ -13,21 +13,23 @@ *) let unbuffered_headers () = - (* A miscalculation in the Cohttp_posix_io module can cause the HTTP - status line to be parsed ok but the headers mangled. This can be - surprisingly hard to spot! *) + (* A miscalculation in the Cohttp_posix_io module can cause the HTTP status + line to be parsed ok but the headers mangled. This can be surprisingly hard + to spot! *) let open Cohttp_posix_io.Unbuffered_IO in - let ic = { - header_buffer = Some "HTTP/200 OK\r\nHeader1: Val1\r\nHeader2: Val2\r\n\r\n"; - header_buffer_idx = 0; - (* unused *) - fd = Unix.stdin; - } in - Alcotest.(check (option string)) "header line 1" (Some "HTTP/200 OK") (read_line ic); - Alcotest.(check (option string)) "header line 2" (Some "Header1: Val1") (read_line ic); - Alcotest.(check (option string)) "header line 3" (Some "Header2: Val2") (read_line ic) + let ic = + { + header_buffer= Some "HTTP/200 OK\r\nHeader1: Val1\r\nHeader2: Val2\r\n\r\n" + ; header_buffer_idx= 0 + ; (* unused *) + fd= Unix.stdin + } + in + Alcotest.(check (option string)) + "header line 1" (Some "HTTP/200 OK") (read_line ic) ; + Alcotest.(check (option string)) + "header line 2" (Some "Header1: Val1") (read_line ic) ; + Alcotest.(check (option string)) + "header line 3" (Some "Header2: Val2") (read_line ic) -let tests = - [ - "unbuffered_headers", `Quick, unbuffered_headers; - ] +let tests = [("unbuffered_headers", `Quick, unbuffered_headers)] diff --git a/lib_test/idl_test_common.ml b/lib_test/idl_test_common.ml index 39734bb7..a211d878 100644 --- a/lib_test/idl_test_common.ml +++ b/lib_test/idl_test_common.ml @@ -14,312 +14,420 @@ let write_str filename str = let oc = open_out filename in - Printf.fprintf oc "%s" str; - close_out oc + Printf.fprintf oc "%s" str ; close_out oc let read_str filename = let ic = open_in filename in let n = in_channel_length ic in let s = Bytes.create n in - really_input ic s 0 n; - close_in ic; - Bytes.unsafe_to_string s + really_input ic s 0 n ; close_in ic ; Bytes.unsafe_to_string s open Idl module type CONFIG = sig val test_data_path : string - (** Path under which we look for or generate requests and responses. For example, - if test_data_path = 'foo', this module will search for or generate requests - matching 'foo/requests/.request.' and responses matching - 'foo/responses/.response.' *) + (** Path under which we look for or generate requests and responses. For + example, if test_data_path = 'foo', this module will search for or + generate requests matching 'foo/requests/.request.' and + responses matching 'foo/responses/.response.' *) end module type MARSHALLER = sig val string_of_call : Rpc.call -> string + val call_of_string : string -> Rpc.call + val string_of_response : Rpc.response -> string + val response_of_string : string -> Rpc.response + val to_string : Rpc.t -> string + val of_string : string -> Rpc.t end -(* Slightly annoyingly, both RPC modules have a slightly different signature. Fix it here *) +(* Slightly annoyingly, both RPC modules have a slightly different signature. + Fix it here *) module TJsonrpc : MARSHALLER = struct include Jsonrpc + (* there is a ?strict parameter, and the signature would not match *) let of_string s = of_string s + let response_of_string r = response_of_string r + let string_of_call call = string_of_call call + let string_of_response response = string_of_response response end module TXmlrpc : MARSHALLER = struct include Xmlrpc + let call_of_string s = call_of_string s + let response_of_string s = response_of_string s + let of_string s = of_string s end +(** The following module implements test cases that write test RPC requests and + responses in JSON that can be used to verify that subsequent versions of an + API can still parse them. + The test cases are obtained by obtaining the implementation of the module + generated when applying the API functor to this module. -(** The following module implements test cases that write test - RPC requests and responses in JSON that can be used to - verify that subsequent versions of an API can still parse - them. - - The test cases are obtained by obtaining the implementation - of the module generated when applying the API functor to - this module. - - The test data will be written to the path specified in the - CONFIG module passed in *) -module GenTestData (C:CONFIG) (M:MARSHALLER) = struct + The test data will be written to the path specified in the CONFIG module + passed in *) +module GenTestData (C : CONFIG) (M : MARSHALLER) = struct type implementation = unit Alcotest.test_case list ref let tests : unit Alcotest.test_case list ref = ref [] + let description = ref None - let implement x = description := Some x; tests + let implement x = + description := Some x ; + tests + + type ('a, 'b) comp = 'a - type ('a,'b) comp = 'a type 'a res = unit + type _ fn = | Function : 'a Idl.Param.t * 'b fn -> ('a -> 'b) fn | Returning : ('a Idl.Param.t * 'b Idl.Error.t) -> ('a, _) comp fn let returning a err = Returning (a, err) - let (@->) = fun t f -> Function (t, f) + + let ( @-> ) t f = Function (t, f) open M let declare name _ ty = - let rec inner : type b. (((string * Rpc.t) list * Rpc.t list) list) -> b fn -> unit = fun params -> - function - | Function (t, f) -> begin - let vs = Rpc_genfake.genall 2 (match t.Param.name with Some n -> n | None -> t.Param.typedef.Rpc.Types.name) t.Param.typedef.Rpc.Types.ty in - let marshalled = List.map (fun v -> Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v) vs in - match t.Param.name with - | Some n -> - inner - (List.flatten - (List.map - (fun marshalled -> - match marshalled, t.Param.typedef.Rpc.Types.ty with - | Rpc.Enum [], Rpc.Types.Option _ -> - params - | Rpc.Enum [x], Rpc.Types.Option _ -> - List.map - (fun (named,unnamed) -> - (((n, x)::named),unnamed)) - params - | _, _ -> - List.map - (fun (named,unnamed) -> - (((n,marshalled)::named),unnamed)) - params - ) marshalled + let rec inner : + type b. ((string * Rpc.t) list * Rpc.t list) list -> b fn -> unit = + fun params -> function + | Function (t, f) -> ( + let vs = + Rpc_genfake.genall 2 + ( match t.Param.name with + | Some n -> + n + | None -> + t.Param.typedef.Rpc.Types.name ) - ) f - | None -> inner (List.flatten (List.map (fun marshalled -> List.map (fun (named,unnamed) -> (named,(marshalled::unnamed))) params) marshalled)) f - end + t.Param.typedef.Rpc.Types.ty + in + let marshalled = + List.map + (fun v -> Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v) + vs + in + match t.Param.name with + | Some n -> + inner + (List.flatten + (List.map + (fun marshalled -> + match (marshalled, t.Param.typedef.Rpc.Types.ty) with + | Rpc.Enum [], Rpc.Types.Option _ -> + params + | Rpc.Enum [x], Rpc.Types.Option _ -> + List.map + (fun (named, unnamed) -> + ((n, x) :: named, unnamed)) + params + | _, _ -> + List.map + (fun (named, unnamed) -> + ((n, marshalled) :: named, unnamed)) + params) + marshalled)) + f + | None -> + inner + (List.flatten + (List.map + (fun marshalled -> + List.map + (fun (named, unnamed) -> + (named, marshalled :: unnamed)) + params) + marshalled)) + f + ) | Returning (t, e) -> - let wire_name = Idl.get_wire_name !description name in - let calls = List.map - (fun (named,unnamed) -> - let args = - match named with - | [] -> List.rev unnamed - | _ -> (Rpc.Dict named) :: List.rev unnamed + let wire_name = Idl.get_wire_name !description name in + let calls = + List.map + (fun (named, unnamed) -> + let args = + match named with + | [] -> + List.rev unnamed + | _ -> + Rpc.Dict named :: List.rev unnamed + in + let call = Rpc.call wire_name args in + call) + params + in + List.iteri + (fun i call -> + let request_str = string_of_call call in + write_str + (Printf.sprintf "%s/requests/%s.request.%d" C.test_data_path + wire_name i) + request_str) + calls ; + let vs = + Rpc_genfake.genall 2 + ( match t.Param.name with + | Some n -> + n + | None -> + t.Param.typedef.Rpc.Types.name + ) + t.Param.typedef.Rpc.Types.ty + in + let marshalled_vs = + List.map + (fun v -> + Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v)) + vs + in + let errs = Rpc_genfake.genall 2 "error" e.Error.def.Rpc.Types.ty in + let marshalled_errs = + List.map + (fun err -> + Rpc.failure (Rpcmarshal.marshal e.Error.def.Rpc.Types.ty err)) + errs in - let call = Rpc.call wire_name args in - call) params in - List.iteri (fun i call -> - let request_str = string_of_call call in - write_str - (Printf.sprintf "%s/requests/%s.request.%d" C.test_data_path wire_name i) - request_str) calls; - let vs = Rpc_genfake.genall 2 (match t.Param.name with Some n -> n | None -> t.Param.typedef.Rpc.Types.name) t.Param.typedef.Rpc.Types.ty in - let marshalled_vs = List.map (fun v -> Rpc.success (Rpcmarshal.marshal t.Param.typedef.Rpc.Types.ty v)) vs in - let errs = Rpc_genfake.genall 2 "error" e.Error.def.Rpc.Types.ty in - let marshalled_errs = List.map (fun err -> Rpc.failure (Rpcmarshal.marshal e.Error.def.Rpc.Types.ty err)) errs in - List.iteri (fun i response -> - let response_str = string_of_response response in - write_str - (Printf.sprintf "%s/responses/%s.response.%d" C.test_data_path wire_name i) - response_str) (marshalled_vs @ marshalled_errs) + List.iteri + (fun i response -> + let response_str = string_of_response response in + write_str + (Printf.sprintf "%s/responses/%s.response.%d" C.test_data_path + wire_name i) + response_str) + (marshalled_vs @ marshalled_errs) in let test_fn () = - let mkdir_safe p = begin try Unix.mkdir p 0o755 with Unix.Unix_error (EEXIST, _, _) -> () end in - mkdir_safe C.test_data_path; - mkdir_safe (Printf.sprintf "%s/requests" C.test_data_path); - mkdir_safe (Printf.sprintf "%s/responses" C.test_data_path); - inner [[],[]] ty in - tests := (Printf.sprintf "Generate test data for '%s'" (Idl.get_wire_name !description name), `Quick, test_fn) :: !tests + let mkdir_safe p = + try Unix.mkdir p 0o755 with Unix.Unix_error (EEXIST, _, _) -> () + in + mkdir_safe C.test_data_path ; + mkdir_safe (Printf.sprintf "%s/requests" C.test_data_path) ; + mkdir_safe (Printf.sprintf "%s/responses" C.test_data_path) ; + inner [([], [])] ty + in + tests := + ( Printf.sprintf "Generate test data for '%s'" + (Idl.get_wire_name !description name) + , `Quick + , test_fn ) + :: !tests end let get_arg call has_named name is_opt = - match has_named, name, call.Rpc.params with - | true, Some n, (Rpc.Dict named)::unnamed -> begin - match List.partition (fun (x,_) -> x = n) named with - | (_,arg)::dups,others when is_opt -> - Result.Ok (Rpc.Enum [arg], {call with Rpc.params = (Rpc.Dict (dups @ others))::unnamed }) - | [], _others when is_opt -> Result.Ok (Rpc.Enum [], call) - | (_,arg)::dups,others -> - Result.Ok (arg, {call with Rpc.params = (Rpc.Dict (dups @ others))::unnamed }) - | _,_ -> Result.Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)) - end - | true, None, (Rpc.Dict named)::unnamed -> begin - match unnamed with - | head::tail -> Result.Ok (head, {call with Rpc.params = (Rpc.Dict named)::tail}) - | _ -> Result.Error (`Msg "Incorrect number of arguments") - end - | true, _, _ -> begin - Result.Error (`Msg "Marshalling error: Expecting dict as first argument when named parameters exist") - end - | false, None, head::tail -> begin - Result.Ok (head, {call with Rpc.params = tail}) - end + match (has_named, name, call.Rpc.params) with + | true, Some n, Rpc.Dict named :: unnamed -> ( + match List.partition (fun (x, _) -> x = n) named with + | (_, arg) :: dups, others when is_opt -> + Result.Ok + ( Rpc.Enum [arg] + , {call with Rpc.params= Rpc.Dict (dups @ others) :: unnamed} ) + | [], _others when is_opt -> + Result.Ok (Rpc.Enum [], call) + | (_, arg) :: dups, others -> + Result.Ok + (arg, {call with Rpc.params= Rpc.Dict (dups @ others) :: unnamed}) + | _, _ -> + Result.Error (`Msg (Printf.sprintf "Expecting named argument '%s'" n)) + ) + | true, None, Rpc.Dict named :: unnamed -> ( + match unnamed with + | head :: tail -> + Result.Ok (head, {call with Rpc.params= Rpc.Dict named :: tail}) + | _ -> + Result.Error (`Msg "Incorrect number of arguments") + ) + | true, _, _ -> + Result.Error + (`Msg + "Marshalling error: Expecting dict as first argument when named \ + parameters exist") + | false, None, head :: tail -> + Result.Ok (head, {call with Rpc.params= tail}) | false, None, [] -> - Result.Error (`Msg "Incorrect number of arguments") + Result.Error (`Msg "Incorrect number of arguments") | false, Some _, _ -> - failwith "Can't happen by construction" + failwith "Can't happen by construction" exception NoDescription -exception MarshalError of string +exception MarshalError of string -(** The following module will generate alcotest test cases to verify - that a set of requests and responses can be successfully parsed. +(** The following module will generate alcotest test cases to verify that a set + of requests and responses can be successfully parsed. The CONFIG module specifies the location for the test data as - `test_data_path`. Requests and responses will be looked up in - this location in the subdirectories `requests` and `responses`. - The actual data must be in files following the naming convention - .request. and .response.. - - The code here closely follows that of the GenServer module to - ensure it accurately represents how the server would parse the - json. - *) + `test_data_path`. Requests and responses will be looked up in this location + in the subdirectories `requests` and `responses`. The actual data must be in + files following the naming convention .request. and + .response.. + + The code here closely follows that of the GenServer module to ensure it + accurately represents how the server would parse the json. *) module TestOldRpcs (C : CONFIG) (M : MARSHALLER) = struct open Rpc + type implementation = unit Alcotest.test_case list ref let tests : implementation = ref [] + let description = ref None - let implement x = description := Some x; tests + let implement x = + description := Some x ; + tests + + type ('a, 'b) comp = unit - type ('a,'b) comp = unit type 'a res = unit type _ fn = | Function : 'a Param.t * 'b fn -> ('a -> 'b) fn | Returning : ('a Param.t * 'b Error.t) -> (_, _) comp fn - let returning a b = Returning (a,b) - let (@->) = fun t f -> Function (t, f) + let returning a b = Returning (a, b) + + let ( @-> ) t f = Function (t, f) open M - let rec has_named_args : type a. a fn -> bool = - function - | Function (t, f) -> begin - match t.Param.name with - | Some _ -> true - | None -> has_named_args f - end + let rec has_named_args : type a. a fn -> bool = function + | Function (t, f) -> ( + match t.Param.name with Some _ -> true | None -> has_named_args f + ) | Returning (_, _) -> - false - - let declare : string -> string list -> 'a fn -> _ res = fun name _ ty -> - begin - (* Sanity check: ensure the description has been set before we declare - any RPCs *) - match !description with - | Some _ -> () - | None -> raise NoDescription - end; - + false + + let declare : string -> string list -> 'a fn -> _ res = + fun name _ ty -> + ( (* Sanity check: ensure the description has been set before we declare any + RPCs *) + match !description with + | Some _ -> + () + | None -> + raise NoDescription + ) ; let wire_name = Idl.get_wire_name !description name in - let rec read_all path extension i = try let call = - read_str (Printf.sprintf "%s/%s/%s.%s.%d" C.test_data_path path wire_name extension i) in - call :: read_all path extension (i+1) + read_str + (Printf.sprintf "%s/%s/%s.%s.%d" C.test_data_path path wire_name + extension i) + in + call :: read_all path extension (i + 1) with _ -> [] in - let calls = read_all "requests" "request" 0 |> List.map call_of_string in - let responses = read_all "responses" "response" 0 |> List.map response_of_string in - - let verify : type a. a Rpc.Types.typ -> Rpc.t -> a = fun typ rpc -> + let responses = + read_all "responses" "response" 0 |> List.map response_of_string + in + let verify : type a. a Rpc.Types.typ -> Rpc.t -> a = + fun typ rpc -> let rec sort_dicts ty = let open Rpc in match ty with | Dict kvs' -> - let kvs = List.map (fun (k,v) -> (k, sort_dicts v)) kvs' in - Dict (List.sort (fun (k1,_) (k2,_) -> String.compare k1 k2) kvs) - | Enum ts -> Enum (List.map sort_dicts ts) - | _ -> ty + let kvs = List.map (fun (k, v) -> (k, sort_dicts v)) kvs' in + Dict (List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) kvs) + | Enum ts -> + Enum (List.map sort_dicts ts) + | _ -> + ty in match Rpcmarshal.unmarshal typ rpc with | Ok x -> - let check = Rpcmarshal.marshal typ x in - if (to_string (sort_dicts check)) <> (to_string (sort_dicts rpc)) then begin - match Rpcmarshal.unmarshal typ check with - | Ok y when y <> x -> - let err = Printf.sprintf "Round-trip failed (OCaml values different too). Before: '%s' After: '%s'" - (to_string rpc) - (to_string check) in - raise (MarshalError err) - | Ok _ -> () - | Error (`Msg m) -> - raise (MarshalError m) - end; - x + let check = Rpcmarshal.marshal typ x in + ( if to_string (sort_dicts check) <> to_string (sort_dicts rpc) then + match Rpcmarshal.unmarshal typ check with + | Ok y when y <> x -> + let err = + Printf.sprintf + "Round-trip failed (OCaml values different too). Before: \ + '%s' After: '%s'" + (to_string rpc) (to_string check) + in + raise (MarshalError err) + | Ok _ -> + () + | Error (`Msg m) -> + raise (MarshalError m) + ) ; + x | Error (`Msg m) -> - raise (MarshalError m) + raise (MarshalError m) in - let testfn call response = let has_named = has_named_args ty in - let rec inner : type a. a fn -> Rpc.call -> unit = fun f call -> + let rec inner : type a. a fn -> Rpc.call -> unit = + fun f call -> match f with - | Function (t, f) -> begin - let (arg_rpc, call') = - let is_opt = match t.Param.typedef.Rpc.Types.ty with Rpc.Types.Option _ -> true | _ -> false in + | Function (t, f) -> + let arg_rpc, call' = + let is_opt = + match t.Param.typedef.Rpc.Types.ty with + | Rpc.Types.Option _ -> + true + | _ -> + false + in match get_arg call has_named t.Param.name is_opt with - | Result.Ok (x,y) -> (x,y) - | Result.Error (`Msg m) -> raise (MarshalError m) + | Result.Ok (x, y) -> + (x, y) + | Result.Error (`Msg m) -> + raise (MarshalError m) in - verify t.Param.typedef.Rpc.Types.ty arg_rpc |> ignore; + verify t.Param.typedef.Rpc.Types.ty arg_rpc |> ignore ; inner f call' - end - | Returning (t,e) -> begin + | Returning (t, e) -> ( match response.success with | true -> - verify t.Param.typedef.Rpc.Types.ty response.contents |> ignore + verify t.Param.typedef.Rpc.Types.ty response.contents |> ignore | false -> - verify e.Error.def.Rpc.Types.ty response.contents |> ignore - end - in inner ty call + verify e.Error.def.Rpc.Types.ty response.contents |> ignore + ) + in + inner ty call in (* Check all calls *) let request_tests = - List.mapi (fun i call -> - let response = List.hd responses in - let name = Printf.sprintf "Check old request for '%s': %d" wire_name i in - (name, `Quick, fun () -> testfn call response)) calls in + List.mapi + (fun i call -> + let response = List.hd responses in + let name = + Printf.sprintf "Check old request for '%s': %d" wire_name i + in + (name, `Quick, fun () -> testfn call response)) + calls + in (* Now check all responses *) let response_tests = - List.mapi (fun i response -> - let call = List.hd calls in - let name = Printf.sprintf "Check old response for '%s': %d" wire_name i in - (name, `Quick, fun () -> testfn call response)) responses in - + List.mapi + (fun i response -> + let call = List.hd calls in + let name = + Printf.sprintf "Check old response for '%s': %d" wire_name i + in + (name, `Quick, fun () -> testfn call response)) + responses + in tests := !tests @ request_tests @ response_tests - end diff --git a/lib_test/memory_interface_test.ml b/lib_test/memory_interface_test.ml index 041d171e..06f7e690 100644 --- a/lib_test/memory_interface_test.ml +++ b/lib_test/memory_interface_test.ml @@ -1,11 +1,10 @@ - open Idl_test_common module GenPath = struct let test_data_path = "mem_gen" end + module OldPath = struct let test_data_path = "test_data/memory" end -module C = Memory_interface.API(GenTestData(GenPath)(TJsonrpc)) -module T = Memory_interface.API(TestOldRpcs(OldPath)(TJsonrpc)) +module C = Memory_interface.API (GenTestData (GenPath) (TJsonrpc)) +module T = Memory_interface.API (TestOldRpcs (OldPath) (TJsonrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/network_interface_test.ml b/lib_test/network_interface_test.ml index ce6744fd..bcb43d91 100644 --- a/lib_test/network_interface_test.ml +++ b/lib_test/network_interface_test.ml @@ -1,12 +1,10 @@ - - open Idl_test_common module GenPath = struct let test_data_path = "net_gen" end + module OldPath = struct let test_data_path = "test_data/network" end -module C = Network_interface.Interface_API(GenTestData(GenPath)(TJsonrpc)) -module T = Network_interface.Interface_API(TestOldRpcs(OldPath)(TJsonrpc)) +module C = Network_interface.Interface_API (GenTestData (GenPath) (TJsonrpc)) +module T = Network_interface.Interface_API (TestOldRpcs (OldPath) (TJsonrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/rrd_interface_test.ml b/lib_test/rrd_interface_test.ml index 9b006c65..b3c7ebf7 100644 --- a/lib_test/rrd_interface_test.ml +++ b/lib_test/rrd_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "rrd_gen" end + module OldPath = struct let test_data_path = "test_data/rrd" end -module C = Rrd_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) -module T = Rrd_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) +module C = Rrd_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) +module T = Rrd_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/scheduler_test.ml b/lib_test/scheduler_test.ml index 1d9129cc..63c38a0f 100644 --- a/lib_test/scheduler_test.ml +++ b/lib_test/scheduler_test.ml @@ -1,4 +1,3 @@ - let assert_bool msg = Alcotest.(check bool) msg true let global_scheduler = Scheduler.make () @@ -8,10 +7,10 @@ let test_delay () = let open Scheduler.Delay in let x = make () in let before = Unix.gettimeofday () in - ignore(wait x 0.5); + ignore (wait x 0.5) ; let after = Unix.gettimeofday () in let elapsed = after -. before in - assert_bool "elapsed_time1" (elapsed < 0.6); + assert_bool "elapsed_time1" (elapsed < 0.6) ; assert_bool "elapsed_time2" (elapsed > 0.4) (* Tests that 'wait' can be cancelled *) @@ -20,89 +19,97 @@ let test_delay_cancel () = let x = make () in let before = Unix.gettimeofday () in let th = Thread.create (fun () -> wait x 0.5) () in - signal x; - Thread.join th; + signal x ; + Thread.join th ; let after = Unix.gettimeofday () in let elapsed = after -. before in assert_bool "elapsed_time1" (elapsed < 0.4) -let timed_wait_callback ~msg ?(time_min = 0.) ?(eps=0.1) ?(time_max = 60.) f = +let timed_wait_callback ~msg ?(time_min = 0.) ?(eps = 0.1) ?(time_max = 60.) f = let rd, wr = Unix.pipe () in - let finally () = - Unix.close rd; - Unix.close wr - in + let finally () = Unix.close rd ; Unix.close wr in Fun.protect ~finally (fun () -> let before = Unix.gettimeofday () in let after = ref None in let callback () = - after := Some (Unix.gettimeofday ()); - let (_:int) = Unix.write_substring wr " " 0 1 in + after := Some (Unix.gettimeofday ()) ; + let (_ : int) = Unix.write_substring wr " " 0 1 in () in - f callback; + f callback ; let ready = Thread.wait_timed_read rd time_max in - match ready, !after with + match (ready, !after) with | true, None -> - Alcotest.fail "pipe ready to read, but after is not set" + Alcotest.fail "pipe ready to read, but after is not set" | false, None -> - Alcotest.fail (Printf.sprintf "%s: callback not invoked within %gs" msg time_max) + Alcotest.fail + (Printf.sprintf "%s: callback not invoked within %gs" msg time_max) | _, Some t -> - let actual_minimum = min (t -. before) time_min in - Alcotest.(check (float eps)) - (Printf.sprintf "%s: callback invoked earlier than expected" msg) time_min actual_minimum) - + let actual_minimum = min (t -. before) time_min in + Alcotest.(check (float eps)) + (Printf.sprintf "%s: callback invoked earlier than expected" msg) + time_min actual_minimum) (* Test the injection of a one-shot function at a time in the future *) let test_one_shot () = timed_wait_callback ~msg:"one_shot_success" ~time_min:1.0 (fun callback -> - ignore @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" callback) + ignore + @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" + callback) (* Test the injection of a one-shot function at an absolute time *) let test_one_shot_abs () = timed_wait_callback ~msg:"one_shot_abs_success" ~time_min:1.0 (fun callback -> let now = Scheduler.now () in - ignore @@ Scheduler.one_shot global_scheduler (Scheduler.Absolute (Int64.add 1L now)) "test_one_shot" callback) + ignore + @@ Scheduler.one_shot global_scheduler + (Scheduler.Absolute (Int64.add 1L now)) + "test_one_shot" callback) -(* Tests that the scheduler still works even after a failure occurs in - the injected function *) +(* Tests that the scheduler still works even after a failure occurs in the + injected function *) let test_one_shot_failure () = timed_wait_callback ~msg:"one_show_failure" ~time_min:1.0 (fun callback -> - let _ = Scheduler.one_shot global_scheduler (Scheduler.Delta 0) "test_one_shot" - (fun () -> failwith "Error") in - ignore @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" - callback) + let _ = + Scheduler.one_shot global_scheduler (Scheduler.Delta 0) "test_one_shot" + (fun () -> failwith "Error") + in + ignore + @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" + callback) (* Checks that one-shot functions can cancelled and are then not executed *) let test_one_shot_cancel () = let after = ref None in - let x = Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot_cancel" (fun () -> after := Some (Unix.gettimeofday ())) in - Scheduler.cancel global_scheduler x; - Thread.delay 2.0; - let success = - match !after with - | Some _ -> false - | None -> true + let x = + Scheduler.one_shot global_scheduler (Scheduler.Delta 1) + "test_one_shot_cancel" (fun () -> after := Some (Unix.gettimeofday ())) in + Scheduler.cancel global_scheduler x ; + Thread.delay 2.0 ; + let success = match !after with Some _ -> false | None -> true in assert_bool "one_shot_cancelled" success -(* Check that dumping the state of the scheduler contains a reference to - a test function that has been injected *) +(* Check that dumping the state of the scheduler contains a reference to a test + function that has been injected *) let test_dump () = let after = ref None in let _before = Unix.gettimeofday () in - let _ = Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_dump" - (fun () -> after := Some (Unix.gettimeofday ())) in + let _ = + Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_dump" + (fun () -> after := Some (Unix.gettimeofday ())) + in let dump = Scheduler.Dump.make global_scheduler in - assert_bool "dump_contains_item" (List.exists (fun x -> x.Scheduler.Dump.thing = "test_dump") dump) + assert_bool "dump_contains_item" + (List.exists (fun x -> x.Scheduler.Dump.thing = "test_dump") dump) let tests = [ - "Test Delay", `Slow, test_delay; - "Test Delay cancellation", `Quick, test_delay_cancel; - "Test One shot", `Slow, test_one_shot; - "Test One shot absolute", `Slow, test_one_shot_abs; - "Test One shot failure", `Slow, test_one_shot_failure; - "Test One shot cancellation", `Slow, test_one_shot_cancel; - "Test dump", `Quick, test_dump; + ("Test Delay", `Slow, test_delay) + ; ("Test Delay cancellation", `Quick, test_delay_cancel) + ; ("Test One shot", `Slow, test_one_shot) + ; ("Test One shot absolute", `Slow, test_one_shot_abs) + ; ("Test One shot failure", `Slow, test_one_shot_failure) + ; ("Test One shot cancellation", `Slow, test_one_shot_cancel) + ; ("Test dump", `Quick, test_dump) ] diff --git a/lib_test/storage_interface_test.ml b/lib_test/storage_interface_test.ml index 203259db..4f057ebd 100644 --- a/lib_test/storage_interface_test.ml +++ b/lib_test/storage_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "storage_gen" end + module OldPath = struct let test_data_path = "test_data/storage" end -module C = Storage_interface.StorageAPI(GenTestData(GenPath)(TXmlrpc)) -module T = Storage_interface.StorageAPI(TestOldRpcs(OldPath)(TXmlrpc)) +module C = Storage_interface.StorageAPI (GenTestData (GenPath) (TXmlrpc)) +module T = Storage_interface.StorageAPI (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/syslog_test.ml b/lib_test/syslog_test.ml index 07b00b34..e2e13615 100644 --- a/lib_test/syslog_test.ml +++ b/lib_test/syslog_test.ml @@ -1,24 +1,20 @@ - -(* Test which log levels are masked off by each threshhold level. - Levels are ordered by severity - Err is the highest, Debug the - lowest. If the log threshold is set to Warning, the less - severe levels (Info and Debug) should be masked out. *) +(* Test which log levels are masked off by each threshhold level. Levels are + ordered by severity - Err is the highest, Debug the lowest. If the log + threshold is set to Warning, the less severe levels (Info and Debug) should + be masked out. *) let assert_masked ~threshold (err, warn, info, debug) = - let open Syslog in - assert ((is_masked ~threshold:threshold Err) = err); - assert ((is_masked ~threshold:threshold Warning) = warn); - assert ((is_masked ~threshold:threshold Info) = info); - assert ((is_masked ~threshold:threshold Debug) = debug) + let open Syslog in + assert (is_masked ~threshold Err = err) ; + assert (is_masked ~threshold Warning = warn) ; + assert (is_masked ~threshold Info = info) ; + assert (is_masked ~threshold Debug = debug) let test_is_masked () = - let open Syslog in - assert_masked ~threshold:Debug (false, false, false, false); - assert_masked ~threshold:Info (false, false, false, true); - assert_masked ~threshold:Warning (false, false, true, true); - assert_masked ~threshold:Err (false, true, true, true) + let open Syslog in + assert_masked ~threshold:Debug (false, false, false, false) ; + assert_masked ~threshold:Info (false, false, false, true) ; + assert_masked ~threshold:Warning (false, false, true, true) ; + assert_masked ~threshold:Err (false, true, true, true) -let tests = - [ - "Test Syslog.is_masked", `Quick, test_is_masked; - ] +let tests = [("Test Syslog.is_masked", `Quick, test_is_masked)] diff --git a/lib_test/task_server_test.ml b/lib_test/task_server_test.ml index b58f458e..e8de91c2 100644 --- a/lib_test/task_server_test.ml +++ b/lib_test/task_server_test.ml @@ -1,34 +1,37 @@ - let assert_bool msg = Alcotest.(check bool) msg true module TestInterface = struct let service_name = "test_interface" exception Does_not_exist of (string * string) + exception Cancelled of string - let does_not_exist (a,b) = raise @@ Does_not_exist(a,b) + + let does_not_exist (a, b) = raise @@ Does_not_exist (a, b) + let cancelled a = raise @@ Cancelled a module Task = struct type id = string + type async_result = string [@@deriving rpc] - type completion_t = { - duration : float; - result: async_result option; - } + + type completion_t = {duration: float; result: async_result option} + type state = | Pending of float | Completed of completion_t | Failed of Rpc.t + type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool; + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool } end @@ -37,26 +40,36 @@ module TestInterface = struct | Internal_error of string | Does_not_exist of string * string | Cancelled of string - | Unknown of string [@@deriving rpc] + | Unknown of string + [@@deriving rpc] end exception Internal_error of string let exnty_of_exn = function - | Internal_error s -> Exception.Internal_error s - | Cancelled s -> Exception.Cancelled s - | Does_not_exist (x,y) -> Exception.Does_not_exist (x,y) - | e -> Exception.Unknown (Printexc.to_string e) + | Internal_error s -> + Exception.Internal_error s + | Cancelled s -> + Exception.Cancelled s + | Does_not_exist (x, y) -> + Exception.Does_not_exist (x, y) + | e -> + Exception.Unknown (Printexc.to_string e) + let exn_of_exnty = function - | Exception.Internal_error s -> Internal_error s - | Exception.Does_not_exist (x,y) -> Does_not_exist (x,y) - | Exception.Cancelled s -> Cancelled s - | Exception.Unknown s -> Failure s + | Exception.Internal_error s -> + Internal_error s + | Exception.Does_not_exist (x, y) -> + Does_not_exist (x, y) + | Exception.Cancelled s -> + Cancelled s + | Exception.Unknown s -> + Failure s let marshal_exn e = e |> exnty_of_exn |> Exception.rpc_of_exnty end -module T = Task_server.Task(TestInterface) +module T = Task_server.Task (TestInterface) (* Test that we can add a task and retrieve it from the task list *) let test_add () = @@ -69,251 +82,308 @@ let test_add () = let test_destroy () = let t = T.empty () in let task = T.add t "dbg" (fun _task -> Some "done") in - T.destroy task; + T.destroy task ; let ts = T.list t in assert_bool "Task not in task list" (not (List.mem task ts)) -(* Test 'running' a task, and that the various times associated with the - task make sense, and that the task status is correctly completed with - correct result *) +(* Test 'running' a task, and that the various times associated with the task + make sense, and that the task status is correctly completed with correct + result *) let test_run () = let t = T.empty () in let start = Unix.gettimeofday () in - Thread.delay 0.001; - let task = T.add t "dbg" (fun _task -> Thread.delay 0.001; Some "done") in - T.run task; + Thread.delay 0.001 ; + let task = T.add t "dbg" (fun _task -> Thread.delay 0.001 ; Some "done") in + T.run task ; let t' = T.to_interface_task task in - assert_bool "Task ctime" (t'.TestInterface.Task.ctime > start); + assert_bool "Task ctime" (t'.TestInterface.Task.ctime > start) ; assert_bool "Task result" - (match t'.TestInterface.Task.state with - | TestInterface.Task.Completed {TestInterface.Task.result=Some r; duration} -> - r = "done" && duration > 0.0 - | _ -> false) + ( match t'.TestInterface.Task.state with + | TestInterface.Task.Completed {TestInterface.Task.result= Some r; duration} + -> + r = "done" && duration > 0.0 + | _ -> + false + ) (* Test what happens when the function passed to the task server raises an exception. The task result should be failed with the correct exception *) let test_raise () = - Debug.disable "task_server"; + Debug.disable "task_server" ; let t = T.empty () in - let task = T.add t "dbg" (fun _task -> raise (TestInterface.Internal_error "test")) in - T.run task; + let task = + T.add t "dbg" (fun _task -> raise (TestInterface.Internal_error "test")) + in + T.run task ; let t' = T.to_interface_task task in assert_bool "Task result" - (match t'.TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let s = TestInterface.Exception.exnty_of_rpc r in - s = TestInterface.Exception.Internal_error "test" - with _ -> false - end - | _ -> false) + ( match t'.TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let s = TestInterface.Exception.exnty_of_rpc r in + s = TestInterface.Exception.Internal_error "test" + with _ -> false + ) + | _ -> + false + ) -(* Test cancellation of a task, in this case cancelled before the task is - run. The state should be 'failed' with exception 'cancelled' *) +(* Test cancellation of a task, in this case cancelled before the task is run. + The state should be 'failed' with exception 'cancelled' *) let test_cancel () = let t = T.empty () in - let task = T.add t "dbg" (fun task -> T.check_cancelling task; Some "foo") in + let task = T.add t "dbg" (fun task -> T.check_cancelling task ; Some "foo") in let id = T.id_of_handle task in - T.cancel task; - T.run task; + T.cancel task ; + T.run task ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) -(* Tests the 'with_cancel' function. Tests that the cancel function gets - run on cancellation. In this case, the cancellation happens before the - task is run *) +(* Tests the 'with_cancel' function. Tests that the cancel function gets run on + cancellation. In this case, the cancellation happens before the task is run *) let test_with_cancel () = let t = T.empty () in let cancel_fn_run = ref false in - let task = T.add t "dbg" - (fun task -> T.with_cancel task (fun () -> cancel_fn_run := true) (fun () -> Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task + (fun () -> cancel_fn_run := true) + (fun () -> Some "foo")) + in let id = T.id_of_handle task in - T.cancel task; - T.run task; + T.cancel task ; + T.run task ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false); + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) ; assert_bool "Cancel_fn run" !cancel_fn_run (* Tests what happens when the 'cancel' function passed to 'with_cancel' itself fails. *) let test_with_cancel_failure () = let t = T.empty () in - let task = T.add t "dbg" - (fun task -> T.with_cancel task (fun () -> failwith "moo") (fun () -> Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task (fun () -> failwith "moo") (fun () -> Some "foo")) + in let id = T.id_of_handle task in - T.cancel task; - T.run task; + T.cancel task ; + T.run task ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) -(* Similar to test_with_cancel, but in this case the cancellation function - is called after the task is started *) +(* Similar to test_with_cancel, but in this case the cancellation function is + called after the task is started *) let test_with_cancel2 () = let t = T.empty () in let delay = Scheduler.Delay.make () in let cancel_fn_run = ref false in - let task = T.add t "dbg" - (fun task -> - T.with_cancel task (fun () -> cancel_fn_run := true) - (fun () -> ignore (Scheduler.Delay.wait delay 1.0); - T.check_cancelling task; Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task + (fun () -> cancel_fn_run := true) + (fun () -> + ignore (Scheduler.Delay.wait delay 1.0) ; + T.check_cancelling task ; + Some "foo")) + in let id = T.id_of_handle task in let th = Thread.create (fun () -> T.run task) () in - Thread.delay 0.01; - T.cancel task; - Scheduler.Delay.signal delay; - Thread.join th; + Thread.delay 0.01 ; + T.cancel task ; + Scheduler.Delay.signal delay ; + Thread.join th ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false); + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) ; assert_bool "Cancel_fn run" !cancel_fn_run -(* Similar to test_with_cancel_failure, but as above the cancel_fn is - called after the task has started *) +(* Similar to test_with_cancel_failure, but as above the cancel_fn is called + after the task has started *) let test_with_cancel_failure2 () = let t = T.empty () in let delay = Scheduler.Delay.make () in - let task = T.add t "dbg" - (fun task -> - T.with_cancel task (fun () -> failwith "moo") - (fun () -> ignore (Scheduler.Delay.wait delay 1.0); - T.check_cancelling task; Some "foo")) in + let task = + T.add t "dbg" (fun task -> + T.with_cancel task + (fun () -> failwith "moo") + (fun () -> + ignore (Scheduler.Delay.wait delay 1.0) ; + T.check_cancelling task ; + Some "foo")) + in let id = T.id_of_handle task in let th = Thread.create (fun () -> T.run task) () in - Thread.delay 0.01; - T.cancel task; - Scheduler.Delay.signal delay; - Thread.join th; + Thread.delay 0.01 ; + T.cancel task ; + Scheduler.Delay.signal delay ; + Thread.join th ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id - with _ -> false end - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id + with _ -> false + ) + | _ -> + false + ) -(* Check the 'subtask' functionality. Subtasks are logged in the task - record. *) +(* Check the 'subtask' functionality. Subtasks are logged in the task record. *) let test_subtasks () = let t = T.empty () in - let task = T.add t "dbg" - (fun task -> - let _ : int = T.with_subtask task "subtask1" (fun () -> 0) in - Some "done") in + let task = + T.add t "dbg" (fun task -> + let (_ : int) = T.with_subtask task "subtask1" (fun () -> 0) in + Some "done") + in let _id = T.id_of_handle task in - T.run task; + T.run task ; assert_bool "Subtasks" - ((List.hd (T.to_interface_task task).TestInterface.Task.subtasks |> fst) = "subtask1"); + (List.hd (T.to_interface_task task).TestInterface.Task.subtasks + |> fst + = "subtask1" + ) ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Completed {TestInterface.Task.result=Some r; duration=_} -> - r = "done" - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Completed + {TestInterface.Task.result= Some r; duration= _} -> + r = "done" + | _ -> + false + ) -(* Check what happens when subtasks fail. The whole task should be marked - as failed, and the individual task that caused the problem should be - marked as failed in the task record, with the correct exception. *) +(* Check what happens when subtasks fail. The whole task should be marked as + failed, and the individual task that caused the problem should be marked as + failed in the task record, with the correct exception. *) let test_subtasks_failure () = let t = T.empty () in - let task = T.add t "dbg" - (fun task -> - let _ : int = T.with_subtask task "subtask1" - (fun () -> raise (TestInterface.Internal_error "foo")) in - Some "done") in - T.run task; - let subtask = List.hd (T.to_interface_task task).TestInterface.Task.subtasks in - assert_bool "Subtasks" - (fst subtask = "subtask1"); + let task = + T.add t "dbg" (fun task -> + let (_ : int) = + T.with_subtask task "subtask1" (fun () -> + raise (TestInterface.Internal_error "foo")) + in + Some "done") + in + T.run task ; + let subtask = + List.hd (T.to_interface_task task).TestInterface.Task.subtasks + in + assert_bool "Subtasks" (fst subtask = "subtask1") ; assert_bool "Subtasks" - (match snd subtask with - | TestInterface.Task.Failed r -> - r |> TestInterface.Exception.exnty_of_rpc = TestInterface.Exception.Internal_error "foo" - | _ -> false); + ( match snd subtask with + | TestInterface.Task.Failed r -> + r + |> TestInterface.Exception.exnty_of_rpc + = TestInterface.Exception.Internal_error "foo" + | _ -> + false + ) ; assert_bool "Task result" - (match (T.to_interface_task task).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - r |> TestInterface.Exception.exnty_of_rpc = TestInterface.Exception.Internal_error "foo" - | _ -> false) + ( match (T.to_interface_task task).TestInterface.Task.state with + | TestInterface.Task.Failed r -> + r + |> TestInterface.Exception.exnty_of_rpc + = TestInterface.Exception.Internal_error "foo" + | _ -> + false + ) -(* Test the cancellation points functionality. In here, we ask for task 'dbg' - to be cancelled at the 5th time it checks for cancellation. Verify this - succeeds for the task specified, and doesn't for the other task *) +(* Test the cancellation points functionality. In here, we ask for task 'dbg' to + be cancelled at the 5th time it checks for cancellation. Verify this succeeds + for the task specified, and doesn't for the other task *) let test_cancel_trigger () = let t = T.empty () in - T.set_cancel_trigger t "dbg" 5; + T.set_cancel_trigger t "dbg" 5 ; let xxx = ref 0 in let dbg = ref 0 in let fn x task = let rec loop n = - x := n; - if n=0 then () else (T.check_cancelling task; loop (n-1)) - in loop 10; - Some "done" + x := n ; + if n = 0 then + () + else ( + T.check_cancelling task ; + loop (n - 1) + ) + in + loop 10 ; Some "done" in let task1 = T.add t "xxx" (fn xxx) in let task2 = T.add t "dbg" (fn dbg) in let id2 = T.id_of_handle task2 in - T.run task1; - T.run task2; + T.run task1 ; + T.run task2 ; assert_bool "Task result" - (match (T.to_interface_task task2).TestInterface.Task.state with - | TestInterface.Task.Failed r -> - begin - try - let e = TestInterface.Exception.exnty_of_rpc r in - e = TestInterface.Exception.Cancelled id2 - with _ -> false end - | _ -> false); + ( match (T.to_interface_task task2).TestInterface.Task.state with + | TestInterface.Task.Failed r -> ( + try + let e = TestInterface.Exception.exnty_of_rpc r in + e = TestInterface.Exception.Cancelled id2 + with _ -> false + ) + | _ -> + false + ) ; assert_bool "Task result" - (match (T.to_interface_task task1).TestInterface.Task.state with - | TestInterface.Task.Completed {TestInterface.Task.result=Some r; duration=_} -> - r = "done" - | _ -> false); - assert_bool "cancel points xxx" (!xxx = 0); + ( match (T.to_interface_task task1).TestInterface.Task.state with + | TestInterface.Task.Completed + {TestInterface.Task.result= Some r; duration= _} -> + r = "done" + | _ -> + false + ) ; + assert_bool "cancel points xxx" (!xxx = 0) ; assert_bool "cancel points dbg" (!dbg = 6) let tests = [ - "Test adding a task", `Quick, test_add; - "Test removing a task", `Quick, test_destroy; - "Test run", `Quick, test_run; - "Test raise", `Quick, test_raise; - "Test cancel", `Quick, test_cancel; - "Test with_cancel", `Quick, test_with_cancel; - "Test with_cancel_failure", `Quick, test_with_cancel_failure; - "Test with_cancel 2", `Quick, test_with_cancel2; - "Test with_cancel_failure2", `Quick, test_with_cancel_failure2; - "Test subtasks", `Quick, test_subtasks; - "Test subtask failure", `Quick, test_subtasks_failure; - "Test cancel trigger", `Quick, test_cancel_trigger; + ("Test adding a task", `Quick, test_add) + ; ("Test removing a task", `Quick, test_destroy) + ; ("Test run", `Quick, test_run) + ; ("Test raise", `Quick, test_raise) + ; ("Test cancel", `Quick, test_cancel) + ; ("Test with_cancel", `Quick, test_with_cancel) + ; ("Test with_cancel_failure", `Quick, test_with_cancel_failure) + ; ("Test with_cancel 2", `Quick, test_with_cancel2) + ; ("Test with_cancel_failure2", `Quick, test_with_cancel_failure2) + ; ("Test subtasks", `Quick, test_subtasks) + ; ("Test subtask failure", `Quick, test_subtasks_failure) + ; ("Test cancel trigger", `Quick, test_cancel_trigger) ] diff --git a/lib_test/test.ml b/lib_test/test.ml index bc0f0d48..32779202 100644 --- a/lib_test/test.ml +++ b/lib_test/test.ml @@ -1,27 +1,28 @@ let () = Alcotest.run "Base suite" - [ (* interface tests *) - "Test memory interface", Memory_interface_test.tests; - "Test network interface", Network_interface_test.tests; - "Test Gpumon interface", Gpumon_interface_test.tests; - "Test RRD interface", Rrd_interface_test.tests; - "Test Storage interface", Storage_interface_test.tests; - "Test cluster interface", Cluster_interface_test.tests; - "Test varstore privileged interfaces", Varstore_interfaces_test.Privileged.tests; - "Test varstore deprivileged interfaces", Varstore_interfaces_test.Deprivileged.tests; - "Test v6 interface", V6_interface_test.tests; - - (* custom tests *) - "Test Debug module", Debug_test.tests; - "Task_server tests", Task_server_test.tests; - "Udpates tests", Updates_test.tests; - "Scheduler tests", Scheduler_test.tests; - "Syslog tests", Syslog_test.tests; - "Cohttp_posix_io tests", Http_test.tests; - "Xenops_interface tests", Xen_test.tests; - "Device_number tests", Device_number_test.tests; - "xcp-config-file tests", Config_file_test.tests; - (* "xcp-channel-test", Channel_test.tests; TODO: Turn these on when the code works. *) + [ + (* interface tests *) + ("Test memory interface", Memory_interface_test.tests) + ; ("Test network interface", Network_interface_test.tests) + ; ("Test Gpumon interface", Gpumon_interface_test.tests) + ; ("Test RRD interface", Rrd_interface_test.tests) + ; ("Test Storage interface", Storage_interface_test.tests) + ; ("Test cluster interface", Cluster_interface_test.tests) + ; ( "Test varstore privileged interfaces" + , Varstore_interfaces_test.Privileged.tests ) + ; ( "Test varstore deprivileged interfaces" + , Varstore_interfaces_test.Deprivileged.tests ) + ; ("Test v6 interface", V6_interface_test.tests) + ; (* custom tests *) + ("Test Debug module", Debug_test.tests) + ; ("Task_server tests", Task_server_test.tests) + ; ("Udpates tests", Updates_test.tests) + ; ("Scheduler tests", Scheduler_test.tests) + ; ("Syslog tests", Syslog_test.tests) + ; ("Cohttp_posix_io tests", Http_test.tests) + ; ("Xenops_interface tests", Xen_test.tests) + ; ("Device_number tests", Device_number_test.tests) + ; ("xcp-config-file tests", Config_file_test.tests) + (* "xcp-channel-test", Channel_test.tests; TODO: Turn these on when the + code works. *) ] - - diff --git a/lib_test/updates_test.ml b/lib_test/updates_test.ml index a34d0259..28845cea 100644 --- a/lib_test/updates_test.ml +++ b/lib_test/updates_test.ml @@ -2,211 +2,232 @@ let assert_bool msg = Alcotest.(check bool) msg true -let rpc = Alcotest.testable (Fmt.of_to_string Rpc.to_string) (=) +let rpc = Alcotest.testable (Fmt.of_to_string Rpc.to_string) ( = ) (* See xen/xenops_interface.ml for a real example *) module TestInterface = struct let service_name = "test_updates" module Dynamic = struct - type id = Foo of string | Bar of string - [@@deriving rpc] + type id = Foo of string | Bar of string [@@deriving rpc] end end let scheduler = Scheduler.make () + let update_a = TestInterface.Dynamic.Foo "a" + let update_b = TestInterface.Dynamic.Foo "b" + let update_c = TestInterface.Dynamic.Foo "c" -module M = Updates.Updates(TestInterface) +module M = Updates.Updates (TestInterface) (* Tests adding and getting an update *) let test_add () = let u = M.empty scheduler in - M.add update_a u; - let (_barriers,updates,_id) = M.get "dbg" None (Some 0) u in - assert_bool "Update returned" (List.length updates = 1 && List.exists (fun x -> x=update_a) updates) + M.add update_a u ; + let _barriers, updates, _id = M.get "dbg" None (Some 0) u in + assert_bool "Update returned" + (List.length updates = 1 && List.exists (fun x -> x = update_a) updates) (* Tests that no updates are returned if none exist *) let test_noadd () = let u = M.empty scheduler in - let (_barriers,updates,_id) = M.get "dbg" None (Some 0) u in + let _barriers, updates, _id = M.get "dbg" None (Some 0) u in assert_bool "Update returned" (List.length updates = 0) (* Tests that we can remove an update, and that it's not then returned by 'get' *) let test_remove () = let u = M.empty scheduler in - M.add update_a u; - M.remove update_a u; - let (_barriers,updates,_id) = M.get "dbg" None (Some 0) u in + M.add update_a u ; + M.remove update_a u ; + let _barriers, updates, _id = M.get "dbg" None (Some 0) u in assert_bool "Update returned" (List.length updates = 0) -(* Tests that, if we specify a timeout, the 'get' call returns the empty - list after that timeout. *) +(* Tests that, if we specify a timeout, the 'get' call returns the empty list + after that timeout. *) let test_timeout () = let u = M.empty scheduler in let before = Unix.gettimeofday () in - let (_,l,_) = M.get "dbg" None (Some 1) u in + let _, l, _ = M.get "dbg" None (Some 1) u in let duration = Unix.gettimeofday () -. before in - assert_bool "Duration greater than 1 sec" (duration > 1.0 && duration < 2.0); + assert_bool "Duration greater than 1 sec" (duration > 1.0 && duration < 2.0) ; assert_bool "Returned list was empty" (List.length l = 0) -(* Checks that if we add an event after a blocking 'get' call that the call - is unblocked. Verifies that the call returns immediately and that the - correct update was returned. *) +(* Checks that if we add an event after a blocking 'get' call that the call is + unblocked. Verifies that the call returns immediately and that the correct + update was returned. *) let test_add_after_get () = let u = M.empty scheduler in let ok = ref false in let before = Unix.gettimeofday () in - let th = Thread.create (fun () -> - let (_,updates,_) = M.get "dbg" None (Some 0) u in - ok := List.length updates = 1 && List.exists (fun x -> x=update_a) updates) () in - M.add update_a u; - Thread.join th; + let th = + Thread.create + (fun () -> + let _, updates, _ = M.get "dbg" None (Some 0) u in + ok := + List.length updates = 1 && List.exists (fun x -> x = update_a) updates) + () + in + M.add update_a u ; + Thread.join th ; let duration = Unix.gettimeofday () -. before in assert_bool "Update returned" (!ok && duration < 0.1) -(* Test injecting a barrier. Adds two updates before injecting a barrier, - then adds two more events. Checks that the barrier is returned and contains - the expected 2 updates from before the barrier was injected. Also checks - that the updates returned from the 'get' contain all 3 updates in the - correct order *) +(* Test injecting a barrier. Adds two updates before injecting a barrier, then + adds two more events. Checks that the barrier is returned and contains the + expected 2 updates from before the barrier was injected. Also checks that the + updates returned from the 'get' contain all 3 updates in the correct order *) let test_inject_barrier () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.inject_barrier 1 (fun _ _ -> true) u; - M.add update_a u; - M.add update_c u; - let (barriers,updates,_id) = M.get "dbg" None (Some 1) u in - assert_bool "Barrier returned" (List.length barriers = 1); - assert_bool "Barriers contains our barrier" (List.exists (fun x -> fst x = 1) barriers); + M.add update_a u ; + M.add update_b u ; + M.inject_barrier 1 (fun _ _ -> true) u ; + M.add update_a u ; + M.add update_c u ; + let barriers, updates, _id = M.get "dbg" None (Some 1) u in + assert_bool "Barrier returned" (List.length barriers = 1) ; + assert_bool "Barriers contains our barrier" + (List.exists (fun x -> fst x = 1) barriers) ; let our_barrier = List.hd barriers in let barrier_contains u = List.mem u (snd our_barrier) in assert_bool "Our barrier contains Foo 'a' and Foo 'b'" - (barrier_contains update_a && barrier_contains update_b); + (barrier_contains update_a && barrier_contains update_b) ; assert_bool "Updates contain all updates" - (List.nth updates 0 = update_b && - List.nth updates 1 = update_a && - List.nth updates 2 = update_c) + (List.nth updates 0 = update_b + && List.nth updates 1 = update_a + && List.nth updates 2 = update_c + ) -(* Test the removal of a barrier. Adds a barrier as above, then removes - it and makes sure it doesn't show up in a subsequent 'get' *) +(* Test the removal of a barrier. Adds a barrier as above, then removes it and + makes sure it doesn't show up in a subsequent 'get' *) let test_remove_barrier () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.inject_barrier 1 (fun _ _ -> true) u; - M.add update_a u; - M.add update_c u; - M.remove_barrier 1 u; - let (barriers,updates,_id) = M.get "dbg" None (Some 1) u in - assert_bool "Barrier returned" (List.length barriers = 0); + M.add update_a u ; + M.add update_b u ; + M.inject_barrier 1 (fun _ _ -> true) u ; + M.add update_a u ; + M.add update_c u ; + M.remove_barrier 1 u ; + let barriers, updates, _id = M.get "dbg" None (Some 1) u in + assert_bool "Barrier returned" (List.length barriers = 0) ; assert_bool "Updates contain all updates" - (List.nth updates 0 = update_b && - List.nth updates 1 = update_a && - List.nth updates 2 = update_c) + (List.nth updates 0 = update_b + && List.nth updates 1 = update_a + && List.nth updates 2 = update_c + ) -(* This is a similar check to the above, but round-trips through an - Rpc.t to verify the hand-written t_of_rpc and rpc_of_t functions are - correct *) +(* This is a similar check to the above, but round-trips through an Rpc.t to + verify the hand-written t_of_rpc and rpc_of_t functions are correct *) let test_inject_barrier_rpc () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.inject_barrier 1 (fun _ _ -> true) u; - M.add update_a u; - M.add update_c u; - let (barriers,updates,_id) = M.get "dbg" None (Some 1) u in - assert_bool "Barrier returned" (List.length barriers = 1); - assert_bool "Barriers contains our barrier" (List.exists (fun x -> fst x = 1) barriers); + M.add update_a u ; + M.add update_b u ; + M.inject_barrier 1 (fun _ _ -> true) u ; + M.add update_a u ; + M.add update_c u ; + let barriers, updates, _id = M.get "dbg" None (Some 1) u in + assert_bool "Barrier returned" (List.length barriers = 1) ; + assert_bool "Barriers contains our barrier" + (List.exists (fun x -> fst x = 1) barriers) ; let our_barrier = List.hd barriers in let barrier_contains u = List.mem u (snd our_barrier) in assert_bool "Our barrier contains Foo 'a' and Foo 'b'" - (barrier_contains update_a && barrier_contains update_b); + (barrier_contains update_a && barrier_contains update_b) ; assert_bool "Updates contain all updates" - (List.nth updates 0 = update_b && - List.nth updates 1 = update_a && - List.nth updates 2 = update_c) + (List.nth updates 0 = update_b + && List.nth updates 1 = update_a + && List.nth updates 2 = update_c + ) (* Check that the token returned by the first 'get' can be passed to a - subsequent 'get' invocation. This second one should return only events - that happend after the first 'get' *) + subsequent 'get' invocation. This second one should return only events that + happend after the first 'get' *) let test_multiple_gets () = let u = M.empty scheduler in - M.add update_a u; - let (_,updates1,id) = M.get "dbg" None (Some 1) u in - M.add update_b u; - let (_,updates2,_) = M.get "dbg" (Some id) (Some 1) u in + M.add update_a u ; + let _, updates1, id = M.get "dbg" None (Some 1) u in + M.add update_b u ; + let _, updates2, _ = M.get "dbg" (Some id) (Some 1) u in assert_bool "Updates contain correct updates" - (List.nth updates1 0 = update_a && - List.nth updates2 0 = update_b && - List.length updates1 = 1 && - List.length updates2 = 1) - -(* Test the filter function for filtering out events. Here we add events - 'a' and 'b', then filter out everything but 'a', and check that a - subsequent 'get' call returns only update 'a' *) + (List.nth updates1 0 = update_a + && List.nth updates2 0 = update_b + && List.length updates1 = 1 + && List.length updates2 = 1 + ) + +(* Test the filter function for filtering out events. Here we add events 'a' and + 'b', then filter out everything but 'a', and check that a subsequent 'get' + call returns only update 'a' *) let test_filter () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; - M.filter (function | Foo "a" -> true | _ -> false) u; - let (_,updates1,_id) = M.get "dbg" None (Some 1) u in + M.add update_a u ; + M.add update_b u ; + M.filter (function Foo "a" -> true | _ -> false) u ; + let _, updates1, _id = M.get "dbg" None (Some 1) u in assert_bool "Updates contain correct updates" - (List.nth updates1 0 = update_a && - List.length updates1 = 1) + (List.nth updates1 0 = update_a && List.length updates1 = 1) -(* Check that a dumped updates.t value has the correct Rpc representation. - Note that the dumped Rpc contains embedded strings containing json... *) +(* Check that a dumped updates.t value has the correct Rpc representation. Note + that the dumped Rpc contains embedded strings containing json... *) let test_dump () = let u = M.empty scheduler in - M.add update_a u; - M.inject_barrier 1 (fun _ _ -> true) u; + M.add update_a u ; + M.inject_barrier 1 (fun _ _ -> true) u ; let dump = M.Dump.make u in let dumped_rpc = M.Dump.rpc_of_dump dump in - let expected_rpc = Rpc.Dict - [("updates", - Rpc.Enum - [Rpc.Dict [("id", Rpc.Int 1L); ("v", Rpc.String "[\"Foo\",\"a\"]")]]); - ("barriers", - Rpc.Enum - [Rpc.Enum - [Rpc.Int 1L; Rpc.Int 2L; + let expected_rpc = + Rpc.Dict + [ + ( "updates" + , Rpc.Enum + [Rpc.Dict [("id", Rpc.Int 1L); ("v", Rpc.String "[\"Foo\",\"a\"]")]] + ) + ; ( "barriers" + , Rpc.Enum + [ Rpc.Enum - [Rpc.Dict - [ ("id", Rpc.Int 1L) - ; ("v", Rpc.String "[\"Foo\",\"a\"]") - ]]]] - )] + [ + Rpc.Int 1L + ; Rpc.Int 2L + ; Rpc.Enum + [ + Rpc.Dict + [ + ("id", Rpc.Int 1L); ("v", Rpc.String "[\"Foo\",\"a\"]") + ] + ] + ] + ] ) + ] in Alcotest.check rpc "same RPC value" dumped_rpc expected_rpc -(* Test that last_id returns a token that can be passed to 'get'. This get call should - then only return events that were added _after_ the call to 'last_id' *) +(* Test that last_id returns a token that can be passed to 'get'. This get call + should then only return events that were added _after_ the call to 'last_id' *) let test_last_id () = let u = M.empty scheduler in - M.add update_a u; - M.add update_b u; + M.add update_a u ; + M.add update_b u ; let id = M.last_id "dbg" u in - M.add update_c u; - let (_,updates,_) = M.get "dbg" (Some id) (Some 1) u in + M.add update_c u ; + let _, updates, _ = M.get "dbg" (Some id) (Some 1) u in assert_bool "Only later events returned" - (List.length updates = 1 && List.exists (fun x -> x=update_c) updates) + (List.length updates = 1 && List.exists (fun x -> x = update_c) updates) let tests = [ - "Test no add", `Quick, test_noadd; - "Test add", `Quick, test_add; - "Test remove", `Quick, test_remove; - "Test timeout", `Slow, test_timeout; - "Test add after get", `Quick, test_add_after_get; - "Test inject barrier", `Quick, test_inject_barrier; - "Test remove barrier", `Quick, test_remove_barrier; - "Test inject barrier with rpc", `Quick, test_inject_barrier_rpc; - "Test multiple gets", `Quick, test_multiple_gets; - "Test filter", `Quick, test_filter; - "Test dump", `Quick, test_dump; - "Test last_id", `Quick, test_last_id; + ("Test no add", `Quick, test_noadd) + ; ("Test add", `Quick, test_add) + ; ("Test remove", `Quick, test_remove) + ; ("Test timeout", `Slow, test_timeout) + ; ("Test add after get", `Quick, test_add_after_get) + ; ("Test inject barrier", `Quick, test_inject_barrier) + ; ("Test remove barrier", `Quick, test_remove_barrier) + ; ("Test inject barrier with rpc", `Quick, test_inject_barrier_rpc) + ; ("Test multiple gets", `Quick, test_multiple_gets) + ; ("Test filter", `Quick, test_filter) + ; ("Test dump", `Quick, test_dump) + ; ("Test last_id", `Quick, test_last_id) ] diff --git a/lib_test/v6_interface_test.ml b/lib_test/v6_interface_test.ml index 96968e01..c546fa29 100644 --- a/lib_test/v6_interface_test.ml +++ b/lib_test/v6_interface_test.ml @@ -1,10 +1,10 @@ open Idl_test_common module GenPath = struct let test_data_path = "v6_gen" end + module OldPath = struct let test_data_path = "test_data/v6" end -module C = V6_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) -module T = V6_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) +module C = V6_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) +module T = V6_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) -let tests = - !C.implementation @ !T.implementation +let tests = !C.implementation @ !T.implementation diff --git a/lib_test/varstore_interfaces_test.ml b/lib_test/varstore_interfaces_test.ml index 7956cc13..29c47e07 100644 --- a/lib_test/varstore_interfaces_test.ml +++ b/lib_test/varstore_interfaces_test.ml @@ -2,21 +2,30 @@ open Idl_test_common module Privileged = struct module GenPath = struct let test_data_path = "varstore_privileged_gen" end - module OldPath = struct let test_data_path = "test_data/varstore/privileged" end - module C = Varstore_privileged_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) - module T = Varstore_privileged_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) + module OldPath = struct + let test_data_path = "test_data/varstore/privileged" + end - let tests = - !C.implementation @ !T.implementation + module C = + Varstore_privileged_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) + module T = + Varstore_privileged_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) + + let tests = !C.implementation @ !T.implementation end + module Deprivileged = struct module GenPath = struct let test_data_path = "varstore_deprivileged_gen" end - module OldPath = struct let test_data_path = "test_data/varstore/deprivileged" end - module C = Varstore_deprivileged_interface.RPC_API(GenTestData(GenPath)(TXmlrpc)) - module T = Varstore_deprivileged_interface.RPC_API(TestOldRpcs(OldPath)(TXmlrpc)) + module OldPath = struct + let test_data_path = "test_data/varstore/deprivileged" + end + + module C = + Varstore_deprivileged_interface.RPC_API (GenTestData (GenPath) (TXmlrpc)) + module T = + Varstore_deprivileged_interface.RPC_API (TestOldRpcs (OldPath) (TXmlrpc)) - let tests = - !C.implementation @ !T.implementation + let tests = !C.implementation @ !T.implementation end diff --git a/lib_test/xen_test.ml b/lib_test/xen_test.ml index f4aeb420..ce02702b 100644 --- a/lib_test/xen_test.ml +++ b/lib_test/xen_test.ml @@ -1,23 +1,43 @@ - -(* This was created on a creedence host. I have deliberately removed the field *) -(* *) -(* "name": "foo" *) -(* *) +(* This was created on a creedence host. I have deliberately removed the field *) +(* *) +(* "name": "foo" *) +(* *) (* from just after the 'id' field. This is to test that the field gets defaulted *) -(* to the value specified in the idl. *) +(* to the value specified in the idl. *) -let old_vm_t = "{\"id\": \"bc6b8e8a-f0a5-4746-6489-2745756f21b2\", \"ssidref\": 0, \"xsdata\": {\"vm-data\": \"\"}, \"platformdata\": {\"generation-id\": \"\", \"timeoffset\": \"0\", \"usb\": \"true\", \"usb_tablet\": \"true\"}, \"bios_strings\": {\"bios-vendor\": \"Xen\", \"bios-version\": \"\", \"system-manufacturer\": \"Xen\", \"system-product-name\": \"HVM domU\", \"system-version\": \"\", \"system-serial-number\": \"\", \"hp-rombios\": \"\", \"oem-1\":\"Xen\", \"oem-2\": \"MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d\"}, \"ty\": [\"HVM\", {\"hap\": true, \"shadow_multiplier\": 1.000000, \"timeoffset\": \"0\", \"video_mib\": 4, \"video\": \"Cirrus\", \"acpi\": true, \"serial\": \"pty\", \"keymap\": \"en-us\", \"pci_emulations\": [], \"pci_passthrough\": false, \"boot_order\": \"cd\", \"qemu_disk_cmdline\": false, \"qemu_stubdom\": false}], \"suppress_spurious_page_faults\": false, \"memory_static_max\": 268435456, \"memory_dynamic_max\": 268435456, \"memory_dynamic_min\": 134217728, \"vcpu_max\": 1, \"vcpus\": 1, \"scheduler_params\": {\"priority\": [256, 0], \"affinity\": []}, \"on_crash\": [\"Shutdown\"], \"on_shutdown\": [\"Shutdown\"], \"on_reboot\": [\"Start\"], \"pci_msitranslate\": true, \"pci_power_mgmt\": false}" +let old_vm_t = + "{\"id\": \"bc6b8e8a-f0a5-4746-6489-2745756f21b2\", \"ssidref\": 0, \ + \"xsdata\": {\"vm-data\": \"\"}, \"platformdata\": {\"generation-id\": \ + \"\", \"timeoffset\": \"0\", \"usb\": \"true\", \"usb_tablet\": \"true\"}, \ + \"bios_strings\": {\"bios-vendor\": \"Xen\", \"bios-version\": \"\", \ + \"system-manufacturer\": \"Xen\", \"system-product-name\": \"HVM domU\", \ + \"system-version\": \"\", \"system-serial-number\": \"\", \"hp-rombios\": \ + \"\", \"oem-1\":\"Xen\", \"oem-2\": \ + \"MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d\"}, \"ty\": \ + [\"HVM\", {\"hap\": true, \"shadow_multiplier\": 1.000000, \"timeoffset\": \ + \"0\", \"video_mib\": 4, \"video\": \"Cirrus\", \"acpi\": true, \"serial\": \ + \"pty\", \"keymap\": \"en-us\", \"pci_emulations\": [], \ + \"pci_passthrough\": false, \"boot_order\": \"cd\", \"qemu_disk_cmdline\": \ + false, \"qemu_stubdom\": false}], \"suppress_spurious_page_faults\": false, \ + \"memory_static_max\": 268435456, \"memory_dynamic_max\": 268435456, \ + \"memory_dynamic_min\": 134217728, \"vcpu_max\": 1, \"vcpus\": 1, \ + \"scheduler_params\": {\"priority\": [256, 0], \"affinity\": []}, \ + \"on_crash\": [\"Shutdown\"], \"on_shutdown\": [\"Shutdown\"], \ + \"on_reboot\": [\"Start\"], \"pci_msitranslate\": true, \"pci_power_mgmt\": \ + false}" let test_upgrade_rules () = - let old_json = old_vm_t in - let rpc = Jsonrpc.of_string old_json in - let vm_t = match Rpcmarshal.unmarshal Xenops_interface.Vm.t.Rpc.Types.ty rpc with - | Ok vm -> vm - | Error (`Msg m) -> failwith (Printf.sprintf "Failed to unmarshal: %s" m) + let old_json = old_vm_t in + let rpc = Jsonrpc.of_string old_json in + let vm_t = + match Rpcmarshal.unmarshal Xenops_interface.Vm.t.Rpc.Types.ty rpc with + | Ok vm -> + vm + | Error (`Msg m) -> + failwith (Printf.sprintf "Failed to unmarshal: %s" m) in - Alcotest.(check string) "VM name" vm_t.Xenops_interface.Vm.name "unnamed" (* this value is the default in xenops_interface.ml *) + Alcotest.(check string) "VM name" vm_t.Xenops_interface.Vm.name "unnamed" + +(* this value is the default in xenops_interface.ml *) -let tests = - [ - "check upgrade rule", `Quick, test_upgrade_rules - ] +let tests = [("check upgrade rule", `Quick, test_upgrade_rules)] diff --git a/memory/memory.ml b/memory/memory.ml index cfd1bacf..fedb7591 100644 --- a/memory/memory.ml +++ b/memory/memory.ml @@ -14,77 +14,103 @@ (** Functions relating to memory requirements of Xen domains *) let ( +++ ) = Int64.add + let ( --- ) = Int64.sub + let ( *** ) = Int64.mul + let ( /// ) = Int64.div (* === Memory conversion factors ============================================ *) -let bytes_per_kib = 1024L -let bytes_per_mib = 1048576L +let bytes_per_kib = 1024L + +let bytes_per_mib = 1048576L + let bytes_per_page = 4096L -let kib_per_page = bytes_per_page /// bytes_per_kib -let kib_per_mib = 1024L -let pages_per_mib = bytes_per_mib /// bytes_per_page + +let kib_per_page = bytes_per_page /// bytes_per_kib + +let kib_per_mib = 1024L + +let pages_per_mib = bytes_per_mib /// bytes_per_page (* === Arithmetic functions ================================================= *) (** Returns true if (and only if) the specified argument is a power of 2. *) -let is_power_of_2 n = - (n > 0) && (n land (0 - n) = n) +let is_power_of_2 n = n > 0 && n land (0 - n) = n -let round_down_to_multiple_of x y = - (x /// y) *** y +let round_down_to_multiple_of x y = (x /// y) *** y -let round_up_to_multiple_of x y = - ((x +++ y --- 1L) /// y) *** y +let round_up_to_multiple_of x y = ((x +++ y --- 1L) /// y) *** y (* === Memory rounding functions ============================================ *) let round_up = round_up_to_multiple_of + let round_down = round_down_to_multiple_of let round_bytes_down_to_nearest_page_boundary v = round_down v bytes_per_page -let round_bytes_down_to_nearest_mib v = round_down v bytes_per_mib -let round_kib_down_to_nearest_page_boundary v = round_down v kib_per_page -let round_kib_up_to_nearest_page_boundary v = round_up v kib_per_page -let round_kib_up_to_nearest_mib v = round_up v kib_per_mib -let round_pages_up_to_nearest_mib v = round_up v pages_per_mib + +let round_bytes_down_to_nearest_mib v = round_down v bytes_per_mib + +let round_kib_down_to_nearest_page_boundary v = round_down v kib_per_page + +let round_kib_up_to_nearest_page_boundary v = round_up v kib_per_page + +let round_kib_up_to_nearest_mib v = round_up v kib_per_mib + +let round_pages_up_to_nearest_mib v = round_up v pages_per_mib (* === Division functions =================================================== *) -let divide_rounding_down numerator denominator = - numerator /// denominator +let divide_rounding_down numerator denominator = numerator /// denominator let divide_rounding_up numerator denominator = (numerator +++ denominator --- 1L) /// denominator (* === Memory unit conversion functions ===================================== *) -let bytes_of_kib value = value *** bytes_per_kib +let bytes_of_kib value = value *** bytes_per_kib + let bytes_of_pages value = value *** bytes_per_page -let bytes_of_mib value = value *** bytes_per_mib -let kib_of_mib value = value *** kib_per_mib -let kib_of_pages value = value *** kib_per_page -let pages_of_mib value = value *** pages_per_mib -let kib_of_bytes_free value = divide_rounding_down value bytes_per_kib +let bytes_of_mib value = value *** bytes_per_mib + +let kib_of_mib value = value *** kib_per_mib + +let kib_of_pages value = value *** kib_per_page + +let pages_of_mib value = value *** pages_per_mib + +let kib_of_bytes_free value = divide_rounding_down value bytes_per_kib + let pages_of_bytes_free value = divide_rounding_down value bytes_per_page -let pages_of_kib_free value = divide_rounding_down value kib_per_page -let mib_of_bytes_free value = divide_rounding_down value bytes_per_mib -let mib_of_kib_free value = divide_rounding_down value kib_per_mib -let mib_of_pages_free value = divide_rounding_down value pages_per_mib -let kib_of_bytes_used value = divide_rounding_up value bytes_per_kib +let pages_of_kib_free value = divide_rounding_down value kib_per_page + +let mib_of_bytes_free value = divide_rounding_down value bytes_per_mib + +let mib_of_kib_free value = divide_rounding_down value kib_per_mib + +let mib_of_pages_free value = divide_rounding_down value pages_per_mib + +let kib_of_bytes_used value = divide_rounding_up value bytes_per_kib + let pages_of_bytes_used value = divide_rounding_up value bytes_per_page -let pages_of_kib_used value = divide_rounding_up value kib_per_page -let mib_of_bytes_used value = divide_rounding_up value bytes_per_mib -let mib_of_kib_used value = divide_rounding_up value kib_per_mib -let mib_of_pages_used value = divide_rounding_up value pages_per_mib -(* === Domain memory breakdown ======================================================= *) +let pages_of_kib_used value = divide_rounding_up value kib_per_page -(* +let mib_of_bytes_used value = divide_rounding_up value bytes_per_mib + +let mib_of_kib_used value = divide_rounding_up value kib_per_mib + +let mib_of_pages_used value = + divide_rounding_up value pages_per_mib + (* === Domain memory breakdown + ======================================================= *) + + (* ╤ ╔══════════╗ ╤ │ ║ shadow ║ │ │ ╠══════════╣ │ @@ -111,96 +137,105 @@ let mib_of_pages_used value = divide_rounding_up value pages_per_mib *) [@@ocamlformat "wrap-comments=false"] -(* === Domain memory breakdown: HVM guests =========================================== *) +(* === Domain memory breakdown: HVM guests + =========================================== *) module type MEMORY_MODEL_DATA = sig val extra_internal_mib : int64 + val extra_external_mib : int64 + val shim_mib : int64 -> int64 + val can_start_ballooned_down : bool end module HVM_memory_model_data : MEMORY_MODEL_DATA = struct let extra_internal_mib = 1L + let extra_external_mib = 1L + let shim_mib _ = 0L + let can_start_ballooned_down = true end module Linux_memory_model_data : MEMORY_MODEL_DATA = struct let extra_internal_mib = 0L + let extra_external_mib = 1L + let shim_mib _ = 0L + let can_start_ballooned_down = true end module PVinPVH_memory_model_data : MEMORY_MODEL_DATA = struct let extra_internal_mib = 1L + let extra_external_mib = 1L + let shim_mib static_max_mib = 23L +++ (static_max_mib /// 90L) + let can_start_ballooned_down = true end type memory_config = { - build_max_mib : int64; - build_start_mib : int64; - xen_max_mib : int64; - shadow_mib : int64; - required_host_free_mib : int64; - overhead_mib : int64; + build_max_mib: int64 + ; build_start_mib: int64 + ; xen_max_mib: int64 + ; shadow_mib: int64 + ; required_host_free_mib: int64 + ; overhead_mib: int64 } module Memory_model (D : MEMORY_MODEL_DATA) = struct - let build_max_mib static_max_mib video_mib = - static_max_mib --- - (Int64.of_int video_mib) +++ - (D.shim_mib static_max_mib) + static_max_mib --- Int64.of_int video_mib +++ D.shim_mib static_max_mib let build_start_mib static_max_mib target_mib video_mib = if D.can_start_ballooned_down then - target_mib --- - (Int64.of_int video_mib) +++ - (D.shim_mib target_mib) + target_mib --- Int64.of_int video_mib +++ D.shim_mib target_mib else build_max_mib static_max_mib video_mib let xen_max_offset_mib = D.extra_internal_mib let xen_max_mib static_max_mib = - static_max_mib +++ - xen_max_offset_mib +++ - (D.shim_mib static_max_mib) + static_max_mib +++ xen_max_offset_mib +++ D.shim_mib static_max_mib let shadow_mib static_max_mib vcpu_count multiplier = - let vcpu_pages = 256L *** (Int64.of_int vcpu_count) in + let vcpu_pages = 256L *** Int64.of_int vcpu_count in let p2m_map_pages = static_max_mib in let shadow_resident_pages = static_max_mib in - let total_mib = mib_of_pages_used - (vcpu_pages +++ p2m_map_pages +++ shadow_resident_pages) in + let total_mib = + mib_of_pages_used (vcpu_pages +++ p2m_map_pages +++ shadow_resident_pages) + in let total_mib_multiplied = - Int64.of_float ((Int64.to_float total_mib) *. multiplier) in + Int64.of_float (Int64.to_float total_mib *. multiplier) + in max 1L total_mib_multiplied let overhead_mib static_max_mib vcpu_count multiplier = - D.extra_internal_mib +++ - D.extra_external_mib +++ - (shadow_mib static_max_mib vcpu_count multiplier) +++ - (D.shim_mib static_max_mib) + D.extra_internal_mib + +++ D.extra_external_mib + +++ shadow_mib static_max_mib vcpu_count multiplier + +++ D.shim_mib static_max_mib let footprint_mib target_mib static_max_mib vcpu_count multiplier = - target_mib +++ (overhead_mib static_max_mib vcpu_count multiplier) + target_mib +++ overhead_mib static_max_mib vcpu_count multiplier let shadow_multiplier_default = 1.0 let full_config static_max_mib video_mib target_mib vcpus shadow_multiplier = { - build_max_mib = build_max_mib static_max_mib video_mib; - build_start_mib = build_start_mib static_max_mib target_mib video_mib; - xen_max_mib = xen_max_mib static_max_mib; - shadow_mib = shadow_mib static_max_mib vcpus shadow_multiplier; - required_host_free_mib = footprint_mib target_mib static_max_mib vcpus shadow_multiplier; - overhead_mib = overhead_mib static_max_mib vcpus shadow_multiplier; + build_max_mib= build_max_mib static_max_mib video_mib + ; build_start_mib= build_start_mib static_max_mib target_mib video_mib + ; xen_max_mib= xen_max_mib static_max_mib + ; shadow_mib= shadow_mib static_max_mib vcpus shadow_multiplier + ; required_host_free_mib= + footprint_mib target_mib static_max_mib vcpus shadow_multiplier + ; overhead_mib= overhead_mib static_max_mib vcpus shadow_multiplier } end diff --git a/memory/memory_cli.ml b/memory/memory_cli.ml index 2d19dfc1..29f20dd4 100644 --- a/memory/memory_cli.ml +++ b/memory/memory_cli.ml @@ -2,24 +2,34 @@ open Memory_interface -module Cmds = API(Cmdlinergen.Gen ()) +module Cmds = API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the memory API. This allows scripting of the squeeze daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "memory_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the memory API. This allows scripting of the squeeze daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "memory_cli" ~version:(version_str Cmds.description) ~doc + ) let cli () = let rpc = Memory_client.rpc in - match Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) with - | `Ok f -> f () - | _ -> () + match + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) + with + | `Ok f -> + f () + | _ -> + () let _ = cli () diff --git a/memory/memory_client.ml b/memory/memory_client.ml index c19df5c5..c627ffa3 100644 --- a/memory/memory_client.ml +++ b/memory/memory_client.ml @@ -16,12 +16,15 @@ open Memory_interface open Xcp_client let json_url () = "file:" ^ json_path + let xml_url () = "file:" ^ xml_path let rpc call = - if !use_switch - then json_switch_rpc queue_name call - else xml_http_rpc ~srcstr:"xenops" ~dststr:"squeezed" xml_url call - -module Client = Memory_interface.API(Idl.Exn.GenClient(struct let rpc=rpc end)) + if !use_switch then + json_switch_rpc queue_name call + else + xml_http_rpc ~srcstr:"xenops" ~dststr:"squeezed" xml_url call +module Client = Memory_interface.API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) diff --git a/memory/memory_interface.ml b/memory/memory_interface.ml index e96908f8..512a73c6 100644 --- a/memory/memory_interface.ml +++ b/memory/memory_interface.ml @@ -11,228 +11,295 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Memory -*) + +(** * @group Memory *) open Rpc + open Idl -module D = Debug.Make(struct let name = "memory_interface" end) +module D = Debug.Make (struct let name = "memory_interface" end) + open D let service_name = "memory" + let queue_name = Xcp_service.common_prefix ^ service_name + let json_path = "/var/xapi/memory.json" + let xml_path = "/var/xapi/memory" (** The reservation_id is an opaque identifier associated with a block of - memory. It is used to reserve memory for a domain before the domain has - been created. *) -type reservation_id = string -[@@deriving rpcty] + memory. It is used to reserve memory for a domain before the domain has been + created. *) +type reservation_id = string [@@deriving rpcty] (** Domain zero can have a different policy to that used by guest domains. *) type domain_zero_policy = - | Fixed_size of int64 (** Never balloon, use the specified fixed size *) - | Auto_balloon of int64 * int64 (** Balloon between the two sizes specified *) + | Fixed_size of int64 (** Never balloon, use the specified fixed size *) + | Auto_balloon of int64 * int64 + (** Balloon between the two sizes specified *) [@@deriving rpcty] type errors = | Cannot_free_this_much_memory of (int64 * int64) - (** [Cannot_free_this_much_memory (required, free)] is reported if it is not - possible to free [required] kib. [free] is the amount of memory - currently free. *) - | Domains_refused_to_cooperate of (int list) - (** [Domains_refused_to_cooperate (domid list)] is reported if a set of - domains do not respond in a timely manner to the request to balloon. - The uncooperative domain ids are returned. *) - | Unknown_reservation of (reservation_id) - (** [Unknown_reservation (id)] is reported if a the specified - reservation_id is unknown. *) + (** [Cannot_free_this_much_memory (required, free)] is reported if it is + not possible to free [required] kib. [free] is the amount of memory + currently free. *) + | Domains_refused_to_cooperate of int list + (** [Domains_refused_to_cooperate (domid list)] is reported if a set of + domains do not respond in a timely manner to the request to balloon. + The uncooperative domain ids are returned. *) + | Unknown_reservation of reservation_id + (** [Unknown_reservation (id)] is reported if a the specified + reservation_id is unknown. *) | No_reservation - (** [No_reservation] is reported by [query_reservation_of_domain] if the - domain does not have a reservation. *) - | Invalid_memory_value of (int64) - (** [Invalid_memory_value (value)] is reported if a memory value passed is - not valid, e.g. negative. *) - | Internal_error of (string) - (** [Internal_error (value)] is reported if an unexpected error is - triggered by the library. *) - | Unknown_error - (** The default variant for forward compatibility. *) -[@@default Unknown_error] -[@@deriving rpcty] + (** [No_reservation] is reported by [query_reservation_of_domain] if the + domain does not have a reservation. *) + | Invalid_memory_value of int64 + (** [Invalid_memory_value (value)] is reported if a memory value passed is + not valid, e.g. negative. *) + | Internal_error of string + (** [Internal_error (value)] is reported if an unexpected error is + triggered by the library. *) + | Unknown_error (** The default variant for forward compatibility. *) +[@@default Unknown_error] [@@deriving rpcty] exception MemoryError of errors -let () = (* register printer for MemoryError *) +let () = + (* register printer for MemoryError *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | MemoryError e -> Some (sprintf "Memory_interface.Memory_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer -let err = Error. - { def = errors - ; raiser = (fun e -> - log_backtrace (); - let exn = MemoryError e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | MemoryError e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let err = + Error. + { + def= errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = MemoryError e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | MemoryError e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** An uninterpreted string associated with the operation. *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] -(** An identifier to associate requests with a client. This is - obtained by a call to [login]. *) -type session_id = string -[@@deriving rpcty] +(** An identifier to associate requests with a client. This is obtained by a + call to [login]. *) +type session_id = string [@@deriving rpcty] -type reserve_memory_range_result = reservation_id * int64 -[@@deriving rpcty] +type reserve_memory_range_result = reservation_id * int64 [@@deriving rpcty] -module API(R : RPC) = struct +module API (R : RPC) = struct open R - let description = Interface.{ - name = "Memory"; - namespace = None; - description = [ - "This interface is used by Xapi and Squeezed to manage the "; - "dynamic memory usage of VMs on a host."; - ]; - version=(1,0,0); - } + let description = + Interface. + { + name= "Memory" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and Squeezed to manage the " + ; "dynamic memory usage of VMs on a host." + ] + ; version= (1, 0, 0) + } let implementation = implement description (* General parameters, used by more than one API call *) - let debug_info_p = Param.mk ~description:[ - "An uninterpreted string to associate with the operation." - ] Types.string + let debug_info_p = + Param.mk + ~description:["An uninterpreted string to associate with the operation."] + Types.string - let diagnostics_result_p = Param.mk ~description:[ - "A string containing diagnostic information from the server." - ] Types.string + let diagnostics_result_p = + Param.mk + ~description: + ["A string containing diagnostic information from the server."] + Types.string - let service_name_p = Param.mk ~description:[ - "The name of the service attempting to interact with the squeeze daemon." - ] Types.string + let service_name_p = + Param.mk + ~description: + [ + "The name of the service attempting to interact with the squeeze \ + daemon." + ] + Types.string - let session_id_p = Param.mk ~description:[ - "An identifier to associate requests with a client. This is "; - "obtained by a call to [login]."] + let session_id_p = + Param.mk + ~description: + [ + "An identifier to associate requests with a client. This is " + ; "obtained by a call to [login]." + ] Types.string - let domid_p = Param.mk ~description:[ - "Domain id of a VM." - ] Types.int + let domid_p = Param.mk ~description:["Domain id of a VM."] Types.int - let reservation_id_p = Param.mk ~description:[ - "The reservation_id is the token used to identify a memory allocation." - ] reservation_id + let reservation_id_p = + Param.mk + ~description: + [ + "The reservation_id is the token used to identify a memory allocation." + ] + reservation_id - let size_p = Param.mk ~description:[ - "The size in bytes to reserve"] - Types.int64 + let size_p = + Param.mk ~description:["The size in bytes to reserve"] Types.int64 let unit_p = Param.mk Types.unit (* Individual API calls *) - let get_diagnostics = declare - "get_diagnostics" + let get_diagnostics = + declare "get_diagnostics" ["Gets diagnostic information from the server"] (debug_info_p @-> returning diagnostics_result_p err) - let login = declare - "login" - ["Logs into the squeeze daemon. Any reservations previously made with the "; - "specified service name not yet associated with a domain will be removed."] + let login = + declare "login" + [ + "Logs into the squeeze daemon. Any reservations previously made with \ + the " + ; "specified service name not yet associated with a domain will be \ + removed." + ] (debug_info_p @-> service_name_p @-> returning session_id_p err) - - let reserve_memory = declare - "reserve_memory" - ["[reserve_memory dbg session size] reserves memory for a domain. If necessary, "; - "other domains will be ballooned down to ensure [size] is available. The call "; - "returns a reservation_id that can later be transferred to a domain."] - (debug_info_p @-> session_id_p @-> size_p @-> returning reservation_id_p err) + let reserve_memory = + declare "reserve_memory" + [ + "[reserve_memory dbg session size] reserves memory for a domain. If \ + necessary, " + ; "other domains will be ballooned down to ensure [size] is available. \ + The call " + ; "returns a reservation_id that can later be transferred to a domain." + ] + (debug_info_p + @-> session_id_p + @-> size_p + @-> returning reservation_id_p err + ) let reserve_memory_range = - let result = Param.mk - ~description:[ - "A tuple containing the reservation_id and the amount of memory actually reserved." - ] + let result = + Param.mk + ~description: + [ + "A tuple containing the reservation_id and the amount of memory \ + actually reserved." + ] reserve_memory_range_result in - declare - "reserve_memory_range" - ["[reserve_memory_range dbg session min max] reserves memory for a domain. If necessary, "; - "other domains will be ballooned down to ensure enough memory is available. The amount "; - "of memory will be between [min] and [max] according to the policy in operation. The call "; - "returns a reservation_id and the actual memory amount that can later be transferred to a domain."] - (debug_info_p @-> session_id_p @-> size_p @-> size_p @-> returning result err) - + declare "reserve_memory_range" + [ + "[reserve_memory_range dbg session min max] reserves memory for a \ + domain. If necessary, " + ; "other domains will be ballooned down to ensure enough memory is \ + available. The amount " + ; "of memory will be between [min] and [max] according to the policy in \ + operation. The call " + ; "returns a reservation_id and the actual memory amount that can later \ + be transferred to a domain." + ] + (debug_info_p + @-> session_id_p + @-> size_p + @-> size_p + @-> returning result err + ) let delete_reservation = - declare - "delete_reservation" - ["Deletes a reservation. Note that memory rebalancing is not done synchronously after the "; - "operation has completed."] - (debug_info_p @-> session_id_p @-> reservation_id_p @-> returning unit_p err) + declare "delete_reservation" + [ + "Deletes a reservation. Note that memory rebalancing is not done \ + synchronously after the " + ; "operation has completed." + ] + (debug_info_p + @-> session_id_p + @-> reservation_id_p + @-> returning unit_p err + ) let transfer_reservation_to_domain = - declare - "transfer_reservation_to_domain" - ["Transfers a reservation to a domain. This is called when the domain has been created for "; - "the VM for which the reservation was initially made."] - (debug_info_p @-> session_id_p @-> reservation_id_p @-> domid_p @-> returning unit_p err) + declare "transfer_reservation_to_domain" + [ + "Transfers a reservation to a domain. This is called when the domain \ + has been created for " + ; "the VM for which the reservation was initially made." + ] + (debug_info_p + @-> session_id_p + @-> reservation_id_p + @-> domid_p + @-> returning unit_p err + ) let query_reservation_of_domain = - declare - "query_reservation_of_domain" + declare "query_reservation_of_domain" ["Queries the reservation_id associated with a domain"] - (debug_info_p @-> session_id_p @-> domid_p @-> returning reservation_id_p err) + (debug_info_p + @-> session_id_p + @-> domid_p + @-> returning reservation_id_p err + ) let balance_memory = - declare - "balance_memory" - ["Forces a rebalance of the hosts memory. Blocks until the system is in a stable "; - "state."] + declare "balance_memory" + [ + "Forces a rebalance of the hosts memory. Blocks until the system is in \ + a stable " + ; "state." + ] (debug_info_p @-> returning unit_p err) let get_host_reserved_memory = - declare - "get_host_reserved_memory" - ["Gets the amount of reserved memory in a host. This is the lower limit of memory that "; - "squeezed will ensure remains unused by any domain or reservation."] + declare "get_host_reserved_memory" + [ + "Gets the amount of reserved memory in a host. This is the lower limit \ + of memory that " + ; "squeezed will ensure remains unused by any domain or reservation." + ] (debug_info_p @-> returning size_p err) let get_host_initial_free_memory = - declare - "get_host_initial_free_memory" + declare "get_host_initial_free_memory" ["Gets the amount of initial free memory in a host"] (debug_info_p @-> returning size_p err) let get_domain_zero_policy = - let result_p = Param.mk ~description:["The policy associated with domain 0"] domain_zero_policy in - declare - "get_domain_zero_policy" + let result_p = + Param.mk + ~description:["The policy associated with domain 0"] + domain_zero_policy + in + declare "get_domain_zero_policy" ["Gets the ballooning policy for domain zero."] (debug_info_p @-> returning result_p err) - end diff --git a/misc/channel_helper.ml b/misc/channel_helper.ml index e1c2e05c..f4a3c84e 100644 --- a/misc/channel_helper.ml +++ b/misc/channel_helper.ml @@ -5,46 +5,47 @@ open Lwt let my_domid = 0 (* TODO: figure this out *) exception Short_write of int * int + exception End_of_file + exception No_useful_protocol let copy_all src dst = let buffer = Bytes.make 16384 '\000' in let rec loop () = Lwt_unix.read src buffer 0 (Bytes.length buffer) >>= fun n -> - if n = 0 - then Lwt.fail End_of_file + if n = 0 then + Lwt.fail End_of_file else Lwt_unix.write dst buffer 0 n >>= fun m -> - if n <> m then Lwt.fail (Short_write(m, n)) - else loop () - in loop () + if n <> m then Lwt.fail (Short_write (m, n)) else loop () + in + loop () let proxy a b = let copy _id src dst = - Lwt.catch (fun () -> copy_all src dst) - (fun _e -> - (try Lwt_unix.shutdown src Lwt_unix.SHUTDOWN_RECEIVE with _ -> ()); - (try Lwt_unix.shutdown dst Lwt_unix.SHUTDOWN_SEND with _ -> ()); - return ()) in - let ts = [ copy "ab" a b; copy "ba" b a ] in + Lwt.catch + (fun () -> copy_all src dst) + (fun _e -> + (try Lwt_unix.shutdown src Lwt_unix.SHUTDOWN_RECEIVE with _ -> ()) ; + (try Lwt_unix.shutdown dst Lwt_unix.SHUTDOWN_SEND with _ -> ()) ; + return ()) + in + let ts = [copy "ab" a b; copy "ba" b a] in Lwt.join ts -let file_descr_of_int (x: int) : Unix.file_descr = - Obj.magic x (* Keep this in sync with ocaml's file_descr type *) +let file_descr_of_int (x : int) : Unix.file_descr = Obj.magic x + +(* Keep this in sync with ocaml's file_descr type *) let ip = ref "127.0.0.1" + let unix = ref "/tmp" module Common = struct - type t = { - verbose: bool; - debug: bool; - port: int; - } [@@deriving rpc] + type t = {verbose: bool; debug: bool; port: int} [@@deriving rpc] - let make verbose debug port = - { verbose; debug; port } + let make verbose debug port = {verbose; debug; port} let to_string x = Jsonrpc.to_string (rpc_of_t x) end @@ -58,127 +59,165 @@ let common_options_t = let docs = _common_options in let debug = let doc = "Give only debug output." in - Arg.(value & flag & info ["debug"] ~docs ~doc) in + Arg.(value & flag & info ["debug"] ~docs ~doc) + in let verb = let doc = "Give verbose output." in - let verbose = true, Arg.info ["v"; "verbose"] ~docs ~doc in - Arg.(last & vflag_all [false] [verbose]) in + let verbose = (true, Arg.info ["v"; "verbose"] ~docs ~doc) in + Arg.(last & vflag_all [false] [verbose]) + in let port = let doc = Printf.sprintf "Specify port to connect to the message switch." in - Arg.(value & opt int 8080 & info ["port"] ~docs ~doc) in + Arg.(value & opt int 8080 & info ["port"] ~docs ~doc) + in Term.(pure Common.make $ debug $ verb $ port) (* Help sections common to all commands *) -let help = [ - `S _common_options; - `P "These options are common to all commands."; - `S "MORE HELP"; - `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; `Noblank; - `S "BUGS"; `P (Printf.sprintf "Check bug reports at %s" project_url); -] +let help = + [ + `S _common_options + ; `P "These options are common to all commands." + ; `S "MORE HELP" + ; `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command." + ; `Noblank + ; `S "BUGS" + ; `P (Printf.sprintf "Check bug reports at %s" project_url) + ] (* Commands *) let advertise_t _common_options_t proxy_socket = - let s_ip = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in (* INET socket, can't block *) - Lwt_unix.bind s_ip (Lwt_unix.ADDR_INET(Unix.inet_addr_of_string !ip, 0)) >>= fun () -> - Lwt_unix.listen s_ip 5; - let port = match Lwt_unix.getsockname s_ip with - | Unix.ADDR_INET(_, port) -> port - | _ -> assert false in - + Lwt_unix.bind s_ip (Lwt_unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) + >>= fun () -> + Lwt_unix.listen s_ip 5 ; + let port = + match Lwt_unix.getsockname s_ip with + | Unix.ADDR_INET (_, port) -> + port + | _ -> + assert false + in let s_unix = Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in - (* Try to avoid polluting the filesystem with unused unix domain sockets *) - let path = Printf.sprintf "%s/%s.%d" !unix - (Filename.basename Sys.argv.(0)) (Unix.getpid ()) in - if Sys.file_exists path then Unix.unlink path; + let path = + Printf.sprintf "%s/%s.%d" !unix + (Filename.basename Sys.argv.(0)) + (Unix.getpid ()) + in + if Sys.file_exists path then Unix.unlink path ; Lwt_unix.bind s_unix (Lwt_unix.ADDR_UNIX path) >>= fun () -> - List.iter (fun signal -> - ignore(Lwt_unix.on_signal signal (fun _ -> Unix.unlink path; exit 1)) - ) [ Sys.sigterm; Sys.sigint ]; - - Lwt_unix.listen s_unix 5; - + List.iter + (fun signal -> + ignore (Lwt_unix.on_signal signal (fun _ -> Unix.unlink path ; exit 1))) + [Sys.sigterm; Sys.sigint] ; + Lwt_unix.listen s_unix 5 ; let token = "token" in let protocols = let open Xcp_channel_protocol in - [ - TCP_proxy(!ip, port); - Unix_sendmsg(my_domid, path, token); - ] in - Printf.fprintf stdout "%s\n%!" (Jsonrpc.to_string (Xcp_channel.rpc_of_protocols protocols)); - + [TCP_proxy (!ip, port); Unix_sendmsg (my_domid, path, token)] + in + Printf.fprintf stdout "%s\n%!" + (Jsonrpc.to_string (Xcp_channel.rpc_of_protocols protocols)) ; let t_ip = Lwt_unix.accept s_ip >>= fun (fd, _peer) -> Lwt_unix.close s_ip >>= fun () -> - proxy fd (Lwt_unix.of_unix_file_descr proxy_socket) in + proxy fd (Lwt_unix.of_unix_file_descr proxy_socket) + in let t_unix = Lwt_unix.accept s_unix >>= fun (fd, _peer) -> let buffer = Bytes.make (String.length token) '\000' in - let io_vector = Lwt_unix.io_vector ~buffer:(Bytes.unsafe_to_string buffer) ~offset:0 ~length:(Bytes.length buffer) in + let io_vector = + Lwt_unix.io_vector + ~buffer:(Bytes.unsafe_to_string buffer) + ~offset:0 ~length:(Bytes.length buffer) + in Lwt_unix.recv_msg ~socket:fd ~io_vectors:[io_vector] >>= fun (n, fds) -> - List.iter Unix.close fds; + List.iter Unix.close fds ; let token' = Bytes.sub_string buffer 0 n in - let io_vector' = Lwt_unix.io_vector ~buffer:token' ~offset:0 ~length:(String.length token') in - if token = token' - then - Lwt_unix.send_msg ~socket:fd ~io_vectors:[io_vector'] ~fds:[proxy_socket] >>= fun _ -> return () - else return () in - Lwt.pick [ t_ip; t_unix ] >>= fun () -> - Unix.unlink path; - return () - -let advertise common_options_t fd = match fd with + let io_vector' = + Lwt_unix.io_vector ~buffer:token' ~offset:0 ~length:(String.length token') + in + if token = token' then + Lwt_unix.send_msg ~socket:fd ~io_vectors:[io_vector'] ~fds:[proxy_socket] + >>= fun _ -> return () + else + return () + in + Lwt.pick [t_ip; t_unix] >>= fun () -> Unix.unlink path ; return () + +let advertise common_options_t fd = + match fd with | Some x -> - Lwt_main.run (advertise_t common_options_t (file_descr_of_int x)); - `Ok () + Lwt_main.run (advertise_t common_options_t (file_descr_of_int x)) ; + `Ok () | None -> - `Error(true, "you must provide a file descriptor to proxy") + `Error (true, "you must provide a file descriptor to proxy") let advertise_cmd = let doc = "advertise a given channel represented as a file-descriptor" in - let man = [ - `S "DESCRIPTION"; - `P "Advertises a given channel over as many protocols as possible, and waits for someone to connect."; - ] @ help in + let man = + [ + `S "DESCRIPTION" + ; `P + "Advertises a given channel over as many protocols as possible, and \ + waits for someone to connect." + ] + @ help + in let fd = let doc = Printf.sprintf "File descriptor to advertise" in - Arg.(value & pos 0 (some int) None & info [] ~docv:"FD" ~doc) in - Term.(ret(pure advertise $ common_options_t $ fd)), - Term.info "advertise" ~sdocs:_common_options ~doc ~man + Arg.(value & pos 0 (some int) None & info [] ~docv:"FD" ~doc) + in + ( Term.(ret (pure advertise $ common_options_t $ fd)) + , Term.info "advertise" ~sdocs:_common_options ~doc ~man ) let connect_t _common_options_t = - Lwt_io.read_line_opt Lwt_io.stdin >>= (function | None -> return "" | Some x -> return x) >>= fun advertisement -> + (Lwt_io.read_line_opt Lwt_io.stdin >>= function + | None -> + return "" + | Some x -> + return x) + >>= fun advertisement -> let open Xcp_channel in - let fd = Lwt_unix.of_unix_file_descr (file_descr_of_t (t_of_rpc (Jsonrpc.of_string advertisement))) in + let fd = + Lwt_unix.of_unix_file_descr + (file_descr_of_t (t_of_rpc (Jsonrpc.of_string advertisement))) + in let a = copy_all Lwt_unix.stdin fd in let b = copy_all fd Lwt_unix.stdout in Lwt.join [a; b] let connect common_options_t = - Lwt_main.run(connect_t common_options_t); + Lwt_main.run (connect_t common_options_t) ; `Ok () let connect_cmd = let doc = "connect to a channel and proxy to the terminal" in - let man = [ - `S "DESCRIPTION"; - `P "Connect to a channel which has been advertised and proxy I/O to the console. The advertisement will be read from stdin as a single line of text."; - ] @ help in - Term.(ret(pure connect $ common_options_t)), - Term.info "connect" ~sdocs:_common_options ~doc ~man + let man = + [ + `S "DESCRIPTION" + ; `P + "Connect to a channel which has been advertised and proxy I/O to the \ + console. The advertisement will be read from stdin as a single line \ + of text." + ] + @ help + in + ( Term.(ret (pure connect $ common_options_t)) + , Term.info "connect" ~sdocs:_common_options ~doc ~man ) let default_cmd = let doc = "channel (file-descriptor) passing helper program" in let man = help in - Term.(ret (pure (fun _ -> `Help (`Pager, None)) $ common_options_t)), - Term.info "proxy" ~version:"1.0.0" ~sdocs:_common_options ~doc ~man + ( Term.(ret (pure (fun _ -> `Help (`Pager, None)) $ common_options_t)) + , Term.info "proxy" ~version:"1.0.0" ~sdocs:_common_options ~doc ~man ) let cmds = [advertise_cmd; connect_cmd] let _ = match Term.eval_choice default_cmd cmds with - | `Error _ -> exit 1 - | _ -> exit 0 + | `Error _ -> + exit 1 + | _ -> + exit 0 diff --git a/network/network_cli.ml b/network/network_cli.ml index 385ede93..2cc0e9f1 100644 --- a/network/network_cli.ml +++ b/network/network_cli.ml @@ -2,25 +2,30 @@ open Network_interface -module Cmds = Interface_API(Cmdlinergen.Gen ()) +module Cmds = Interface_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the network API. This allows scripting of the xcp-networkd daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "network_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the network API. This allows scripting of the xcp-networkd \ + daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "network_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = let rpc = Network_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) -let _ = - match cli () with - | `Ok f -> f () - | _ -> () +let _ = match cli () with `Ok f -> f () | _ -> () diff --git a/network/network_client.ml b/network/network_client.ml index 2c2ae140..9161ca11 100644 --- a/network/network_client.ml +++ b/network/network_client.ml @@ -15,26 +15,23 @@ let retry_econnrefused f = let rec loop () = let result = - try - Some (f ()) - with Unix.Unix_error((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> - Thread.delay 1.; - None in - match result with - | Some x -> x - | None -> loop () in + try Some (f ()) + with Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> + Thread.delay 1. ; None + in + match result with Some x -> x | None -> loop () + in loop () let rpc call = - retry_econnrefused - (fun () -> - if !Xcp_client.use_switch - then Xcp_client.json_switch_rpc !Network_interface.queue_name call - else Xcp_client.xml_http_rpc - ~srcstr:(Xcp_client.get_user_agent ()) - ~dststr:"network" - Network_interface.uri - call - ) + retry_econnrefused (fun () -> + if !Xcp_client.use_switch then + Xcp_client.json_switch_rpc !Network_interface.queue_name call + else + Xcp_client.xml_http_rpc + ~srcstr:(Xcp_client.get_user_agent ()) + ~dststr:"network" Network_interface.uri call) -module Client = Network_interface.Interface_API(Idl.Exn.GenClient(struct let rpc=rpc end)) +module Client = Network_interface.Interface_API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) diff --git a/network/network_interface.ml b/network/network_interface.ml index 92c91bb6..956496e5 100644 --- a/network/network_interface.ml +++ b/network/network_interface.ml @@ -14,41 +14,34 @@ open Rpc open Idl -module D = Debug.Make(struct let name = "network_interface" end) +module D = Debug.Make (struct let name = "network_interface" end) + open D (** {2 Helper functions} *) let service_name = "networkd" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) let default_sockets_dir = "/var/lib/xcp" + let default_path = ref (Filename.concat default_sockets_dir service_name) let uri () = "file:" ^ !default_path let comp f g x = f (g x) -let (++) f g x = comp f g x + +let ( ++ ) f g x = comp f g x let netmask_to_prefixlen netmask = Scanf.sscanf netmask "%d.%d.%d.%d" (fun a b c d -> - let rec length l x = - if x > 0 then - length (succ l) (x lsr 1) - else - l - in - let masks = List.map ((-) 255) [a; b; c; d] in - 32 - (List.fold_left length 0 masks) - ) + let rec length l x = if x > 0 then length (succ l) (x lsr 1) else l in + let masks = List.map (( - ) 255) [a; b; c; d] in + 32 - List.fold_left length 0 masks) let prefixlen_to_netmask len = let mask l = - if l <= 0 then - 0 - else if l > 8 then - 255 - else - 256 - (1 lsl (8 - l)) + if l <= 0 then 0 else if l > 8 then 255 else 256 - (1 lsl (8 - l)) in let lens = [len; len - 8; len - 16; len - 24] in let masks = List.map (string_of_int ++ mask) lens in @@ -56,294 +49,339 @@ let prefixlen_to_netmask len = module Unix = struct include Unix - let typ_of_inet_addr = Rpc.Types.Abstract ({ - aname = "inet_addr"; - test_data = [Unix.inet_addr_of_string "127.0.0.1"]; - rpc_of = (fun t -> Rpc.String (Unix.string_of_inet_addr t)); - of_rpc = (function - | Rpc.String s -> Ok (Unix.inet_addr_of_string s) - | r -> Error (`Msg (Printf.sprintf "typ_of_inet_addr: expectd rpc string but got %s" (Rpc.to_string r)))); - }) + + let typ_of_inet_addr = + Rpc.Types.Abstract + { + aname= "inet_addr" + ; test_data= [Unix.inet_addr_of_string "127.0.0.1"] + ; rpc_of= (fun t -> Rpc.String (Unix.string_of_inet_addr t)) + ; of_rpc= + (function + | Rpc.String s -> + Ok (Unix.inet_addr_of_string s) + | r -> + Error + (`Msg + (Printf.sprintf + "typ_of_inet_addr: expectd rpc string but got %s" + (Rpc.to_string r)))) + } end (** {2 Types} *) type debug_info = string [@@deriving rpcty] + type iface = string [@@deriving rpcty] + type port = string [@@deriving rpcty] + type bridge = string [@@deriving rpcty] + (* rpcty cannot handle polymorphic variant, so change the definition to variant *) type dhcp_options = Set_gateway | Set_dns [@@deriving rpcty] -type ipv4 = None4 | DHCP4 | Static4 of (Unix.inet_addr * int) list [@@deriving rpcty] -type ipv6 = None6 | Linklocal6 | DHCP6 | Autoconf6 | Static6 of (Unix.inet_addr * int) list [@@deriving rpcty] - -type duplex = - | Duplex_unknown - | Duplex_half - | Duplex_full -[@@default Duplex_unknown] + +type ipv4 = None4 | DHCP4 | Static4 of (Unix.inet_addr * int) list [@@deriving rpcty] +type ipv6 = + | None6 + | Linklocal6 + | DHCP6 + | Autoconf6 + | Static6 of (Unix.inet_addr * int) list +[@@deriving rpcty] + +type duplex = Duplex_unknown | Duplex_half | Duplex_full +[@@default Duplex_unknown] [@@deriving rpcty] + let string_of_duplex = function - | Duplex_unknown -> "unknown" - | Duplex_half -> "half" - | Duplex_full -> "full" + | Duplex_unknown -> + "unknown" + | Duplex_half -> + "half" + | Duplex_full -> + "full" let duplex_of_string = function - | "full" -> Duplex_full - | "half" -> Duplex_half - | _ -> Duplex_unknown + | "full" -> + Duplex_full + | "half" -> + Duplex_half + | _ -> + Duplex_unknown (* `Basic` is conflict with Rpc.Basic so rename it to `Basic_port`*) -type port_kind = - | Basic_port - | PVS_proxy -[@@deriving rpcty] +type port_kind = Basic_port | PVS_proxy [@@deriving rpcty] let string_of_port_kind = function - | Basic_port -> "basic" - | PVS_proxy -> "PVS proxy" + | Basic_port -> + "basic" + | PVS_proxy -> + "PVS proxy" type ipv4_route_t = { - subnet : Unix.inet_addr; - netmask : int; - gateway : Unix.inet_addr; -} [@@deriving rpcty] + subnet: Unix.inet_addr + ; netmask: int + ; gateway: Unix.inet_addr +} +[@@deriving rpcty] type kind = Openvswitch | Bridge [@@deriving rpcty] let string_of_kind = function - | Openvswitch -> "openvswitch" - | Bridge -> "bridge" + | Openvswitch -> + "openvswitch" + | Bridge -> + "bridge" type bond_mode = Balance_slb | Active_backup | Lacp [@@deriving rpcty] + type fail_mode = Standalone | Secure [@@deriving rpcty] type interface_config_t = { - ipv4_conf: ipv4 [@default None4]; - ipv4_gateway: Unix.inet_addr option [@default None]; - ipv6_conf: ipv6 [@default None6]; - ipv6_gateway: Unix.inet_addr option [@default None]; - ipv4_routes: ipv4_route_t list [@default []]; - dns: Unix.inet_addr list * string list [@default [], []]; - mtu: int [@default 1500]; - ethtool_settings: (string * string) list [@default []]; - ethtool_offload: (string * string) list [@default ["lro", "off"]]; - persistent_i: bool [@default false]; -} [@@deriving rpcty] + ipv4_conf: ipv4 [@default None4] + ; ipv4_gateway: Unix.inet_addr option [@default None] + ; ipv6_conf: ipv6 [@default None6] + ; ipv6_gateway: Unix.inet_addr option [@default None] + ; ipv4_routes: ipv4_route_t list [@default []] + ; dns: Unix.inet_addr list * string list [@default [], []] + ; mtu: int [@default 1500] + ; ethtool_settings: (string * string) list [@default []] + ; ethtool_offload: (string * string) list [@default [("lro", "off")]] + ; persistent_i: bool [@default false] +} +[@@deriving rpcty] type port_config_t = { - interfaces: iface list [@default []]; - bond_properties: (string * string) list [@default []]; - bond_mac: string option [@default None]; - kind: port_kind [@default Basic_port]; -} [@@deriving rpcty] - -type bridge_config_t = { - ports: (port * port_config_t) list [@default []]; - vlan: (bridge * int) option [@default None]; - bridge_mac: string option [@default None]; - igmp_snooping: bool option [@default None]; - other_config: (string * string) list [@default []]; - persistent_b: bool [@default false]; -} [@@deriving rpcty] - -type config_t = { - interface_config: (iface * interface_config_t) list [@default []]; - bridge_config: (bridge * bridge_config_t) list [@default []]; - gateway_interface: iface option [@default None]; - dns_interface: iface option [@default None]; -} [@@deriving rpcty] - -(** {2 Default configuration} *) -let default_interface = { - ipv4_conf = None4; - ipv4_gateway = None; - ipv6_conf = None6; - ipv6_gateway = None; - ipv4_routes = []; - dns = [], []; - mtu = 1500; - ethtool_settings = []; - ethtool_offload = ["lro", "off"]; - persistent_i = false; + interfaces: iface list [@default []] + ; bond_properties: (string * string) list [@default []] + ; bond_mac: string option [@default None] + ; kind: port_kind [@default Basic_port] } +[@@deriving rpcty] -let default_bridge = { - ports = []; - vlan = None; - bridge_mac = None; - igmp_snooping = None; - other_config = []; - persistent_b = false; +type bridge_config_t = { + ports: (port * port_config_t) list [@default []] + ; vlan: (bridge * int) option [@default None] + ; bridge_mac: string option [@default None] + ; igmp_snooping: bool option [@default None] + ; other_config: (string * string) list [@default []] + ; persistent_b: bool [@default false] } +[@@deriving rpcty] -let default_port = { - interfaces = []; - bond_properties = []; - bond_mac = None; - kind = Basic_port; +type config_t = { + interface_config: (iface * interface_config_t) list [@default []] + ; bridge_config: (bridge * bridge_config_t) list [@default []] + ; gateway_interface: iface option [@default None] + ; dns_interface: iface option [@default None] } +[@@deriving rpcty] -let default_config = { - interface_config = []; - bridge_config = []; - gateway_interface = None; - dns_interface = None -} +(** {2 Default configuration} *) +let default_interface = + { + ipv4_conf= None4 + ; ipv4_gateway= None + ; ipv6_conf= None6 + ; ipv6_gateway= None + ; ipv4_routes= [] + ; dns= ([], []) + ; mtu= 1500 + ; ethtool_settings= [] + ; ethtool_offload= [("lro", "off")] + ; persistent_i= false + } + +let default_bridge = + { + ports= [] + ; vlan= None + ; bridge_mac= None + ; igmp_snooping= None + ; other_config= [] + ; persistent_b= false + } + +let default_port = + {interfaces= []; bond_properties= []; bond_mac= None; kind= Basic_port} + +let default_config = + { + interface_config= [] + ; bridge_config= [] + ; gateway_interface= None + ; dns_interface= None + } (** {2 Configuration manipulation} *) let get_config config default name = - try - List.assoc name config - with _ -> default + try List.assoc name config with _ -> default -let remove_config config name = - List.remove_assoc name config +let remove_config config name = List.remove_assoc name config let update_config config name data = let replace_assoc key new_value existing = - (key, new_value) :: (List.filter (fun (k, _) -> k <> key) existing) in - - if List.mem_assoc name config then begin + (key, new_value) :: List.filter (fun (k, _) -> k <> key) existing + in + if List.mem_assoc name config then replace_assoc name data config - end else + else (name, data) :: config (** {2 Exceptions} *) type errors = - | Script_missing of string (** [Script_missing (script)] is reported if unable to find [script] *) - | Script_error of (string * string) list (** [Script_error ([(key * value); ...])] is reported when error occurs when executing script, the [key] and [value] indicates the information about the script and the error *) - | Read_error of string (** [Read_error (file)] is reported when error occurs when reading [file] *) - | Write_error of string (** [Write_error (file)] is reported when error occurs when writing [file] *) - | Not_implemented (** [Not_implemented] is reported if the interface is not implemented *) - | Vlan_in_use of (string * int) (** [Vlan_in_use (bridge, vlan_id)] is reported when [vlan_id] on [bridge] is inuse *) - | PVS_proxy_connection_error (** [PVS_proxy_connection_error] is reported when unable to connect PVS proxy *) - | Interface_does_not_exist of string (** The named network interface does not exist *) - | Bridge_does_not_exist of string (** The named bridge does not exist *) + | Script_missing of string + (** [Script_missing (script)] is reported if unable to find [script] *) + | Script_error of (string * string) list + (** [Script_error ([(key * value); ...])] is reported when error occurs + when executing script, the [key] and [value] indicates the information + about the script and the error *) + | Read_error of string + (** [Read_error (file)] is reported when error occurs when reading [file] *) + | Write_error of string + (** [Write_error (file)] is reported when error occurs when writing [file] *) + | Not_implemented + (** [Not_implemented] is reported if the interface is not implemented *) + | Vlan_in_use of (string * int) + (** [Vlan_in_use (bridge, vlan_id)] is reported when [vlan_id] on [bridge] + is inuse *) + | PVS_proxy_connection_error + (** [PVS_proxy_connection_error] is reported when unable to connect PVS + proxy *) + | Interface_does_not_exist of string + (** The named network interface does not exist *) + | Bridge_does_not_exist of string (** The named bridge does not exist *) | Internal_error of string - | Unknown_error (** The default variant for forward compatibility. *) -[@@default Unknown_error] -[@@deriving rpcty] + | Unknown_error (** The default variant for forward compatibility. *) +[@@default Unknown_error] [@@deriving rpcty] exception Network_error of errors -let () = (* register printer *) +let () = + (* register printer *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | Network_error e -> Some (sprintf "Network_interface.Network_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer -let err = Error. - { def = errors - ; raiser = (fun e -> - log_backtrace (); - let exn = Network_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | Network_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let err = + Error. + { + def= errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = Network_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | Network_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** {2 API functions} *) -module Interface_API(R : RPC) = struct +module Interface_API (R : RPC) = struct open R (* Define this module here because we will reuse the name `Interface` *) module Idl_Interface = Interface - let description = Idl_Interface.{ - name = "Network"; - namespace = Some "Network"; - description = [ - "This interface is used by Xapi and networkd to manage "; - "Xenserver network bridges and devices ."; - ]; - version=(1,0,0); - } + let description = + Idl_Interface. + { + name= "Network" + ; namespace= Some "Network" + ; description= + [ + "This interface is used by Xapi and networkd to manage " + ; "Xenserver network bridges and devices ." + ] + ; version= (1, 0, 0) + } let implementation = implement description - let debug_info_p = Param.mk ~description:[ - "an uninterpreted string to associate with the operation." - ] Types.string + let debug_info_p = + Param.mk + ~description:["an uninterpreted string to associate with the operation."] + Types.string let unit_p = Param.mk Types.unit - let clear_state = declare - "clear_state" + let clear_state = + declare "clear_state" ["Clear configuration state"] (unit_p @-> returning unit_p err) - let reset_state = declare - "reset_state" + let reset_state = + declare "reset_state" ["Reset configuration state"] (unit_p @-> returning unit_p err) let set_gateway_interface = let name_p = Param.mk ~name:"name" ~description:["gateway name"] iface in - declare - "set_gateway_interface" - ["Set gateway interface"] + declare "set_gateway_interface" ["Set gateway interface"] (debug_info_p @-> name_p @-> returning unit_p err) let set_dns_interface = let name_p = Param.mk ~name:"name" ~description:["gateway name"] iface in - declare - "set_dns_interface" - ["Set dns interface"] + declare "set_dns_interface" ["Set dns interface"] (debug_info_p @-> name_p @-> returning unit_p err) module Interface = struct - let iface_name_p = Param.mk ~name:"name" ~description:["interface name"] iface + let iface_name_p = + Param.mk ~name:"name" ~description:["interface name"] iface let get_all = let module T = struct type _iface_list_t = iface list [@@deriving rpcty] end in - let iface_list_p = Param.mk ~description:["interface list"] T._iface_list_t in - declare - "Interface.get_all" + let iface_list_p = + Param.mk ~description:["interface list"] T._iface_list_t + in + declare "Interface.get_all" ["Get list of all interface names"] (debug_info_p @-> unit_p @-> returning iface_list_p err) let exists = let result = Param.mk ~description:["existence"] Types.bool in - declare - "Interface.exists" + declare "Interface.exists" ["Check interface existence"] (debug_info_p @-> iface_name_p @-> returning result err) let get_pci_bus_path = let result = Param.mk ~description:["PCI bus path"] Types.string in - declare - "Interface.get_pci_bus_path" + declare "Interface.get_pci_bus_path" ["Get PCI bus path of the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let get_mac = let result = Param.mk ~description:["MAC address"] Types.string in - declare - "Interface.get_mac" + declare "Interface.get_mac" ["Get Mac address of the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let is_up = let result = Param.mk ~description:["interface is up"] Types.bool in - declare - "Interface.is_up" + declare "Interface.is_up" ["Check whether the interface is up"] (debug_info_p @-> iface_name_p @-> returning result err) @@ -351,54 +389,55 @@ module Interface_API(R : RPC) = struct let module T = struct type _ip_addr_list_t = (Unix.inet_addr * int) list [@@deriving rpcty] end in - let result = Param.mk ~description:["list of interface IPv4 addresses"] T._ip_addr_list_t in - declare - "Interface.get_ipv4_addr" + let result = + Param.mk + ~description:["list of interface IPv4 addresses"] + T._ip_addr_list_t + in + declare "Interface.get_ipv4_addr" ["Get list of IPv4 addresses of the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let set_ipv4_conf = let conf_p = Param.mk ~description:["IPv4 configuration type"] ipv4 in - declare - "Interface.set_ipv4_conf" - ["Set IPv4 configuration"] + declare "Interface.set_ipv4_conf" ["Set IPv4 configuration"] (debug_info_p @-> iface_name_p @-> conf_p @-> returning unit_p err) let get_ipv4_gateway = let module T = struct type _inet_addr_opt_t = Unix.inet_addr option [@@deriving rpcty] end in - let result = Param.mk ~description:["gateway address if exists"] T._inet_addr_opt_t in - declare - "Interface.get_ipv4_gateway" - ["Get IPv4 gateway"] + let result = + Param.mk ~description:["gateway address if exists"] T._inet_addr_opt_t + in + declare "Interface.get_ipv4_gateway" ["Get IPv4 gateway"] (debug_info_p @-> iface_name_p @-> returning result err) let get_ipv6_addr = let module T = struct type _ip_addr_list_t = (Unix.inet_addr * int) list [@@deriving rpcty] end in - let result = Param.mk ~description:["list of interface IPv6 addresses"] T._ip_addr_list_t in - declare - "Interface.get_ipv6_addr" - ["Get IPv6 address"] + let result = + Param.mk + ~description:["list of interface IPv6 addresses"] + T._ip_addr_list_t + in + declare "Interface.get_ipv6_addr" ["Get IPv6 address"] (debug_info_p @-> iface_name_p @-> returning result err) let get_dns = let module T = struct type _dns_info_t = Unix.inet_addr list * string list [@@deriving rpcty] end in - let result = Param.mk ~description:["DNS servers information"] T._dns_info_t in - declare - "Interface.get_dns" - ["Get DNS"] + let result = + Param.mk ~description:["DNS servers information"] T._dns_info_t + in + declare "Interface.get_dns" ["Get DNS"] (debug_info_p @-> iface_name_p @-> returning result err) let get_mtu = let result = Param.mk ~description:["MTU"] Types.int in - declare - "Interface.get_mtu" - ["Get MTU"] + declare "Interface.get_mtu" ["Get MTU"] (debug_info_p @-> iface_name_p @-> returning result err) let get_capabilities = @@ -406,55 +445,64 @@ module Interface_API(R : RPC) = struct type _capabilities_t = string list [@@deriving rpcty] end in let result = Param.mk ~description:["capabilities"] T._capabilities_t in - declare - "Interface.get_capabilities" + declare "Interface.get_capabilities" ["Get capabilities on the interface"] (debug_info_p @-> iface_name_p @-> returning result err) let is_connected = - let result = Param.mk ~description:["whether interface is connected"] Types.bool in - declare - "Interface.is_connected" + let result = + Param.mk ~description:["whether interface is connected"] Types.bool + in + declare "Interface.is_connected" ["Check whether interface is connected"] (debug_info_p @-> iface_name_p @-> returning result err) let is_physical = - let result = Param.mk ~description:["whether interface is physical"] Types.bool in - declare - "Interface.is_physical" + let result = + Param.mk ~description:["whether interface is physical"] Types.bool + in + declare "Interface.is_physical" ["Check whether interface is physical"] (debug_info_p @-> iface_name_p @-> returning result err) let has_vlan = let vlan_p = Param.mk ~name:"vlan" ~description:["vlan id"] Types.int in - let result = Param.mk ~description:["whether interface has vlan"] Types.bool in - declare - "Interface.has_vlan" + let result = + Param.mk ~description:["whether interface has vlan"] Types.bool + in + declare "Interface.has_vlan" ["Check whether interface has vlan"] (debug_info_p @-> iface_name_p @-> vlan_p @-> returning result err) let bring_down = - declare - "Interface.bring_down" - ["Bring PIF down"] + declare "Interface.bring_down" ["Bring PIF down"] (debug_info_p @-> iface_name_p @-> returning unit_p err) let set_persistent = - let value_p = Param.mk ~name:"value" ~description:["persistent or not"] Types.bool in - declare - "Interface.set_persistent" + let value_p = + Param.mk ~name:"value" ~description:["persistent or not"] Types.bool + in + declare "Interface.set_persistent" ["Make PIF to persistent or not"] (debug_info_p @-> iface_name_p @-> value_p @-> returning unit_p err) let make_config = let module T = struct type _conservative_t = bool [@@deriving rpcty] - type _iface_config_list_t = (iface * interface_config_t) list [@@deriving rpcty] + + type _iface_config_list_t = (iface * interface_config_t) list + [@@deriving rpcty] end in - let conservative_p = Param.mk ~name:"conservative" ~description:["conservative"] T._conservative_t in - let config_p = Param.mk ~name:"config" ~description:["list of interface configuration"] T._iface_config_list_t in - declare - "Interface.make_config" + let conservative_p = + Param.mk ~name:"conservative" ~description:["conservative"] + T._conservative_t + in + let config_p = + Param.mk ~name:"config" + ~description:["list of interface configuration"] + T._iface_config_list_t + in + declare "Interface.make_config" ["Make interface configuration"] (debug_info_p @-> conservative_p @-> config_p @-> returning unit_p err) end @@ -465,102 +513,133 @@ module Interface_API(R : RPC) = struct type _bridge_list_t = bridge list [@@deriving rpcty] end in let result = Param.mk ~description:["bridge list"] T._bridge_list_t in - declare - "Bridge.get_all" - ["Get all bridges"] + declare "Bridge.get_all" ["Get all bridges"] (debug_info_p @-> unit_p @-> returning result err) let create = let module T = struct type _vlan_opt_t = (bridge * int) option [@@deriving rpcty] + type _mac_opt_t = string option [@@deriving rpcty] + type _igmp_snooping_opt_t = bool option [@@deriving rpcty] - type _other_config_opt_t = (string * string) list option [@@deriving rpcty] + + type _other_config_opt_t = (string * string) list option + [@@deriving rpcty] end in let vlan_p = Param.mk ~name:"vlan" ~description:["vlan"] T._vlan_opt_t in let mac_p = Param.mk ~name:"mac" ~description:["MAC"] T._mac_opt_t in - let igmp_snooping_p = Param.mk ~name:"igmp_snooping" T._igmp_snooping_opt_t in - let other_config_p = Param.mk ~name:"other_config" T._other_config_opt_t in + let igmp_snooping_p = + Param.mk ~name:"igmp_snooping" T._igmp_snooping_opt_t + in + let other_config_p = + Param.mk ~name:"other_config" T._other_config_opt_t + in let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in - declare - "Bridge.create" - ["Create bridge"] - (debug_info_p @-> vlan_p @-> mac_p @-> igmp_snooping_p @-> other_config_p @-> name_p @-> returning unit_p err) + declare "Bridge.create" ["Create bridge"] + (debug_info_p + @-> vlan_p + @-> mac_p + @-> igmp_snooping_p + @-> other_config_p + @-> name_p + @-> returning unit_p err + ) let destroy = - let module T = struct - type _force_t = bool [@@deriving rpcty] - end in + let module T = struct type _force_t = bool [@@deriving rpcty] end in let force_p = Param.mk ~name:"force" ~description:["force"] T._force_t in let name_p = Param.mk ~name:"name" ~description:["name"] bridge in - declare - "Bridge.destroy" - ["Destroy bridge"] + declare "Bridge.destroy" ["Destroy bridge"] (debug_info_p @-> force_p @-> name_p @-> returning unit_p err) let get_kind = let result = Param.mk ~description:["backend kind"] kind in - declare - "Bridge.get_kind" - ["Get backend kind"] + declare "Bridge.get_kind" ["Get backend kind"] (debug_info_p @-> unit_p @-> returning result err) let get_all_ports = let module T = struct type _from_cache_t = bool [@@deriving rpcty] + type _all_ports_t = (port * iface list) list [@@deriving rpcty] end in - let from_cache_p = Param.mk ~name:"from_cache" ~description:["whether from cache"] T._from_cache_t in + let from_cache_p = + Param.mk ~name:"from_cache" ~description:["whether from cache"] + T._from_cache_t + in let result = Param.mk ~description:["all ports"] T._all_ports_t in - declare - "Bridge.get_all_ports" - ["Get all ports"] + declare "Bridge.get_all_ports" ["Get all ports"] (debug_info_p @-> from_cache_p @-> returning result err) let get_all_bonds = let module T = struct type _from_cache_t = bool [@@deriving rpcty] + type _all_bonds_t = (port * iface list) list [@@deriving rpcty] end in - let from_cache_p = Param.mk ~name:"from_cache" ~description:["whether from cache"] T._from_cache_t in + let from_cache_p = + Param.mk ~name:"from_cache" ~description:["whether from cache"] + T._from_cache_t + in let result = Param.mk ~description:["all bonds"] T._all_bonds_t in - declare - "Bridge.get_all_bonds" - ["get all bonds"] + declare "Bridge.get_all_bonds" ["get all bonds"] (debug_info_p @-> from_cache_p @-> returning result err) let set_persistent = let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in - let value_p = Param.mk ~name:"value" ~description:["persistent value"] Types.bool in - declare - "Bridge.set_persistent" + let value_p = + Param.mk ~name:"value" ~description:["persistent value"] Types.bool + in + declare "Bridge.set_persistent" ["Make bridge to persistent or not"] (debug_info_p @-> name_p @-> value_p @-> returning unit_p err) let add_port = let module T = struct type _bond_mac_opt_t = string option [@@deriving rpcty] + type _interfaces_t = iface list [@@deriving rpcty] - type _bond_properties_opt_t = (string * string) list option [@@deriving rpcty] + + type _bond_properties_opt_t = (string * string) list option + [@@deriving rpcty] + type _kind_opt_t = port_kind option [@@deriving rpcty] end in - let bond_mac_p = Param.mk ~name:"bond_mac" ~description:["bond MAC"] T._bond_mac_opt_t in - let bridge_p = Param.mk ~name:"bridge" ~description:["bridge name"] bridge in + let bond_mac_p = + Param.mk ~name:"bond_mac" ~description:["bond MAC"] T._bond_mac_opt_t + in + let bridge_p = + Param.mk ~name:"bridge" ~description:["bridge name"] bridge + in let name_p = Param.mk ~name:"name" ~description:["port name"] port in - let interfaces_p = Param.mk ~name:"interfaces" ~description:["interfaces"] T._interfaces_t in - let bond_properties_p = Param.mk ~name:"bond_properties" ~description:["bond properties"] T._bond_properties_opt_t in - let kind_p = Param.mk ~name:"kind" ~description:["port kind"] T._kind_opt_t in - declare - "Bridge.add_port" - ["Add port"] - (debug_info_p @-> bond_mac_p @-> bridge_p @-> name_p @-> interfaces_p @-> bond_properties_p @-> kind_p @-> returning unit_p err) + let interfaces_p = + Param.mk ~name:"interfaces" ~description:["interfaces"] T._interfaces_t + in + let bond_properties_p = + Param.mk ~name:"bond_properties" ~description:["bond properties"] + T._bond_properties_opt_t + in + let kind_p = + Param.mk ~name:"kind" ~description:["port kind"] T._kind_opt_t + in + declare "Bridge.add_port" ["Add port"] + (debug_info_p + @-> bond_mac_p + @-> bridge_p + @-> name_p + @-> interfaces_p + @-> bond_properties_p + @-> kind_p + @-> returning unit_p err + ) let remove_port = - let bridge_p = Param.mk ~name:"bridge" ~description:["bridge name"] bridge in + let bridge_p = + Param.mk ~name:"bridge" ~description:["bridge name"] bridge + in let name_p = Param.mk ~name:"name" ~description:["port name"] port in - declare - "Bridge.remove_port" - ["Remove port"] + declare "Bridge.remove_port" ["Remove port"] (debug_info_p @-> bridge_p @-> name_p @-> returning unit_p err) let get_interfaces = @@ -569,9 +648,7 @@ module Interface_API(R : RPC) = struct end in let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in let result = Param.mk ~description:["interface list"] T._iface_list_t in - declare - "Bridge.get_interfaces" - ["Get interfaces"] + declare "Bridge.get_interfaces" ["Get interfaces"] (debug_info_p @-> name_p @-> returning result err) let get_physical_interfaces = @@ -580,20 +657,19 @@ module Interface_API(R : RPC) = struct end in let name_p = Param.mk ~name:"name" ~description:["bridge name"] bridge in let result = Param.mk ~description:["interface list"] T._iface_list_t in - declare - "Bridge.get_physical_interfaces" + declare "Bridge.get_physical_interfaces" ["Get physical interfaces"] (debug_info_p @-> name_p @-> returning result err) let make_config = let module T = struct type _conservative_t = bool [@@deriving rpcty] + type _config_t = (bridge * bridge_config_t) list [@@deriving rpcty] end in let conservative_p = Param.mk ~name:"conservative" T._conservative_t in let config_p = Param.mk ~name:"config" T._config_t in - declare - "Bridge.make_config" + declare "Bridge.make_config" ["Make bridge configuration"] (debug_info_p @-> conservative_p @-> config_p @-> returning unit_p err) end @@ -601,51 +677,46 @@ module Interface_API(R : RPC) = struct module PVS_proxy = struct module Server = struct type t = { - uuid: string; - addresses: Unix.inet_addr list; - first_port: int; - last_port: int; - } [@@deriving rpcty] + uuid: string + ; addresses: Unix.inet_addr list + ; first_port: int + ; last_port: int + } + [@@deriving rpcty] end module Client = struct - type t = { - uuid: string; - mac: string; - interface: string; - prepopulate: bool; - } [@@deriving rpcty] + type t = {uuid: string; mac: string; interface: string; prepopulate: bool} + [@@deriving rpcty] end type t = { - site_uuid: string; - site_name: string; - servers: Server.t list; - clients: Client.t list; - vdi: string; - } [@@deriving rpcty] + site_uuid: string + ; site_name: string + ; servers: Server.t list + ; clients: Client.t list + ; vdi: string + } + [@@deriving rpcty] let configure_site = let pvs_p = Param.mk ~description:["proxy"] t in - declare - "PVS_proxy.configure_site" - ["Configure site"] + declare "PVS_proxy.configure_site" ["Configure site"] (debug_info_p @-> pvs_p @-> returning unit_p err) let remove_site = let site_p = Param.mk ~description:["site name"] Types.string in - declare - "PVS_proxy.remove_site" - ["Remove site"] + declare "PVS_proxy.remove_site" ["Remove site"] (debug_info_p @-> site_p @-> returning unit_p err) end module Sriov = struct type sriov_pci_t = { - mac: string option; - vlan: int64 option; - rate: int64 option; - } [@@deriving rpcty] + mac: string option + ; vlan: int64 option + ; rate: int64 option + } + [@@deriving rpcty] type enable_action_result = | Modprobe_successful_requires_reboot @@ -653,49 +724,44 @@ module Interface_API(R : RPC) = struct | Sysfs_successful [@@deriving rpcty] - type enable_result = - | Ok of enable_action_result - | Error of string + type enable_result = Ok of enable_action_result | Error of string [@@deriving rpcty] - type disable_result = - | Ok - | Error of string - [@@deriving rpcty] + type disable_result = Ok | Error of string [@@deriving rpcty] - type config_error = - | Config_vf_rate_not_supported - | Unknown of string + type config_error = Config_vf_rate_not_supported | Unknown of string [@@deriving rpcty] - type config_result = - | Ok - | Error of config_error - [@@deriving rpcty] + type config_result = Ok | Error of config_error [@@deriving rpcty] - let iface_name_p = Param.mk ~name:"name" ~description:["interface name"] iface + let iface_name_p = + Param.mk ~name:"name" ~description:["interface name"] iface let enable = - let result_p = Param.mk ~description:["SR-IOV enable result"] enable_result in - declare - "Sriov.enable" - ["Enable SR-IOV"] + let result_p = + Param.mk ~description:["SR-IOV enable result"] enable_result + in + declare "Sriov.enable" ["Enable SR-IOV"] (debug_info_p @-> iface_name_p @-> returning result_p err) let disable = - let result_p = Param.mk ~description:["SR-IOV disable result"] disable_result in - declare - "Sriov.disable" - ["Disable SR-IOV"] + let result_p = + Param.mk ~description:["SR-IOV disable result"] disable_result + in + declare "Sriov.disable" ["Disable SR-IOV"] (debug_info_p @-> iface_name_p @-> returning result_p err) let make_vf_config = - let pci_address_p = Param.mk ~description:["pci address"] Xcp_pci.address in + let pci_address_p = + Param.mk ~description:["pci address"] Xcp_pci.address + in let vf_info_p = Param.mk ~description:["vf info"] sriov_pci_t in - let result_t = Param.mk ~description:["SR-IOV make vf configuration result"] config_result in - declare - "Sriov.make_vf_config" - ["Make SR-IOV vf config"] + let result_t = + Param.mk + ~description:["SR-IOV make vf configuration result"] + config_result + in + declare "Sriov.make_vf_config" ["Make SR-IOV vf config"] (debug_info_p @-> pci_address_p @-> vf_info_p @-> returning result_t err) end end diff --git a/network/network_stats.ml b/network/network_stats.ml index 6534bf92..1e10cb8a 100644 --- a/network/network_stats.ml +++ b/network/network_stats.ml @@ -19,56 +19,67 @@ open Network_interface let stats_file = "/dev/shm/network_stats" + let interval = 5. (* seconds *) + let num_retries = 2 + let retry_delay = 0.5 let magic = "xapistat" + let magic_bytes = 8 + let checksum_bytes = 32 + let length_bytes = 8 type iface_stats = { - tx_bytes: int64; (** bytes emitted *) - tx_pkts: int64; (** packets emitted *) - tx_errors: int64; (** error emitted *) - rx_bytes: int64; (** bytes received *) - rx_pkts: int64; (** packets received *) - rx_errors: int64; (** error received *) - carrier: bool; - speed: int; - duplex: duplex; - pci_bus_path: string; - vendor_id: string; - device_id: string; - nb_links: int; - links_up: int; - interfaces: iface list; -} [@@deriving rpcty] - -let default_stats = { - tx_bytes = 0L; - tx_pkts = 0L; - tx_errors = 0L; - rx_bytes = 0L; - rx_pkts = 0L; - rx_errors = 0L; - carrier = false; - speed = 0; - duplex = Duplex_unknown; - pci_bus_path = ""; - vendor_id = ""; - device_id = ""; - nb_links = 0; - links_up = 0; - interfaces = []; + tx_bytes: int64 (** bytes emitted *) + ; tx_pkts: int64 (** packets emitted *) + ; tx_errors: int64 (** error emitted *) + ; rx_bytes: int64 (** bytes received *) + ; rx_pkts: int64 (** packets received *) + ; rx_errors: int64 (** error received *) + ; carrier: bool + ; speed: int + ; duplex: duplex + ; pci_bus_path: string + ; vendor_id: string + ; device_id: string + ; nb_links: int + ; links_up: int + ; interfaces: iface list } +[@@deriving rpcty] + +let default_stats = + { + tx_bytes= 0L + ; tx_pkts= 0L + ; tx_errors= 0L + ; rx_bytes= 0L + ; rx_pkts= 0L + ; rx_errors= 0L + ; carrier= false + ; speed= 0 + ; duplex= Duplex_unknown + ; pci_bus_path= "" + ; vendor_id= "" + ; device_id= "" + ; nb_links= 0 + ; links_up= 0 + ; interfaces= [] + } type stats_t = (iface * iface_stats) list [@@deriving rpcty] exception Read_error + exception Invalid_magic_string + exception Invalid_checksum + exception Invalid_length (* Shamelessly stolen from Unixext. *) @@ -76,12 +87,8 @@ module File_helpers = struct (** open a file, and make sure the close is always done *) let with_file file mode perms f = let fd = Unix.openfile file mode perms in - let r = - try f fd - with exn -> Unix.close fd; raise exn - in - Unix.close fd; - r + let r = try f fd with exn -> Unix.close fd ; raise exn in + Unix.close fd ; r (** [fd_blocks_fold block_size f start fd] folds [f] over blocks (strings) from the fd [fd] with initial value [start] *) @@ -90,14 +97,23 @@ module File_helpers = struct let rec fold acc = let n = Unix.read fd block 0 block_size in (* Consider making the interface explicitly use Substrings *) - let s = if n = block_size then (Bytes.to_string block) else Bytes.sub_string block 0 n in - if n = 0 then acc else fold (f acc s) in + let s = + if n = block_size then + Bytes.to_string block + else + Bytes.sub_string block 0 n + in + if n = 0 then acc else fold (f acc s) + in fold start let buffer_of_fd fd = - fd_blocks_fold 1024 (fun b s -> Buffer.add_string b s; b) (Buffer.create 1024) fd + fd_blocks_fold 1024 + (fun b s -> Buffer.add_string b s ; b) + (Buffer.create 1024) fd - let buffer_of_file file_path = with_file file_path [ Unix.O_RDONLY ] 0 buffer_of_fd + let buffer_of_file file_path = + with_file file_path [Unix.O_RDONLY] 0 buffer_of_fd let string_of_file file_path = Buffer.contents (buffer_of_file file_path) end @@ -106,28 +122,37 @@ let read_stats () = let rec retry n = try let data = File_helpers.string_of_file stats_file in - if String.sub data 0 magic_bytes <> magic then - raise Invalid_magic_string; + if String.sub data 0 magic_bytes <> magic then raise Invalid_magic_string ; let checksum = String.sub data magic_bytes checksum_bytes in let length = - try int_of_string ("0x" ^ (String.sub data (magic_bytes + checksum_bytes) length_bytes)) + try + int_of_string + ("0x" ^ String.sub data (magic_bytes + checksum_bytes) length_bytes) with _ -> raise Invalid_length in - let payload = String.sub data (magic_bytes + checksum_bytes + length_bytes) length in + let payload = + String.sub data (magic_bytes + checksum_bytes + length_bytes) length + in if payload |> Digest.string |> Digest.to_hex <> checksum then raise Invalid_checksum else - match payload |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_stats_t with - | Result.Ok v -> v - | Result.Error _ -> raise Read_error - with e -> - if n > 0 then begin - Thread.delay retry_delay; + match + payload |> Jsonrpc.of_string |> Rpcmarshal.unmarshal typ_of_stats_t + with + | Result.Ok v -> + v + | Result.Error _ -> + raise Read_error + with e -> ( + if n > 0 then ( + Thread.delay retry_delay ; retry (n - 1) - end else + ) else match e with - | Invalid_magic_string | Invalid_length | Invalid_checksum -> raise e - | _ -> raise Read_error + | Invalid_magic_string | Invalid_length | Invalid_checksum -> + raise e + | _ -> + raise Read_error + ) in retry num_retries - diff --git a/rrd/data_source.ml b/rrd/data_source.ml index 3151aa62..0bb817fb 100644 --- a/rrd/data_source.ml +++ b/rrd/data_source.ml @@ -13,21 +13,23 @@ *) type t = { - name : string; - description : string; - enabled : bool; - standard : bool; - min : float; - max : float; - units : string -} [@@deriving rpcty] + name: string + ; description: string + ; enabled: bool + ; standard: bool + ; min: float + ; max: float + ; units: string +} +[@@deriving rpcty] -let to_key_value_map ds = [ - "name_label", ds.name; - "name_description", ds.description; - "enabled", string_of_bool ds.enabled; - "standard", string_of_bool ds.standard; - "min", string_of_float ds.min; - "max", string_of_float ds.max; - "units", ds.units; -] +let to_key_value_map ds = + [ + ("name_label", ds.name) + ; ("name_description", ds.description) + ; ("enabled", string_of_bool ds.enabled) + ; ("standard", string_of_bool ds.standard) + ; ("min", string_of_float ds.min) + ; ("max", string_of_float ds.max) + ; ("units", ds.units) + ] diff --git a/rrd/ds.ml b/rrd/ds.ml index 0f0d2588..955923fd 100644 --- a/rrd/ds.ml +++ b/rrd/ds.ml @@ -11,32 +11,31 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** Data source - * @group Performance Monitoring - *) +(** Data source * @group Performance Monitoring *) (** This is used both for updating the DSs and for creating them *) type ds = { - ds_name : string; - ds_description : string; - ds_value : Rrd.ds_value_type; - ds_type : Rrd.ds_type; - ds_default : bool; - ds_min : float; - ds_max : float; - ds_units : string; - ds_pdp_transform_function : float -> float; + ds_name: string + ; ds_description: string + ; ds_value: Rrd.ds_value_type + ; ds_type: Rrd.ds_type + ; ds_default: bool + ; ds_min: float + ; ds_max: float + ; ds_units: string + ; ds_pdp_transform_function: float -> float } -let ds_make ~name ~description ~value ~ty ~default ~units - ?(min = neg_infinity) ?(max = infinity) ?(transform = (fun x -> x)) () = { - ds_name = name; - ds_description = description; - ds_value = value; - ds_type = ty; - ds_default = default; - ds_min = min; - ds_max = max; - ds_units = units; - ds_pdp_transform_function = transform; -} +let ds_make ~name ~description ~value ~ty ~default ~units ?(min = neg_infinity) + ?(max = infinity) ?(transform = fun x -> x) () = + { + ds_name= name + ; ds_description= description + ; ds_value= value + ; ds_type= ty + ; ds_default= default + ; ds_min= min + ; ds_max= max + ; ds_units= units + ; ds_pdp_transform_function= transform + } diff --git a/rrd/rrd_cli.ml b/rrd/rrd_cli.ml index 1cdd640f..0046a252 100644 --- a/rrd/rrd_cli.ml +++ b/rrd/rrd_cli.ml @@ -1,23 +1,27 @@ - - (* Rrd CLI *) -module Cmds = Rrd_interface.RPC_API(Cmdlinergen.Gen ()) +module Cmds = Rrd_interface.RPC_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the Db monitoring API. This allows scripting of the Rrd daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "rrd_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the Db monitoring API. This allows scripting of the Rrd \ + daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "rrd_cli" ~version:(version_str Cmds.description) ~doc ) let cli () = let rpc = Rrd_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) let _ = cli () diff --git a/rrd/rrd_client.ml b/rrd/rrd_client.ml index 79771479..7f831678 100644 --- a/rrd/rrd_client.ml +++ b/rrd/rrd_client.ml @@ -16,28 +16,22 @@ open Rrd_interface open Xcp_client let rec retry_econnrefused f = - try - f () - with - | Unix.Unix_error(Unix.ECONNREFUSED, "connect", _) -> - (* debug "Caught ECONNREFUSED; retrying in 5s"; *) - Thread.delay 5.; - retry_econnrefused f + try f () with + | Unix.Unix_error (Unix.ECONNREFUSED, "connect", _) -> + (* debug "Caught ECONNREFUSED; retrying in 5s"; *) + Thread.delay 5. ; retry_econnrefused f | e -> - (* error "Caught %s: does the rrd service need restarting?" (Printexc.to_string e); *) - - raise e + (* error "Caught %s: does the rrd service need restarting?" + (Printexc.to_string e); *) + raise e let rpc call = - retry_econnrefused - (fun () -> - (* TODO: the message switch doesn't handle raw HTTP very well *) - if (* !use_switch *) false - then json_switch_rpc !queue_name call - else xml_http_rpc - ~srcstr:(get_user_agent ()) - ~dststr:"rrd" - Rrd_interface.uri - call - ) -module Client = RPC_API(Idl.Exn.GenClient(struct let rpc=rpc end)) + retry_econnrefused (fun () -> + (* TODO: the message switch doesn't handle raw HTTP very well *) + if (* !use_switch *) false then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:(get_user_agent ()) ~dststr:"rrd" Rrd_interface.uri + call) + +module Client = RPC_API (Idl.Exn.GenClient (struct let rpc = rpc end)) diff --git a/rrd/rrd_interface.ml b/rrd/rrd_interface.ml index d8add3ad..e975c520 100644 --- a/rrd/rrd_interface.ml +++ b/rrd/rrd_interface.ml @@ -22,15 +22,20 @@ open Rpc open Idl let service_name = "rrd" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) let default_sockets_dir = "/var/lib/xcp" + let daemon_name = "xcp-rrdd" + let default_path = ref (Filename.concat default_sockets_dir daemon_name) -let forwarded_path = ref (Filename.concat default_sockets_dir daemon_name ^ ".forwarded") + +let forwarded_path = + ref (Filename.concat default_sockets_dir daemon_name ^ ".forwarded") let set_sockets_dir x = - default_path := Filename.concat x daemon_name; + default_path := Filename.concat x daemon_name ; forwarded_path := !default_path ^ ".forwarded" let uri () = "file:" ^ !default_path @@ -39,14 +44,14 @@ let uri () = "file:" ^ !default_path type plugin_protocol = | V1 (** Plugin protocol 1 *) | V2 (** Plugin protocol 2 *) -[@@default V2] -[@@deriving rpcty] +[@@default V2] [@@deriving rpcty] (** Domain ID of VM *) -type interdomain_uid = - { name : string; (** VM domain name label *) - frontend_domid : int (** Front-end domain ID number *) - } [@@deriving rpcty] +type interdomain_uid = { + name: string (** VM domain name label *) + ; frontend_domid: int (** Front-end domain ID number *) +} +[@@deriving rpcty] (* Note: for types such as rrd_req, which alias * user-defined types, it is usually not enough @@ -56,358 +61,532 @@ type interdomain_uid = * already been defined as RPC types in their original declarations * so we are able to derive these type aliases like so *) -type rrd_freq = Rrd.sampling_frequency = Five_Seconds -[@@deriving rpcty] +type rrd_freq = Rrd.sampling_frequency = Five_Seconds [@@deriving rpcty] -type statefile_latency = Rrd.Statefile_latency.t = { id: string; latency: float option } +type statefile_latency = Rrd.Statefile_latency.t = { + id: string + ; latency: float option +} [@@deriving rpcty] -type sflat_lst = statefile_latency list -[@@deriving rpcty] +type sflat_lst = statefile_latency list [@@deriving rpcty] (** Domain database sampling info *) -type interdomain_info = - { frequency : rrd_freq; (** interdomain rrd sampling frequency *) - shared_page_refs : int list (** list of shared page references *) - } [@@deriving rpcty] - -type string_opt = string option +type interdomain_info = { + frequency: rrd_freq (** interdomain rrd sampling frequency *) + ; shared_page_refs: int list (** list of shared page references *) +} [@@deriving rpcty] -type ds_list = Data_source.t list -[@@deriving rpcty] +type string_opt = string option [@@deriving rpcty] +type ds_list = Data_source.t list [@@deriving rpcty] (* -- error handling -- *) (** Rrdd error type *) type rrd_errors = - | Archive_failed of string (** Archival failure *) - | Invalid_protocol of string (** Thrown by protocol_of_string if - string does not match plugin protocol *) - | Rrdd_internal_error of string (** Internal Rrdd error *) + | Archive_failed of string (** Archival failure *) + | Invalid_protocol of string + (** Thrown by protocol_of_string if string does not match plugin protocol *) + | Rrdd_internal_error of string (** Internal Rrdd error *) [@@deriving rpcty] exception Rrdd_error of rrd_errors -let () = (* register printer *) +let () = + (* register printer *) let string_of_error e = - Rpcmarshal.marshal rrd_errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal rrd_errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | Rrdd_error e -> - Some (Printf.sprintf "Rrd_interface.Rrdd_error(%s)" (string_of_error e)) - | _ -> None in + Some (Printf.sprintf "Rrd_interface.Rrdd_error(%s)" (string_of_error e)) + | _ -> + None + in Printexc.register_printer printer (** Error handler *) -module RrdErrHandler = Error.Make(struct - type t = rrd_errors - let t = rrd_errors - let internal_error_of e = Some (Rrdd_internal_error (Printexc.to_string e)) - end) +module RrdErrHandler = Error.Make (struct + type t = rrd_errors + + let t = rrd_errors + + let internal_error_of e = Some (Rrdd_internal_error (Printexc.to_string e)) +end) + let rrd_err = RrdErrHandler.error -let string_of_protocol = function - | V1 -> "V1" - | V2 -> "V2" +let string_of_protocol = function V1 -> "V1" | V2 -> "V2" let protocol_of_string = function - | x when x="V1" -> V1 - | x when x="V2" -> V2 - | y -> raise (Rrdd_error (Invalid_protocol(y))) - + | x when x = "V1" -> + V1 + | x when x = "V2" -> + V2 + | y -> + raise (Rrdd_error (Invalid_protocol y)) (* -- RPC generation -- *) -module RPC_API(R : RPC) = struct +module RPC_API (R : RPC) = struct open R let description = - Interface.{ name = "Rrd" - ; namespace = None - ; description = - [ "This interface is used by Xapi and Rrdd to manage " - ; "round robin database sampling of dom0 databases. " ] - ; version=(1,0,0) - } + Interface. + { + name= "Rrd" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and Rrdd to manage " + ; "round robin database sampling of dom0 databases. " + ] + ; version= (1, 0, 0) + } let implementation = implement description (** Common API call parameter definitions *) - let unit_p = Param.mk Types.unit + let unit_p = Param.mk Types.unit + let string_p = Param.mk Types.string - let float_p = Param.mk Types.float - let uuid_p = Param.mk ~name:"uuid" ~description:[ "User ID" ] Types.string - let vm_uuid_p = Param.mk ~name:"vm_uuid" ~description:[ "VM ID" ] Types.string - let domid_p = Param.mk ~name:"domid" ~description:[ "Domain ID of VM" ] Types.int - let sr_uuid_p = Param.mk ~name:"sr_uuid" ~description:[ "SR ID" ] Types.string - let ds_name_p = Param.mk ~name:"ds_name" ~description:[ "Domain server name" ] Types.string - let rem_add_p = Param.mk ~name:"remote_address" ~description:[ "Remote address" ] Types.string + let float_p = Param.mk Types.float + + let uuid_p = Param.mk ~name:"uuid" ~description:["User ID"] Types.string + + let vm_uuid_p = Param.mk ~name:"vm_uuid" ~description:["VM ID"] Types.string - let ds_list_p = Param.mk ~name:"data_source list" - ~description: [ "Datasource list" ] ds_list + let domid_p = + Param.mk ~name:"domid" ~description:["Domain ID of VM"] Types.int + + let sr_uuid_p = Param.mk ~name:"sr_uuid" ~description:["SR ID"] Types.string + + let ds_name_p = + Param.mk ~name:"ds_name" ~description:["Domain server name"] Types.string + + let rem_add_p = + Param.mk ~name:"remote_address" ~description:["Remote address"] Types.string + + let ds_list_p = + Param.mk ~name:"data_source list" ~description:["Datasource list"] ds_list (** API call definitions *) let has_vm_rrd = let bool_p = Param.mk Types.bool in declare "has_vm_rrd" - [ "Returns `true` if xcp-rrdd has an RRD for the specified VM in memory" ] - ( vm_uuid_p @-> returning bool_p rrd_err) - - let push_rrd_local = declare "push_rrd_local" - [ "Loads a VM RRD from local storage, associates it with the specified domid, and"; - "starts recording all data sources related to the VM to that RRD" ] - (vm_uuid_p @-> domid_p @-> returning unit_p rrd_err) - - let push_rrd_remote = declare "push_rrd_remote" - [ "Loads a VM RRD from local storage and pushes it to a remote host" ] - (vm_uuid_p @-> rem_add_p @-> returning unit_p rrd_err) - - let remove_rrd = declare "remove_rrd" - [ "Removes a VM RRD from the local filesystem, if it exists." ] - (uuid_p @-> returning unit_p rrd_err) + ["Returns `true` if xcp-rrdd has an RRD for the specified VM in memory"] + (vm_uuid_p @-> returning bool_p rrd_err) + + let push_rrd_local = + declare "push_rrd_local" + [ + "Loads a VM RRD from local storage, associates it with the specified \ + domid, and" + ; "starts recording all data sources related to the VM to that RRD" + ] + (vm_uuid_p @-> domid_p @-> returning unit_p rrd_err) + + let push_rrd_remote = + declare "push_rrd_remote" + ["Loads a VM RRD from local storage and pushes it to a remote host"] + (vm_uuid_p @-> rem_add_p @-> returning unit_p rrd_err) + + let remove_rrd = + declare "remove_rrd" + ["Removes a VM RRD from the local filesystem, if it exists."] + (uuid_p @-> returning unit_p rrd_err) let migrate_rrd = - let host_uuid_p = Param.mk ~name:"host_uuid" ~description:[ "Unique ID of host" ] Types.string in - let session_id_p = Param.mk ~name:"session_id" ~description:[ "ID of the session" ] string_opt in + let host_uuid_p = + Param.mk ~name:"host_uuid" ~description:["Unique ID of host"] Types.string + in + let session_id_p = + Param.mk ~name:"session_id" ~description:["ID of the session"] string_opt + in declare "migrate_rrd" - [ "Migrate_push - used by the migrate code to push an RRD directly to" + [ + "Migrate_push - used by the migrate code to push an RRD directly to" ; "a remote host without going via the master. If the host is on a" - ; "different pool, you must pass both the remote_address and session_id parameters."] + ; "different pool, you must pass both the remote_address and session_id \ + parameters." + ] (session_id_p - @-> rem_add_p - @-> vm_uuid_p - @-> host_uuid_p - @-> returning unit_p rrd_err) - + @-> rem_add_p + @-> vm_uuid_p + @-> host_uuid_p + @-> returning unit_p rrd_err + ) let send_host_rrd_to_master = - let mast_addr_str = Param.mk ~name:"master_address" ~description:[ "Address of remote" ] Types.string in + let mast_addr_str = + Param.mk ~name:"master_address" ~description:["Address of remote"] + Types.string + in declare "send_host_rrd_to_master" - [ "Called on host shutdown/reboot to send the Host RRD to the master for" - ; "backup." ] + [ + "Called on host shutdown/reboot to send the Host RRD to the master for" + ; "backup." + ] (mast_addr_str @-> returning unit_p rrd_err) - let rem_addr_opt_p = Param.mk ~name:"remote_address" ~description:[ "Address of the remote" ] string_opt - let backup_rrds = declare "backup_rrds" - [ "Backs up RRD data to disk. This should be done periodically to ensure" - ; "that if the host crashes we don't lose too much data." ] - (rem_addr_opt_p @-> unit_p @-> returning unit_p rrd_err) + let rem_addr_opt_p = + Param.mk ~name:"remote_address" ~description:["Address of the remote"] + string_opt - let archive_rrd = declare "archive_rrd" - [ "Sends the VM RRD either to local disk or the remote address if specified," - ; "and removes it from memory. Called on VM shutdown/suspend." ] - (vm_uuid_p @-> rem_addr_opt_p @-> returning unit_p rrd_err) + let backup_rrds = + declare "backup_rrds" + [ + "Backs up RRD data to disk. This should be done periodically to ensure" + ; "that if the host crashes we don't lose too much data." + ] + (rem_addr_opt_p @-> unit_p @-> returning unit_p rrd_err) - let archive_sr_rrd = declare "archive_sr_rrd" - [ "Saves the SR RRD to the local disk. Returns the path to the saved RRD so" - ; "it can be copied onto the SR before it is detached." ] - (sr_uuid_p @-> returning string_p rrd_err) + let archive_rrd = + declare "archive_rrd" + [ + "Sends the VM RRD either to local disk or the remote address if \ + specified," + ; "and removes it from memory. Called on VM shutdown/suspend." + ] + (vm_uuid_p @-> rem_addr_opt_p @-> returning unit_p rrd_err) + + let archive_sr_rrd = + declare "archive_sr_rrd" + [ + "Saves the SR RRD to the local disk. Returns the path to the saved RRD \ + so" + ; "it can be copied onto the SR before it is detached." + ] + (sr_uuid_p @-> returning string_p rrd_err) let push_sr_rrd = - let path_p = Param.mk ~name:"path" ~description:[ "Filepath" ] Types.string in + let path_p = Param.mk ~name:"path" ~description:["Filepath"] Types.string in declare "push_sr_rrd" - [ "Loads the RRD from the path specified on the local disk. Overwrites any" + [ + "Loads the RRD from the path specified on the local disk. Overwrites any" ; "RRD already in memory for the SR. Data sources will subsequently be " - ; "recorded to this RRD." ] + ; "recorded to this RRD." + ] (sr_uuid_p @-> path_p @-> returning unit_p rrd_err) - let add_host_ds = declare "add_host_ds" - [ "Adds a host data source to the host RRD. This causes the data source to be " - ; "recorded if it wasn't a default data source." ] - (ds_name_p @-> returning unit_p rrd_err) - - let forget_host_ds = declare "forget_host_ds" - [ "Forgets the recorded archives for the named data source. Note that if the " - ; "data source is marked as default, new data coming in will cause the archive" - ; "to be recreated." ] - (ds_name_p @-> returning unit_p rrd_err) + let add_host_ds = + declare "add_host_ds" + [ + "Adds a host data source to the host RRD. This causes the data source \ + to be " + ; "recorded if it wasn't a default data source." + ] + (ds_name_p @-> returning unit_p rrd_err) + + let forget_host_ds = + declare "forget_host_ds" + [ + "Forgets the recorded archives for the named data source. Note that if \ + the " + ; "data source is marked as default, new data coming in will cause the \ + archive" + ; "to be recreated." + ] + (ds_name_p @-> returning unit_p rrd_err) let query_possible_host_dss = declare "query_possible_host_dss" - [ "Returns list of possible host DSs. This will include data sources not " - ; "currently being recorded into archives." ] + [ + "Returns list of possible host DSs. This will include data sources not " + ; "currently being recorded into archives." + ] (unit_p @-> returning ds_list_p rrd_err) - let query_host_ds = declare "query_host_ds" - [ "Returns the current value of the named host data source. Note this returns" - ; " the raw data source value, not the smoothed last value of the RRA." ] + let query_host_ds = + declare "query_host_ds" + [ + "Returns the current value of the named host data source. Note this \ + returns" + ; " the raw data source value, not the smoothed last value of the RRA." + ] (ds_name_p @-> returning float_p rrd_err) - - let add_vm_ds = declare "add_vm_ds" - [ "Adds a VM data source to the VM RRD. This causes the data source to be" - ; " recorded if it wasn't a default data source." ] - (vm_uuid_p @-> domid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let forget_vm_ds = declare "forget_vm_ds" - [ "Forgets the recorded archives for the named VM data source. Note that if the" - ; "data source is marked as default, new data coming in will cause the archive" - ; "to be recreated." ] - (vm_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let query_possible_vm_dss = declare "query_possible_vm_dss" - [ "Returns list of possible VM DSs. This will include data sources not" - ; "currently being recorded into archives." ] - (vm_uuid_p @-> returning ds_list_p rrd_err) - - let query_vm_ds = declare "query_vm_ds" - [ "Returns the current value of the named VM data source. Note this returns" - ; "the raw data source value, not the smoothed last value of the RRA." ] - (vm_uuid_p @-> ds_name_p @-> returning float_p rrd_err) - - let add_sr_ds = declare "add_sr_ds" - [ "Adds an SR data source to the SR RRD. This causes the data source to be" - ; "recorded if it wasn't a default data source." ] - (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let forget_sr_ds = declare "forget_sr_ds" - [ "Forgets the recorded archives for the named SR data source. Note that if the" - ; "data source is marked as default, new data coming in will cause the archive" - ; "to be recreated." ] - (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) - - let query_possible_sr_dss = declare "query_possible_sr_dss" - [ "Returns list of possible SR DSs. This will include data sources not" - ; "currently being recorded into archives." ] - (sr_uuid_p @-> returning ds_list_p rrd_err) - - let query_sr_ds = declare "query_sr_ds" - [ "Returns the current value of the named VM data source. Note this returns" - ; "the raw data source value, not the smoothed last value of the RRA." ] - (sr_uuid_p @-> ds_name_p @-> returning float_p rrd_err) + let add_vm_ds = + declare "add_vm_ds" + [ + "Adds a VM data source to the VM RRD. This causes the data source to be" + ; " recorded if it wasn't a default data source." + ] + (vm_uuid_p @-> domid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let forget_vm_ds = + declare "forget_vm_ds" + [ + "Forgets the recorded archives for the named VM data source. Note that \ + if the" + ; "data source is marked as default, new data coming in will cause the \ + archive" + ; "to be recreated." + ] + (vm_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let query_possible_vm_dss = + declare "query_possible_vm_dss" + [ + "Returns list of possible VM DSs. This will include data sources not" + ; "currently being recorded into archives." + ] + (vm_uuid_p @-> returning ds_list_p rrd_err) + + let query_vm_ds = + declare "query_vm_ds" + [ + "Returns the current value of the named VM data source. Note this \ + returns" + ; "the raw data source value, not the smoothed last value of the RRA." + ] + (vm_uuid_p @-> ds_name_p @-> returning float_p rrd_err) + + let add_sr_ds = + declare "add_sr_ds" + [ + "Adds an SR data source to the SR RRD. This causes the data source to be" + ; "recorded if it wasn't a default data source." + ] + (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let forget_sr_ds = + declare "forget_sr_ds" + [ + "Forgets the recorded archives for the named SR data source. Note that \ + if the" + ; "data source is marked as default, new data coming in will cause the \ + archive" + ; "to be recreated." + ] + (sr_uuid_p @-> ds_name_p @-> returning unit_p rrd_err) + + let query_possible_sr_dss = + declare "query_possible_sr_dss" + [ + "Returns list of possible SR DSs. This will include data sources not" + ; "currently being recorded into archives." + ] + (sr_uuid_p @-> returning ds_list_p rrd_err) + + let query_sr_ds = + declare "query_sr_ds" + [ + "Returns the current value of the named VM data source. Note this \ + returns" + ; "the raw data source value, not the smoothed last value of the RRA." + ] + (sr_uuid_p @-> ds_name_p @-> returning float_p rrd_err) let update_use_min_max = - let value_p = Param.mk ~name:"value" ~description:[ "Value dictating whether to use min_max" ] Types.bool in + let value_p = + Param.mk ~name:"value" + ~description:["Value dictating whether to use min_max"] + Types.bool + in declare "update_use_min_max" - [ "Set the value of the `use_min_max` variable. If this is `true`, when creating" - ; "a new RRD, archives for the minimum and maximum observed values will be created" - ; "alongside the standard archive of average values" ] + [ + "Set the value of the `use_min_max` variable. If this is `true`, when \ + creating" + ; "a new RRD, archives for the minimum and maximum observed values will \ + be created" + ; "alongside the standard archive of average values" + ] (value_p @-> returning unit_p rrd_err) let update_vm_memory_target = - let target_p = Param.mk ~name:"target" ~description:[ "VM memory target" ] Types.int64 in + let target_p = + Param.mk ~name:"target" ~description:["VM memory target"] Types.int64 + in declare "update_vm_memory_target" - [ "Sets the `memory_target` value for a VM. This is called by xapi when it is told by" - ; "xenopsd that squeezed has changed the target for a VM." ] + [ + "Sets the `memory_target` value for a VM. This is called by xapi when \ + it is told by" + ; "xenopsd that squeezed has changed the target for a VM." + ] (domid_p @-> target_p @-> returning unit_p rrd_err) - let set_cache_sr = declare "set_cache_sr" - [ "Sets the uuid of the cache SR. If this is set, statistics about the usage of the cache" - ; "will be recorded into the host SR." ] - (sr_uuid_p @-> returning unit_p rrd_err) - - let unset_cache_sr = declare "unset_cache_sr" - [ "Unsets the cache_sr. No futher data will be gathered about cache usage, but existing" - ; "archive data will not be deleted." ] - (unit_p @-> returning unit_p rrd_err) - + let set_cache_sr = + declare "set_cache_sr" + [ + "Sets the uuid of the cache SR. If this is set, statistics about the \ + usage of the cache" + ; "will be recorded into the host SR." + ] + (sr_uuid_p @-> returning unit_p rrd_err) + + let unset_cache_sr = + declare "unset_cache_sr" + [ + "Unsets the cache_sr. No futher data will be gathered about cache \ + usage, but existing" + ; "archive data will not be deleted." + ] + (unit_p @-> returning unit_p rrd_err) module Plugin = struct - - let uid_p = Param.mk ~name:"uid" ~description:[ "Plugin UID" ] Types.string - let info_p = Param.mk ~name:"info" ~description:[ "Interdomain info" ] interdomain_info - let protocol_p = Param.mk ~name:"protocol" ~description:[ "Plugin protocol version" ] plugin_protocol - - let get_header = declare "Plugin.get_header" - [ "Returns header string. This string should be copied exactly to the start" - ; "of the shared memory containing the data source" ] + let uid_p = Param.mk ~name:"uid" ~description:["Plugin UID"] Types.string + + let info_p = + Param.mk ~name:"info" ~description:["Interdomain info"] interdomain_info + + let protocol_p = + Param.mk ~name:"protocol" + ~description:["Plugin protocol version"] + plugin_protocol + + let get_header = + declare "Plugin.get_header" + [ + "Returns header string. This string should be copied exactly to the \ + start" + ; "of the shared memory containing the data source" + ] (unit_p @-> returning string_p rrd_err) - let get_path = declare "Plugin.get_path" - [ "Returns path in the local filesystem to place the data" - ; "source file" ] + let get_path = + declare "Plugin.get_path" + [ + "Returns path in the local filesystem to place the data"; "source file" + ] (uid_p @-> returning string_p rrd_err) module Local = struct let register = - let info_p = Param.mk ~name:"info" ~description:[ "Local rrd info" ] rrd_freq in + let info_p = + Param.mk ~name:"info" ~description:["Local rrd info"] rrd_freq + in declare "Plugin.Local.register" - [ "[Plugin.Local.register uid info protocol] registers a plugin" + [ + "[Plugin.Local.register uid info protocol] registers a plugin" ; "as a source of a set of data-sources. [uid] is a unique identifier" ; "for the plugin, often the name of the plugin. [info] is the RRD" ; "frequency, and [protocol] specifies whether the plugin will be" - ; "using V1 or V2 of the protocol."] + ; "using V1 or V2 of the protocol." + ] (uid_p @-> info_p @-> protocol_p @-> returning float_p rrd_err) - let deregister = declare "Plugin.Local.deregister" - [ "Deregisters a plugin by uid" ] - (uid_p @-> returning unit_p rrd_err) - - let next_reading = declare "Plugin.Local.next_reading" - [ "Returns the number of seconds until the next reading will be taken." ] - (uid_p @-> returning float_p rrd_err) + let deregister = + declare "Plugin.Local.deregister" + ["Deregisters a plugin by uid"] + (uid_p @-> returning unit_p rrd_err) + + let next_reading = + declare "Plugin.Local.next_reading" + [ + "Returns the number of seconds until the next reading will be taken." + ] + (uid_p @-> returning float_p rrd_err) end module Interdomain = struct - - let iduid_p = Param.mk ~name:"uid" ~description:[ "Interdomain ID" ] interdomain_uid + let iduid_p = + Param.mk ~name:"uid" ~description:["Interdomain ID"] interdomain_uid let register = declare "Plugin.Interdomain.register" - [ "[Plugin.Interdomain.register uid info protocol] registers an" + [ + "[Plugin.Interdomain.register uid info protocol] registers an" ; "interdomain plugin. [uid] is the unique identifier of the" ; "plugin, containing both a name and the frontend domain id." ; "[info] contains both the desired sampling frequency and" ; "a list of the grant references of the shared pages. [protocol]" ; "is V1 or V2, and the return value is the time until the next" - ; "reading" ] + ; "reading" + ] (iduid_p @-> info_p @-> protocol_p @-> returning float_p rrd_err) - let deregister = declare "Plugin.Interdomain.deregister" - [ "Deregisters a plugin by uid." ] - (iduid_p @-> returning unit_p rrd_err) + let deregister = + declare "Plugin.Interdomain.deregister" + ["Deregisters a plugin by uid."] + (iduid_p @-> returning unit_p rrd_err) - let next_reading = declare "Plugin.Interdomain.next_reading" - [ "Returns the number of seconds before the next reading." ] - (iduid_p @-> returning float_p rrd_err) + let next_reading = + declare "Plugin.Interdomain.next_reading" + ["Returns the number of seconds before the next reading."] + (iduid_p @-> returning float_p rrd_err) end let register = - let freq_p = Param.mk ~name:"frequency" ~description:[ "Rrd database sampling frequency" ] rrd_freq in + let freq_p = + Param.mk ~name:"frequency" + ~description:["Rrd database sampling frequency"] + rrd_freq + in declare "Plugin.register" - [ "Preserved for backwards compatibility. Equivalent to a Local" - ; "plugin registration with V1 protocol." ] + [ + "Preserved for backwards compatibility. Equivalent to a Local" + ; "plugin registration with V1 protocol." + ] (uid_p @-> freq_p @-> returning float_p rrd_err) - let deregister = declare "Plugin.deregister" - [ "Preserved for backwards compatibility. Deregesters a local plugin." ] - (uid_p @-> returning unit_p rrd_err) + let deregister = + declare "Plugin.deregister" + ["Preserved for backwards compatibility. Deregesters a local plugin."] + (uid_p @-> returning unit_p rrd_err) - let next_reading = declare "Plugin.next_reading" - [ "Returns the time until the next reading." ] - (uid_p @-> returning float_p rrd_err) + let next_reading = + declare "Plugin.next_reading" + ["Returns the time until the next reading."] + (uid_p @-> returning float_p rrd_err) end (** High availability module *) module HA = struct - let enable_and_update = - let heartb_lat_p = Param.mk ~name:"heartbeat_latency" ~description:[ "Time taken for heartbeat signal to travel" ] Types.float in - let xapi_lat_p = Param.mk ~name:"xapi_latency" ~description:[ "Time taken for Xapi to respond" ] Types.float in - let stfile_lats_p = Param.mk ~name:"statefile_latencies" ~description:[ "Time taken for statefiles to update" ] sflat_lst in + let heartb_lat_p = + Param.mk ~name:"heartbeat_latency" + ~description:["Time taken for heartbeat signal to travel"] + Types.float + in + let xapi_lat_p = + Param.mk ~name:"xapi_latency" + ~description:["Time taken for Xapi to respond"] + Types.float + in + let stfile_lats_p = + Param.mk ~name:"statefile_latencies" + ~description:["Time taken for statefiles to update"] + sflat_lst + in declare "HA.enable_and_update" - [ "Enables the gathering of HA metrics, a built-in function of xcp-rrdd." ] - (stfile_lats_p @-> heartb_lat_p @-> xapi_lat_p @-> returning unit_p rrd_err) - - let disable = declare "HA.disable" - [ "Disables the HA metrics." ] - (unit_p @-> returning unit_p rrd_err) + [ + "Enables the gathering of HA metrics, a built-in function of xcp-rrdd." + ] + (stfile_lats_p + @-> heartb_lat_p + @-> xapi_lat_p + @-> returning unit_p rrd_err + ) + + let disable = + declare "HA.disable" + ["Disables the HA metrics."] + (unit_p @-> returning unit_p rrd_err) end module Deprecated = struct - let load_rrd = - let timescale_int_p = Param.mk ~name:"timescale" ~description:[ "Speed of round-robin database loading" ] Types.int in - let mast_addr_opt_p = Param.mk ~name:"master address" ~description:[ "Master address to load rrd from" ] string_opt in - declare "Deprecated.load_rrd" - [ "Deprecated call." ] + let timescale_int_p = + Param.mk ~name:"timescale" + ~description:["Speed of round-robin database loading"] + Types.int + in + let mast_addr_opt_p = + Param.mk ~name:"master address" + ~description:["Master address to load rrd from"] + string_opt + in + declare "Deprecated.load_rrd" ["Deprecated call."] (uuid_p - @-> timescale_int_p - @-> mast_addr_opt_p - @-> returning unit_p rrd_err) + @-> timescale_int_p + @-> mast_addr_opt_p + @-> returning unit_p rrd_err + ) end end diff --git a/storage/storage_client.ml b/storage/storage_client.ml index 3fdf330f..7bf40378 100644 --- a/storage/storage_client.ml +++ b/storage/storage_client.ml @@ -16,28 +16,21 @@ open Storage_interface open Xcp_client let rec retry_econnrefused f = - try - f () - with - | Unix.Unix_error(Unix.ECONNREFUSED, "connect", _) -> + try f () with + | Unix.Unix_error (Unix.ECONNREFUSED, "connect", _) -> (* debug "Caught ECONNREFUSED; retrying in 5s"; *) - Thread.delay 5.; - retry_econnrefused f + Thread.delay 5. ; retry_econnrefused f | e -> - (* error "Caught %s: does the storage service need restarting?" (Printexc.to_string e); *) + (* error "Caught %s: does the storage service need restarting?" + (Printexc.to_string e); *) raise e -module Client = Storage_interface.StorageAPI(Idl.Exn.GenClient(struct +module Client = Storage_interface.StorageAPI (Idl.Exn.GenClient (struct let rpc call = - retry_econnrefused - (fun () -> - if !use_switch - then json_switch_rpc !queue_name call - else xml_http_rpc - ~srcstr:(get_user_agent ()) - ~dststr:"storage" - Storage_interface.uri - call - ) + retry_econnrefused (fun () -> + if !use_switch then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:(get_user_agent ()) ~dststr:"storage" + Storage_interface.uri call) end)) - diff --git a/storage/storage_interface.ml b/storage/storage_interface.ml index c5297a42..a0bdb319 100644 --- a/storage/storage_interface.ml +++ b/storage/storage_interface.ml @@ -11,15 +11,14 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Storage -*) + +(** * @group Storage *) open Rpc + open Idl -module D = Debug.Make (struct - let name = "storage_interface" - end) +module D = Debug.Make (struct let name = "storage_interface" end) + open D type rpc_t = Rpc.t @@ -27,101 +26,130 @@ type rpc_t = Rpc.t let typ_of_rpc_t = let open Types in Abstract - { aname= "Rpc.t" + { + aname= "Rpc.t" ; test_data= [Null] ; rpc_of= (fun x -> x) - ; of_rpc= (fun x -> Ok x) } - - + ; of_rpc= (fun x -> Ok x) + } module TypeCombinators = struct - let option ?name ?(description= []) d = + let option ?name ?(description = []) d = let open Rpc.Types in let name = match name with Some n -> n | None -> Printf.sprintf "%s option" d.name in {name; description; ty= Option d.ty} - let list ?name ?(description= []) d = + let list ?name ?(description = []) d = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "list of %ss" d.name + | Some n -> + n + | None -> + Printf.sprintf "list of %ss" d.name in {name; description; ty= List d.ty} - let pair ?name ?(description= []) (p1, p2) = + let pair ?name ?(description = []) (p1, p2) = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "pair of %s and %s" p1.name p2.name + | Some n -> + n + | None -> + Printf.sprintf "pair of %s and %s" p1.name p2.name in {name; description; ty= Tuple (p1.ty, p2.ty)} - let triple ?name ?(description= []) (p1, p2, p3) = + let triple ?name ?(description = []) (p1, p2, p3) = let open Rpc.Types in let name = match name with - | Some n -> n + | Some n -> + n | None -> - Printf.sprintf "triple of %s, %s and %s" p1.name p2.name p3.name + Printf.sprintf "triple of %s, %s and %s" p1.name p2.name p3.name in {name; description; ty= Tuple3 (p1.ty, p2.ty, p3.ty)} end -let service_name="storage" +let service_name = "storage" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) let default_sockets_dir = "/var/lib/xcp" + let default_path = ref (Filename.concat default_sockets_dir service_name) -let set_sockets_dir x = - default_path := Filename.concat x service_name +let set_sockets_dir x = default_path := Filename.concat x service_name let uri () = "file:" ^ !default_path let rpc_of t x = Rpcmarshal.marshal t.Rpc.Types.ty x -let of_rpc t x = match Rpcmarshal.unmarshal t.Rpc.Types.ty x with | Ok y -> y | Error (`Msg m) -> failwith (Printf.sprintf "Error unmarshalling type %s: %s" t.Rpc.Types.name m) + +let of_rpc t x = + match Rpcmarshal.unmarshal t.Rpc.Types.ty x with + | Ok y -> + y + | Error (`Msg m) -> + failwith + (Printf.sprintf "Error unmarshalling type %s: %s" t.Rpc.Types.name m) (** Primary key identifying the SR *) module type WRAPPEDSTRING = sig type t + val typ_of : t Rpc.Types.typ + val t : t Rpc.Types.def + val string_of : t -> string + val of_string : string -> t end module Sr : WRAPPEDSTRING = struct type t = string [@@deriving rpcty] + let string_of x = x + let of_string x = x end type sr = Sr.t -let sr_pp : Format.formatter -> sr -> unit = fun ppf sr -> Format.fprintf ppf "%s" (Sr.string_of sr) + +let sr_pp : Format.formatter -> sr -> unit = + fun ppf sr -> Format.fprintf ppf "%s" (Sr.string_of sr) (** Primary key identifying a VDI within an SR *) module Vdi : WRAPPEDSTRING = struct type t = string [@@deriving rpcty] + let string_of x = x + let of_string x = x end type vdi = Vdi.t -let vdi_pp : Format.formatter -> vdi -> unit = fun ppf vdi -> Format.fprintf ppf "%s" (Vdi.string_of vdi) + +let vdi_pp : Format.formatter -> vdi -> unit = + fun ppf vdi -> Format.fprintf ppf "%s" (Vdi.string_of vdi) module Vm : WRAPPEDSTRING = struct (* This is the domid. *) type t = string [@@deriving rpcty] + let string_of x = x + let of_string x = x end type vm = Vm.t -let vm_pp : Format.formatter -> vm -> unit = fun ppf vm -> Format.fprintf ppf "%s" (Vm.string_of vm) + +let vm_pp : Format.formatter -> vm -> unit = + fun ppf vm -> Format.fprintf ppf "%s" (Vm.string_of vm) (** Opaque identifier used by the client to identify a particular operation *) type debug_info = string [@@deriving rpcty] @@ -129,152 +157,156 @@ type debug_info = string [@@deriving rpcty] (** The result of a successful call to the deprecated VDI.attach: this information (eg) can be used to connect a VBD backend to a VBD frontend *) type attach_info = { - params : string; - o_direct: bool; - o_direct_reason : string; - xenstore_data : (string * string) list; -} [@@deriving rpcty] + params: string + ; o_direct: bool + ; o_direct_reason: string + ; xenstore_data: (string * string) list +} +[@@deriving rpcty] type xendisk = { - params: string; (** Put into the "params" key in xenstore *) - - extra: (string * string) list; - (** Key-value pairs to be put into the "extra" subdirectory underneath the - xenstore backend *) - - backend_type: string; -} [@@deriving rpcty] - -type block_device = { - path: string; (** Path to the block device *) -} [@@deriving rpcty] - + params: string (** Put into the "params" key in xenstore *) + ; extra: (string * string) list + (** Key-value pairs to be put into the "extra" subdirectory underneath + the xenstore backend *) + ; backend_type: string +} +[@@deriving rpcty] -type file = { - path: string; (** Path to the raw file *) -} [@@deriving rpcty] +type block_device = {path: string (** Path to the block device *)} +[@@deriving rpcty] +type file = {path: string (** Path to the raw file *)} [@@deriving rpcty] type nbd = { - uri: string; - (** NBD URI of the form nbd:unix::exportname= (this - format is used by qemu-system: - https://manpages.debian.org/stretch/qemu-system-x86/qemu-system-x86_64.1.en.html) *) -} [@@deriving rpcty] - + uri: string + (** NBD URI of the form nbd:unix::exportname= (this + format is used by qemu-system: + https://manpages.debian.org/stretch/qemu-system-x86/qemu-system-x86_64.1.en.html) *) +} +[@@deriving rpcty] type implementation = | XenDisk of xendisk | BlockDevice of block_device | File of file - | Nbd of nbd [@@deriving rpcty] - -type backend = { - implementations: implementation list; -} [@@deriving rpcty] + | Nbd of nbd +[@@deriving rpcty] +type backend = {implementations: implementation list} [@@deriving rpcty] (** Extracts the UNIX domain socket path and the export name from the NBD URI in - the NBD information returned from the VDI.attach2 SMAPIv2 call. - This has the format nbd:unix::exportname= *) + the NBD information returned from the VDI.attach2 SMAPIv2 call. This has the + format nbd:unix::exportname= *) let parse_nbd_uri nbd = - let { uri } = nbd in + let {uri} = nbd in let fail () = - failwith ("Could not parse NBD URI returned from the storage backend: " ^ uri) + failwith + ("Could not parse NBD URI returned from the storage backend: " ^ uri) in match String.split_on_char ':' uri with - | ["nbd"; "unix"; socket; exportname] -> begin + | ["nbd"; "unix"; socket; exportname] -> ( let prefix = "exportname=" in - if not (Astring.String.is_prefix ~affix:prefix exportname) then fail (); + if not (Astring.String.is_prefix ~affix:prefix exportname) then fail () ; match Astring.String.cuts ~empty:false ~sep:prefix exportname with | [exportname] -> - (socket, exportname) - | _ -> fail () - end - | _ -> fail () + (socket, exportname) + | _ -> + fail () + ) + | _ -> + fail () -(** Separates the implementations of the given backend returned from - the VDI.attach2 SMAPIv2 call based on their type *) +(** Separates the implementations of the given backend returned from the + VDI.attach2 SMAPIv2 call based on their type *) let implementations_of_backend backend = List.fold_left (fun (xendisks, blockdevices, files, nbds) implementation -> - match implementation with - | XenDisk xendisk -> (xendisk::xendisks, blockdevices, files, nbds) - | BlockDevice blockdevice -> (xendisks, blockdevice::blockdevices, files, nbds) - | File file -> (xendisks, blockdevices, file::files, nbds) - | Nbd nbd -> (xendisks, blockdevices, files, nbd::nbds) - ) - ([], [], [], []) - backend.implementations + match implementation with + | XenDisk xendisk -> + (xendisk :: xendisks, blockdevices, files, nbds) + | BlockDevice blockdevice -> + (xendisks, blockdevice :: blockdevices, files, nbds) + | File file -> + (xendisks, blockdevices, file :: files, nbds) + | Nbd nbd -> + (xendisks, blockdevices, files, nbd :: nbds)) + ([], [], [], []) backend.implementations (** Uniquely identifies the contents of a VDI *) type content_id = string [@@deriving rpcty] - (** The result of an operation which creates or examines a VDI *) type vdi_info = { - vdi: Vdi.t; - uuid: string option [@default None]; - content_id: content_id [@default ""]; - name_label: string; - name_description: string [@default ""]; - ty: string [@default "user"]; - (* sm_config: workaround via XenAPI *) - metadata_of_pool: string [@default ""]; - is_a_snapshot: bool [@default false]; - snapshot_time: string [@default Xapi_stdext_date.Date.to_string Xapi_stdext_date.Date.never]; - snapshot_of: Vdi.t [@default (Vdi.of_string "")]; - (* managed: workaround via XenAPI *) - read_only: bool [@default false]; - cbt_enabled: bool [@default false]; - (* missing: workaround via XenAPI *) - virtual_size: int64 [@default 0L]; - physical_utilisation: int64 [@default 0L]; - (* xenstore_data: workaround via XenAPI *) - persistent: bool [@default true]; - sharable: bool [@default false]; - sm_config: (string * string) list [@default []]; -} [@@deriving rpcty] + vdi: Vdi.t + ; uuid: string option [@default None] + ; content_id: content_id [@default ""] + ; name_label: string + ; name_description: string [@default ""] + ; ty: string [@default "user"] + ; (* sm_config: workaround via XenAPI *) + metadata_of_pool: string [@default ""] + ; is_a_snapshot: bool [@default false] + ; snapshot_time: string + [@default Xapi_stdext_date.Date.to_string Xapi_stdext_date.Date.never] + ; snapshot_of: Vdi.t [@default Vdi.of_string ""] + ; (* managed: workaround via XenAPI *) + read_only: bool [@default false] + ; cbt_enabled: bool [@default false] + ; (* missing: workaround via XenAPI *) + virtual_size: int64 [@default 0L] + ; physical_utilisation: int64 [@default 0L] + ; (* xenstore_data: workaround via XenAPI *) + persistent: bool [@default true] + ; sharable: bool [@default false] + ; sm_config: (string * string) list [@default []] +} +[@@deriving rpcty] let default_vdi_info = match - Rpcmarshal.unmarshal - vdi_info.Rpc.Types.ty - Rpc.(Dict ["vdi",String ""; - "name_label",String "default"]) + Rpcmarshal.unmarshal vdi_info.Rpc.Types.ty + Rpc.(Dict [("vdi", String ""); ("name_label", String "default")]) with - | Ok x -> x | Error (`Msg m) -> failwith (Printf.sprintf "Error creating default_vdi_info: %s" m) + | Ok x -> + x + | Error (`Msg m) -> + failwith (Printf.sprintf "Error creating default_vdi_info: %s" m) type sr_health = Healthy | Recovering [@@deriving rpcty] type sr_info = { - sr_uuid: string option; - name_label: string; - name_description: string; - total_space: int64; (** total number of bytes on the storage substrate *) - free_space: int64; (** current free space on the storage substrate *) - clustered: bool; - health: sr_health; -} [@@deriving rpcty] - -let string_of_vdi_info (x: vdi_info) = Jsonrpc.to_string (rpc_of vdi_info x) - -(** Each VDI is associated with one or more "attached" or "activated" "datapaths". *) + sr_uuid: string option + ; name_label: string + ; name_description: string + ; total_space: int64 (** total number of bytes on the storage substrate *) + ; free_space: int64 (** current free space on the storage substrate *) + ; clustered: bool + ; health: sr_health +} +[@@deriving rpcty] + +let string_of_vdi_info (x : vdi_info) = Jsonrpc.to_string (rpc_of vdi_info x) + +(** Each VDI is associated with one or more "attached" or "activated" + "datapaths". *) type dp = string [@@deriving rpcty] type dp_stat_t = { - superstate: Vdi_automaton.state; - dps: (string * Vdi_automaton.state) list; -} [@@deriving rpcty] + superstate: Vdi_automaton.state + ; dps: (string * Vdi_automaton.state) list +} +[@@deriving rpcty] -let string_of_dp_stat_t (x: dp_stat_t) = Jsonrpc.to_string (rpc_of dp_stat_t x) +let string_of_dp_stat_t (x : dp_stat_t) = Jsonrpc.to_string (rpc_of dp_stat_t x) type probe = { - configuration: (string * string) list; - complete: bool; - sr: sr_info option; - extra_info: (string * string) list; -} [@@deriving rpcty] + configuration: (string * string) list + ; complete: bool + ; sr: sr_info option + ; extra_info: (string * string) list +} +[@@deriving rpcty] type probe_result = | Raw of string (* SMAPIv1 adapters return arbitrary data *) @@ -284,77 +316,55 @@ type probe_result = module Mirror = struct type id = string [@@deriving rpcty] - type state = - | Receiving - | Sending - | Copying - [@@deriving rpcty] + type state = Receiving | Sending | Copying [@@deriving rpcty] - type t = { - source_vdi : Vdi.t; - dest_vdi : Vdi.t; - state : state list; - failed : bool; - } [@@deriving rpcty] + type t = {source_vdi: Vdi.t; dest_vdi: Vdi.t; state: state list; failed: bool} + [@@deriving rpcty] type mirror_receive_result_vhd_t = { - mirror_vdi : vdi_info; - mirror_datapath : dp; - copy_diffs_from : content_id option; - copy_diffs_to : Vdi.t; - dummy_vdi : Vdi.t; - } [@@deriving rpcty] - - type mirror_receive_result = - | Vhd_mirror of mirror_receive_result_vhd_t + mirror_vdi: vdi_info + ; mirror_datapath: dp + ; copy_diffs_from: content_id option + ; copy_diffs_to: Vdi.t + ; dummy_vdi: Vdi.t + } + [@@deriving rpcty] + + type mirror_receive_result = Vhd_mirror of mirror_receive_result_vhd_t [@@deriving rpcty] type similars = content_id list [@@deriving rpcty] end -type async_result_t = - | Vdi_info of vdi_info - | Mirror_id of Mirror.id +type async_result_t = Vdi_info of vdi_info | Mirror_id of Mirror.id [@@deriving rpcty] - - module Task = struct - type id = string - [@@deriving rpcty] + type id = string [@@deriving rpcty] - type async_result = async_result_t - [@@deriving rpcty] + type async_result = async_result_t [@@deriving rpcty] - type completion_t = { - duration : float; - result : async_result option - } [@@deriving rpcty] + type completion_t = {duration: float; result: async_result option} + [@@deriving rpcty] - type state = - | Pending of float - | Completed of completion_t - | Failed of rpc_t + type state = Pending of float | Completed of completion_t | Failed of rpc_t [@@deriving rpcty] type t = { - id: id; - dbg: string; - ctime: float; - state: state; - subtasks: (string * state) list; - debug_info: (string * string) list; - backtrace: string; - cancellable: bool [@default false]; - } [@@deriving rpcty] + id: id + ; dbg: string + ; ctime: float + ; state: state + ; subtasks: (string * state) list + ; debug_info: (string * string) list + ; backtrace: string + ; cancellable: bool [@default false] + } + [@@deriving rpcty] end module Dynamic = struct - type id = - | Task of Task.id - | Vdi of Vdi.t - | Dp of dp - | Mirror of Mirror.id + type id = Task of Task.id | Vdi of Vdi.t | Dp of dp | Mirror of Mirror.id [@@deriving rpcty] type t = @@ -371,11 +381,15 @@ type uuid = string [@@deriving rpcty] module Errors = struct type error = - | Backend_error_with_backtrace of (string * (string list)) (** name * params *) - | Sr_not_attached of string (** error: SR must be attached to access VDIs *) - | Vdi_does_not_exist of string (** error: the VDI is unknown *) - | Illegal_transition of (Vdi_automaton.state * Vdi_automaton.state) (** This operation implies an illegal state transition *) - | Backend_error of (string * (string list)) (** error: of the form SR_BACKEND_FAILURE *) + | Backend_error_with_backtrace of (string * string list) + (** name * params *) + | Sr_not_attached of string + (** error: SR must be attached to access VDIs *) + | Vdi_does_not_exist of string (** error: the VDI is unknown *) + | Illegal_transition of (Vdi_automaton.state * Vdi_automaton.state) + (** This operation implies an illegal state transition *) + | Backend_error of (string * string list) + (** error: of the form SR_BACKEND_FAILURE *) | Does_not_exist of (string * string) | Cancelled of string | Redirect of string option @@ -387,7 +401,8 @@ module Errors = struct | Content_ids_do_not_match of (string * string) | Missing_configuration_parameter of string | Internal_error of string - | Unknown_error [@@default Unknown_error] [@@deriving rpcty] + | Unknown_error + [@@default Unknown_error] [@@deriving rpcty] end exception Storage_error of Errors.error @@ -400,80 +415,101 @@ let () = in let printer = function | Storage_error e -> - Some - (sprintf "Storage_error (%s)" (string_of_error e)) - | _ -> None + Some (sprintf "Storage_error (%s)" (string_of_error e)) + | _ -> + None in Printexc.register_printer printer let err = let open Idl.Error in - { def= Errors.error + { + def= Errors.error ; raiser= (fun e -> - let exn = Storage_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - raise exn ) + let exn = Storage_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) ; matcher= (function - | Storage_error e as exn -> + | Storage_error e as exn -> error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> + | exn -> error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - Some (Internal_error (Printexc.to_string exn))) } + Some (Internal_error (Printexc.to_string exn))) + } type query_result = { - driver: string; - name: string; - description: string; - vendor: string; - copyright: string; - version: string; - required_api_version: string; - features: string list; - configuration: (string * string) list; - required_cluster_stack: string list; -} [@@deriving rpcty] + driver: string + ; name: string + ; description: string + ; vendor: string + ; copyright: string + ; version: string + ; required_api_version: string + ; features: string list + ; configuration: (string * string) list + ; required_cluster_stack: string list +} +[@@deriving rpcty] module StorageAPI (R : RPC) = struct open R let description = let open Interface in - { name= "Storage" + { + name= "Storage" ; namespace= None - ; description= ["This interface is used by xapi to talk to the storage backends"] - ; version= (1, 0, 0) } + ; description= + ["This interface is used by xapi to talk to the storage backends"] + ; version= (1, 0, 0) + } let implementation = implement description let dbg_p = Param.mk ~name:"dbg" debug_info + let unit_p = Param.mk ~name:"unit" Types.unit + let sr_p = Param.mk ~name:"sr" Sr.t + let vdi_p = Param.mk ~name:"vdi" Vdi.t + let vm_p = Param.mk ~name:"vm" Vm.t + let dp_p = Param.mk ~name:"dp" dp - let device_config_p = Param.mk ~name:"device_config" ~description: - ["Backend-specific keys to specify the storage for the SR"] - TypeCombinators.(list (pair (Types.string,Types.string))) - let sm_config_p = Param.mk ~name:"sm_config" ~description: - ["Backend-private key-value pairs"] - TypeCombinators.(list (pair (Types.string,Types.string))) + + let device_config_p = + Param.mk ~name:"device_config" + ~description:["Backend-specific keys to specify the storage for the SR"] + TypeCombinators.(list (pair (Types.string, Types.string))) + + let sm_config_p = + Param.mk ~name:"sm_config" + ~description:["Backend-private key-value pairs"] + TypeCombinators.(list (pair (Types.string, Types.string))) + let new_name_label_p = Param.mk ~name:"new_name_label" Types.string - let new_name_description_p = Param.mk ~name:"new_name_description" Types.string + let new_name_description_p = + Param.mk ~name:"new_name_description" Types.string module Query = struct (** [query ()] returns information about this storage driver *) let query = let query_result_p = Param.mk ~name:"query_result" query_result in - declare "Query.query" ["Query the SM backend"] (dbg_p @-> returning query_result_p err) + declare "Query.query" ["Query the SM backend"] + (dbg_p @-> returning query_result_p err) - (** [diagnostics ()] returns diagnostic information about this storage driver *) + (** [diagnostics ()] returns diagnostic information about this storage + driver *) let diagnostics = let result_p = Param.mk Types.string in - declare "Query.diagnostics" ["Get diagnostic info from the SM backend"] (dbg_p @-> returning result_p err) + declare "Query.diagnostics" + ["Get diagnostic info from the SM backend"] + (dbg_p @-> returning result_p err) end module DP = struct @@ -481,89 +517,123 @@ module StorageAPI (R : RPC) = struct let create = let id_p = Param.mk ~name:"id" Types.string in - declare - "DP.create" + declare "DP.create" ["[DP.create dbg id]: creates and returns a dp"] (dbg_p @-> id_p @-> returning dp_p err) let destroy = let allow_leak_p = Param.mk ~name:"allow_leak" Types.bool in - declare - "DP.destroy" - ["[DP.destroy dbg id]: frees any resources associated with [id] and destroys it."; - "This will typically do any needed VDI.detach, VDI.deactivate cleanup."] + declare "DP.destroy" + [ + "[DP.destroy dbg id]: frees any resources associated with [id] and \ + destroys it." + ; "This will typically do any needed VDI.detach, VDI.deactivate \ + cleanup." + ] (dbg_p @-> dp_p @-> allow_leak_p @-> returning unit_p err) - let attach_info = let backend_p = Param.mk ~name:"backend" backend in - declare - "DP.attach_info" - ["[DP.attach_info sr vdi dp]: returns the params of the dp (the return value of VDI.attach2)"] + declare "DP.attach_info" + [ + "[DP.attach_info sr vdi dp]: returns the params of the dp (the \ + return value of VDI.attach2)" + ] (dbg_p @-> sr_p @-> vdi_p @-> dp_p @-> returning backend_p err) (** *) let diagnostics = let diagnostics_p = Param.mk ~name:"diagnostics" Types.string in - declare - "DP.diagnostics" - ["[DP.diagnostics ()]: returns a printable set of diagnostic information,"; - "typically including lists of all registered datapaths and their allocated"; - "resources."] + declare "DP.diagnostics" + [ + "[DP.diagnostics ()]: returns a printable set of diagnostic \ + information," + ; "typically including lists of all registered datapaths and their \ + allocated" + ; "resources." + ] (unit_p @-> returning diagnostics_p err) let stat_vdi = let dp_stat_p = Param.mk ~name:"dp_stat" dp_stat_t in - declare "DP.stat_vdi" ["[DP.stat_vdi task sr vdi ()] returns the state of the given VDI from the point of view of each dp as well as the overall superstate."] (dbg_p @-> sr_p @-> vdi_p @-> unit_p @-> returning dp_stat_p err) + declare "DP.stat_vdi" + [ + "[DP.stat_vdi task sr vdi ()] returns the state of the given VDI \ + from the point of view of each dp as well as the overall \ + superstate." + ] + (dbg_p @-> sr_p @-> vdi_p @-> unit_p @-> returning dp_stat_p err) end module SR = struct (** Functions which manipulate SRs *) let create = - let name_label_p = Param.mk ~name:"name_label" ~description: - ["Human-readable name for the SR"] Types.string + let name_label_p = + Param.mk ~name:"name_label" + ~description:["Human-readable name for the SR"] + Types.string in - let name_description_p = Param.mk ~name:"name_description" ~description: - ["Human-readable description for the SR"] Types.string + let name_description_p = + Param.mk ~name:"name_description" + ~description:["Human-readable description for the SR"] + Types.string in let size_p = Param.mk ~name:"physical_size" Types.int64 in declare "SR.create" - ["[SR.create dbg sr name description device_config physical_size]: creates a fresh SR"] - (dbg_p @-> sr_p @-> name_label_p @-> name_description_p @-> device_config_p @-> size_p @-> returning device_config_p err) - + [ + "[SR.create dbg sr name description device_config physical_size]: \ + creates a fresh SR" + ] + (dbg_p + @-> sr_p + @-> name_label_p + @-> name_description_p + @-> device_config_p + @-> size_p + @-> returning device_config_p err + ) (** [set_name_label sr new_name_label] updates the name_label of SR [sr]. *) let set_name_label = - declare "SR.set_name_label" [] (dbg_p @-> sr_p @-> new_name_label_p @-> returning unit_p err) + declare "SR.set_name_label" [] + (dbg_p @-> sr_p @-> new_name_label_p @-> returning unit_p err) - (** [set_name_description sr new_name_description] updates the name_description of SR [sr]. *) + (** [set_name_description sr new_name_description] updates the + name_description of SR [sr]. *) let set_name_description = - declare "SR.set_name_description" [] (dbg_p @-> sr_p @-> new_name_description_p @-> returning unit_p err) + declare "SR.set_name_description" [] + (dbg_p @-> sr_p @-> new_name_description_p @-> returning unit_p err) - (** [probe dbg queue device_config sm_config] searches on the storage device for SRs of queue [queue] *) + (** [probe dbg queue device_config sm_config] searches on the storage device + for SRs of queue [queue] *) let probe = let queue_p = Param.mk ~name:"queue" Types.string in let probe_result_p = Param.mk ~name:"result" probe_result in - declare "SR.probe" [] (dbg_p @-> queue_p @-> device_config_p @-> sm_config_p @-> returning probe_result_p err) + declare "SR.probe" [] + (dbg_p + @-> queue_p + @-> device_config_p + @-> sm_config_p + @-> returning probe_result_p err + ) (** [attach task sr]: attaches the SR *) let attach = - declare "SR.attach" [] (dbg_p @-> sr_p @-> device_config_p @-> returning unit_p err) + declare "SR.attach" [] + (dbg_p @-> sr_p @-> device_config_p @-> returning unit_p err) - (** [detach task sr]: detaches the SR, first detaching and/or deactivating any - active VDIs. This may fail with Sr_not_attached, or any error from VDI.detach - or VDI.deactivate. *) - let detach = - declare "SR.detach" [] (dbg_p @-> sr_p @-> returning unit_p err) + (** [detach task sr]: detaches the SR, first detaching and/or deactivating + any active VDIs. This may fail with Sr_not_attached, or any error from + VDI.detach or VDI.deactivate. *) + let detach = declare "SR.detach" [] (dbg_p @-> sr_p @-> returning unit_p err) (** [reset task sr]: declares that the SR has been completely reset, e.g. by - rebooting the VM hosting the SR backend. *) - let reset = - declare "SR.reset" [] (dbg_p @-> sr_p @-> returning unit_p err) + rebooting the VM hosting the SR backend. *) + let reset = declare "SR.reset" [] (dbg_p @-> sr_p @-> returning unit_p err) - (** [destroy sr]: destroys (i.e. makes unattachable and unprobeable) the [sr], - first detaching and/or deactivating any active VDIs. This may fail with - Sr_not_attached, or any error from VDI.detach or VDI.deactivate. *) + (** [destroy sr]: destroys (i.e. makes unattachable and unprobeable) the + [sr], first detaching and/or deactivating any active VDIs. This may fail + with Sr_not_attached, or any error from VDI.detach or VDI.deactivate. *) let destroy = declare "SR.destroy" [] (dbg_p @-> sr_p @-> returning unit_p err) @@ -573,27 +643,47 @@ module StorageAPI (R : RPC) = struct let result = Param.mk ~name:"result" (list vdi_info) in declare "SR.scan" [] (dbg_p @-> sr_p @-> returning result err) - (** [update_snapshot_info_src sr vdi url dest dest_vdi snapshot_pairs] - * updates the fields is_a_snapshot, snapshot_time and snapshot_of for a - * list of snapshots on a remote SR. *) + (** [update_snapshot_info_src sr vdi url dest dest_vdi snapshot_pairs] * + updates the fields is_a_snapshot, snapshot_time and snapshot_of for a * + list of snapshots on a remote SR. *) let update_snapshot_info_src = let url_p = Param.mk ~name:"url" Types.string in let dest_p = Param.mk ~name:"dest" Sr.t in let dest_vdi_p = Param.mk ~name:"dest_vdi" Vdi.t in - let snapshot_pairs_p = Param.mk ~name:"snapshot_pairs" TypeCombinators.(list (pair (Vdi.t, Vdi.t))) in + let snapshot_pairs_p = + Param.mk ~name:"snapshot_pairs" + TypeCombinators.(list (pair (Vdi.t, Vdi.t))) + in declare "SR.update_snapshot_info_src" [] - (dbg_p @-> sr_p @-> vdi_p @-> url_p @-> dest_p @-> dest_vdi_p @-> snapshot_pairs_p @-> returning unit_p err) - - (** [update_snapshot_info_dest sr vdi dest src_vdi snapshot_pairs] - * updates the fields is_a_snapshot, snapshot_time and snapshot_of for a - * list of snapshots on a local SR. Typically, vdi will be a mirror of - * src_vdi, and for each item in snapshot_pairs the first will be a copy - * of the second. *) + (dbg_p + @-> sr_p + @-> vdi_p + @-> url_p + @-> dest_p + @-> dest_vdi_p + @-> snapshot_pairs_p + @-> returning unit_p err + ) + + (** [update_snapshot_info_dest sr vdi dest src_vdi snapshot_pairs] * updates + the fields is_a_snapshot, snapshot_time and snapshot_of for a * list of + snapshots on a local SR. Typically, vdi will be a mirror of * src_vdi, + and for each item in snapshot_pairs the first will be a copy * of the + second. *) let update_snapshot_info_dest = let src_vdi_p = Param.mk ~name:"src_vdi" vdi_info in - let snapshot_pairs_p = Param.mk ~name:"snapshot_pairs" TypeCombinators.(list (pair (Vdi.t, vdi_info))) in + let snapshot_pairs_p = + Param.mk ~name:"snapshot_pairs" + TypeCombinators.(list (pair (Vdi.t, vdi_info))) + in declare "SR.update_snapshot_info_dest" [] - (dbg_p @-> sr_p @-> vdi_p @-> src_vdi_p @-> snapshot_pairs_p @-> returning unit_p err) + (dbg_p + @-> sr_p + @-> vdi_p + @-> src_vdi_p + @-> snapshot_pairs_p + @-> returning unit_p err + ) (** [stat task sr] returns instantaneous SR-level statistics *) let stat = @@ -607,207 +697,315 @@ module StorageAPI (R : RPC) = struct end module VDI = struct - (** Functions which operate on particular VDIs. - These functions are all idempotent from the point of view of a given [dp]. *) + (** Functions which operate on particular VDIs. These functions are all + idempotent from the point of view of a given [dp]. *) let vdi_info_p = Param.mk ~name:"vdi_info" vdi_info - (** [create task sr vdi_info] creates a new VDI in [sr] using [vdi_info]. Some - fields in the [vdi_info] may be modified (e.g. rounded up), so the function - returns the vdi_info which was used. *) + (** [create task sr vdi_info] creates a new VDI in [sr] using [vdi_info]. + Some fields in the [vdi_info] may be modified (e.g. rounded up), so the + function returns the vdi_info which was used. *) let create = - declare "VDI.create" [] (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) + declare "VDI.create" [] + (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) - (** [set_name_label sr vdi new_name_label] updates the name_label of VDI [vdi] in SR [sr]. *) + (** [set_name_label sr vdi new_name_label] updates the name_label of VDI + [vdi] in SR [sr]. *) let set_name_label = - declare "VDI.set_name_label" [] (dbg_p @-> sr_p @-> vdi_p @-> new_name_label_p @-> returning unit_p err) + declare "VDI.set_name_label" [] + (dbg_p @-> sr_p @-> vdi_p @-> new_name_label_p @-> returning unit_p err) - (** [set_name_description sr vdi new_name_description] updates the name_description of VDI [vdi] in SR [sr]. *) + (** [set_name_description sr vdi new_name_description] updates the + name_description of VDI [vdi] in SR [sr]. *) let set_name_description = - declare "VDI.set_name_description" [] (dbg_p @-> sr_p @-> vdi_p @-> new_name_description_p @-> returning unit_p err) - - (** [snapshot task sr vdi_info] creates a new VDI which is a snapshot of [vdi_info] in [sr] *) + declare "VDI.set_name_description" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> new_name_description_p + @-> returning unit_p err + ) + + (** [snapshot task sr vdi_info] creates a new VDI which is a snapshot of + [vdi_info] in [sr] *) let snapshot = - declare "VDI.snapshot" [] (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) + declare "VDI.snapshot" [] + (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) - (** [clone task sr vdi_info] creates a new VDI which is a clone of [vdi_info] in [sr] *) + (** [clone task sr vdi_info] creates a new VDI which is a clone of + [vdi_info] in [sr] *) let clone = - declare "VDI.clone" [] (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) + declare "VDI.clone" [] + (dbg_p @-> sr_p @-> vdi_info_p @-> returning vdi_info_p err) - (** [resize task sr vdi new_size] makes a VDI's virtual_size at least [new_size] bytes. - The function returns the new virtual_size which may be bigger (but not less than) - requested. *) + (** [resize task sr vdi new_size] makes a VDI's virtual_size at least + [new_size] bytes. The function returns the new virtual_size which may be + bigger (but not less than) requested. *) let resize = let new_size_p = Param.mk ~name:"new_size" Types.int64 in - declare "VDI.resize" [] (dbg_p @-> sr_p @-> vdi_p @-> new_size_p @-> returning new_size_p err) + declare "VDI.resize" [] + (dbg_p @-> sr_p @-> vdi_p @-> new_size_p @-> returning new_size_p err) (** [destroy task sr vdi] removes [vdi] from [sr] *) let destroy = - declare "VDI.destroy" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.destroy" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) (** [stat dbg sr vdi] returns information about VDI [vdi] in SR [sr] *) let stat = - declare "VDI.stat" [] (dbg_p @-> sr_p @-> vdi_p @-> returning vdi_info_p err) + declare "VDI.stat" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning vdi_info_p err) - (** [introduce dbg sr uuid sm_config location] checks that a VDI exists and returns info about it *) + (** [introduce dbg sr uuid sm_config location] checks that a VDI exists and + returns info about it *) let introduce = let uuid_p = Param.mk ~name:"uuid" Types.string in let location_p = Param.mk ~name:"location" Types.string in - declare "VDI.introduce" [] (dbg_p @-> sr_p @-> uuid_p @-> sm_config_p @-> location_p @-> returning vdi_info_p err) + declare "VDI.introduce" [] + (dbg_p + @-> sr_p + @-> uuid_p + @-> sm_config_p + @-> location_p + @-> returning vdi_info_p err + ) let persistent_p = Param.mk ~name:"persistent" Types.bool - (** [set_persistent dbg sr vdi persistent] sets [vdi]'s persistent flag to [persistent] *) + (** [set_persistent dbg sr vdi persistent] sets [vdi]'s persistent flag to + [persistent] *) let set_persistent = - declare "VDI.set_persistent" [] (dbg_p @-> sr_p @-> vdi_p @-> persistent_p @-> returning unit_p err) + declare "VDI.set_persistent" [] + (dbg_p @-> sr_p @-> vdi_p @-> persistent_p @-> returning unit_p err) - (** [epoch_begin sr vdi persistent] declares that [vdi] is about to be added to a starting/rebooting VM. - This is not called over suspend/resume or migrate. - If [persistent] is false, then changes to the disk will be erased when the VM shuts down. *) + (** [epoch_begin sr vdi persistent] declares that [vdi] is about to be added + to a starting/rebooting VM. This is not called over suspend/resume or + migrate. If [persistent] is false, then changes to the disk will be + erased when the VM shuts down. *) let epoch_begin = - declare "VDI.epoch_begin" [] (dbg_p @-> sr_p @-> vdi_p @-> vm_p @-> persistent_p @-> returning unit_p err) + declare "VDI.epoch_begin" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> vm_p + @-> persistent_p + @-> returning unit_p err + ) let read_write_p = Param.mk ~name:"read_write" Types.bool (** [attach task dp sr vdi read_write] returns the [params] for a given - [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] - is true. - @deprecated This function is deprecated, and is only here to keep backward - compatibility with old xapis that call Remote.VDI.attach during SXM. - Use the attach3 function instead. *) + [vdi] in [sr] which can be written to if (but not necessarily only if) + [read_write] is true. @deprecated This function is deprecated, and is + only here to keep backward compatibility with old xapis that call + Remote.VDI.attach during SXM. Use the attach3 function instead. *) let attach = let attach_info_p = Param.mk ~name:"attach_info" attach_info in - declare "VDI.attach" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> read_write_p @-> returning attach_info_p err) + declare "VDI.attach" [] + (dbg_p + @-> dp_p + @-> sr_p + @-> vdi_p + @-> read_write_p + @-> returning attach_info_p err + ) (** [attach2 task dp sr vdi read_write] returns the [params] for a given - [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] - is true. - @deprecated This function is deprecated, and is only here to keep backward - compatibility with old xapis that call Remote.VDI.attach2 during SXM. - Use the attach3 function instead. *) + [vdi] in [sr] which can be written to if (but not necessarily only if) + [read_write] is true. @deprecated This function is deprecated, and is + only here to keep backward compatibility with old xapis that call + Remote.VDI.attach2 during SXM. Use the attach3 function instead. *) let attach2 = let backend_p = Param.mk ~name:"backend" backend in - declare "VDI.attach2" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> read_write_p @-> returning backend_p err) + declare "VDI.attach2" [] + (dbg_p + @-> dp_p + @-> sr_p + @-> vdi_p + @-> read_write_p + @-> returning backend_p err + ) (** [attach3 task dp sr vdi read_write] returns the [params] for a given - [vdi] in [sr] which can be written to if (but not necessarily only if) [read_write] - is true *) + [vdi] in [sr] which can be written to if (but not necessarily only if) + [read_write] is true *) let attach3 = let backend_p = Param.mk ~name:"backend" backend in - declare "VDI.attach3" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> read_write_p @-> returning backend_p err) + declare "VDI.attach3" [] + (dbg_p + @-> dp_p + @-> sr_p + @-> vdi_p + @-> vm_p + @-> read_write_p + @-> returning backend_p err + ) (** [activate task dp sr vdi] signals the desire to immediately use [vdi]. - This client must have called [attach] on the [vdi] first. - @deprecated This function is deprecated, and is only here to keep backward + This client must have called [attach] on the [vdi] first. @deprecated + This function is deprecated, and is only here to keep backward compatibility with old xapis that call Remote.VDI.activate during SXM. Use the activate3 function instead. *) let activate = - declare "VDI.activate" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.activate" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> returning unit_p err) (** [activate3 task dp sr vdi] signals the desire to immediately use [vdi]. - This client must have called [attach] on the [vdi] first. *) + This client must have called [attach] on the [vdi] first. *) let activate3 = - declare "VDI.activate3" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.activate3" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [deactivate task dp sr vdi] signals that this client has stopped reading (and writing) - [vdi]. *) + (** [deactivate task dp sr vdi] signals that this client has stopped reading + (and writing) [vdi]. *) let deactivate = - declare "VDI.deactivate" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.deactivate" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [detach task dp sr vdi] signals that this client no-longer needs the [attach_info] - to be valid. *) + (** [detach task dp sr vdi] signals that this client no-longer needs the + [attach_info] to be valid. *) let detach = - declare "VDI.detach" [] (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.detach" [] + (dbg_p @-> dp_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [epoch_end sr vdi] declares that [vdi] is about to be removed from a shutting down/rebooting VM. - This is not called over suspend/resume or migrate. *) + (** [epoch_end sr vdi] declares that [vdi] is about to be removed from a + shutting down/rebooting VM. This is not called over suspend/resume or + migrate. *) let epoch_end = - declare "VDI.epoch_end" [] (dbg_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) + declare "VDI.epoch_end" [] + (dbg_p @-> sr_p @-> vdi_p @-> vm_p @-> returning unit_p err) - (** [get_url task sr vdi] returns a URL suitable for accessing disk data directly. *) + (** [get_url task sr vdi] returns a URL suitable for accessing disk data + directly. *) let get_url = let result_p = Param.mk ~name:"url" Types.string in - declare "VDI.get_url" [] (dbg_p @-> sr_p @-> vdi_p @-> returning result_p err) + declare "VDI.get_url" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning result_p err) - (** [similar_content task sr vdi] returns a list of VDIs which have similar content to [vdi] *) + (** [similar_content task sr vdi] returns a list of VDIs which have similar + content to [vdi] *) let similar_content = let result = Param.mk ~name:"vdis" TypeCombinators.(list vdi_info) in - declare "VDI.similar_content" [] (dbg_p @-> sr_p @-> vdi_p @-> returning result err) + declare "VDI.similar_content" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning result err) (** [get_by_name task sr name] returns the vdi within [sr] with [name] *) let get_by_name = let name_p = Param.mk ~name:"name" Types.string in - declare "VDI.get_by_name" [] (dbg_p @-> sr_p @-> name_p @-> returning vdi_info_p err) + declare "VDI.get_by_name" [] + (dbg_p @-> sr_p @-> name_p @-> returning vdi_info_p err) - (** [set_content_id task sr vdi content_id] tells the storage backend that a VDI has an updated [content_id] *) + (** [set_content_id task sr vdi content_id] tells the storage backend that a + VDI has an updated [content_id] *) let set_content_id = let content_id_p = Param.mk ~name:"content_id" content_id in - declare "VDI.set_content_id" [] (dbg_p @-> sr_p @-> vdi_p @-> content_id_p @-> returning unit_p err) + declare "VDI.set_content_id" [] + (dbg_p @-> sr_p @-> vdi_p @-> content_id_p @-> returning unit_p err) - (** [compose task sr vdi1 vdi2] layers the updates from [vdi2] onto [vdi1], modifying [vdi2] *) + (** [compose task sr vdi1 vdi2] layers the updates from [vdi2] onto [vdi1], + modifying [vdi2] *) let compose = let vdi1_p = Param.mk ~name:"vdi1" Vdi.t in let vdi2_p = Param.mk ~name:"vdi2" Vdi.t in - declare "VDI.compose" [] (dbg_p @-> sr_p @-> vdi1_p @-> vdi2_p @-> returning unit_p err) + declare "VDI.compose" [] + (dbg_p @-> sr_p @-> vdi1_p @-> vdi2_p @-> returning unit_p err) let key_p = Param.mk ~name:"key" Types.string + let value_p = Param.mk ~name:"value" Types.string - (** [add_to_sm_config dbg sr vdi key value] associates [value] to the [key] in [vdi] sm-config *) + (** [add_to_sm_config dbg sr vdi key value] associates [value] to the [key] + in [vdi] sm-config *) let add_to_sm_config = - declare "VDI.add_to_sm_config" [] (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> value_p @-> returning unit_p err) + declare "VDI.add_to_sm_config" [] + (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> value_p @-> returning unit_p err) (** [remove_from_sm_config dbg sr vdi key] remove [key] from [vdi] sm-config *) let remove_from_sm_config = - declare "VDI.remove_from_sm_config" [] (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> returning unit_p err) + declare "VDI.remove_from_sm_config" [] + (dbg_p @-> sr_p @-> vdi_p @-> key_p @-> returning unit_p err) (** [enable_cbt dbg sr vdi] enables changed block tracking for [vdi] *) let enable_cbt = - declare "VDI.enable_cbt" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.enable_cbt" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) (** [disable_cbt dbg sr vdi] disables changed block tracking for [vdi] *) let disable_cbt = - declare "VDI.disable_cbt" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.disable_cbt" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) - (** [data_destroy dbg sr vdi] deletes the data of the snapshot [vdi] without deleting its changed block tracking metadata *) + (** [data_destroy dbg sr vdi] deletes the data of the snapshot [vdi] without + deleting its changed block tracking metadata *) let data_destroy = - declare "VDI.data_destroy" [] (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) + declare "VDI.data_destroy" [] + (dbg_p @-> sr_p @-> vdi_p @-> returning unit_p err) - (** [list_changed_blocks dbg sr vdi_from vdi_to] returns the blocks that have changed between [vdi_from] and [vdi_to] as a base64-encoded bitmap string *) + (** [list_changed_blocks dbg sr vdi_from vdi_to] returns the blocks that + have changed between [vdi_from] and [vdi_to] as a base64-encoded bitmap + string *) let list_changed_blocks = let vdi_from_p = Param.mk ~name:"vdi_from" Vdi.t in let vdi_to_p = Param.mk ~name:"vdi_tp" Vdi.t in let result_p = Param.mk ~name:"changed_blocks" Types.string in - declare "VDI.list_changed_blocks" [] (dbg_p @-> sr_p @-> vdi_from_p @-> vdi_to_p @-> returning result_p err) - + declare "VDI.list_changed_blocks" [] + (dbg_p @-> sr_p @-> vdi_from_p @-> vdi_to_p @-> returning result_p err) end (** [get_by_name task name] returns a vdi with [name] (which may be in any SR) *) let get_by_name = let name_p = Param.mk ~name:"name" Types.string in - let result_p = Param.mk ~name:"result" TypeCombinators.(pair (Sr.t, vdi_info)) in + let result_p = + Param.mk ~name:"result" TypeCombinators.(pair (Sr.t, vdi_info)) + in declare "get_by_name" [] (dbg_p @-> name_p @-> returning result_p err) module DATA = struct - let url_p = Param.mk ~name:"url" Types.string + let dest_p = Param.mk ~name:"dest" Sr.t + let task_id_p = Param.mk ~name:"task_id" Task.id - (** [copy_into task sr vdi url sr2] copies the data from [vdi] into a remote system [url]'s [sr2] *) + (** [copy_into task sr vdi url sr2] copies the data from [vdi] into a remote + system [url]'s [sr2] *) let copy_into = let dest_vdi_p = Param.mk ~name:"dest_vdi" Vdi.t in - declare "DATA.copy_into" [] (dbg_p @-> sr_p @-> vdi_p @-> url_p @-> dest_p @-> dest_vdi_p @-> returning task_id_p err) + declare "DATA.copy_into" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> url_p + @-> dest_p + @-> dest_vdi_p + @-> returning task_id_p err + ) let copy = let result_p = Param.mk ~name:"task_id" Task.id in - declare "DATA.copy" [] (dbg_p @-> sr_p @-> vdi_p @-> dp_p @-> url_p @-> dest_p @-> returning result_p err) + declare "DATA.copy" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> dp_p + @-> url_p + @-> dest_p + @-> returning result_p err + ) module MIRROR = struct - (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and writes - data synchronously. It returns the id of the VDI.*) + (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and + writes data synchronously. It returns the id of the VDI.*) let start = - declare "DATA.MIRROR.start" [] (dbg_p @-> sr_p @-> vdi_p @-> dp_p @-> url_p @-> dest_p @-> returning task_id_p err) + declare "DATA.MIRROR.start" [] + (dbg_p + @-> sr_p + @-> vdi_p + @-> dp_p + @-> url_p + @-> dest_p + @-> returning task_id_p err + ) let id_p = Param.mk ~name:"id" Mirror.id @@ -823,27 +1021,37 @@ module StorageAPI (R : RPC) = struct let receive_start = let similar_p = Param.mk ~name:"similar" Mirror.similars in let result = Param.mk ~name:"result" Mirror.mirror_receive_result in - declare "DATA.MIRROR.receive_start" [] (dbg_p @-> sr_p @-> VDI.vdi_info_p @-> id_p @-> similar_p @-> returning result err) + declare "DATA.MIRROR.receive_start" [] + (dbg_p + @-> sr_p + @-> VDI.vdi_info_p + @-> id_p + @-> similar_p + @-> returning result err + ) let receive_finalize = - declare "DATA.MIRROR.receive_finalize" [] (dbg_p @-> id_p @-> returning unit_p err) + declare "DATA.MIRROR.receive_finalize" [] + (dbg_p @-> id_p @-> returning unit_p err) let receive_cancel = - declare "DATA.MIRROR.receive_cancel" [] (dbg_p @-> id_p @-> returning unit_p err) + declare "DATA.MIRROR.receive_cancel" [] + (dbg_p @-> id_p @-> returning unit_p err) let list = - let result_p = Param.mk ~name:"mirrors" TypeCombinators.(list (pair Mirror.(id, t))) in + let result_p = + Param.mk ~name:"mirrors" TypeCombinators.(list (pair Mirror.(id, t))) + in declare "DATA.MIRROR.list" [] (dbg_p @-> returning result_p err) end - - end module Policy = struct let get_backend_vm = let vm_p = Param.mk ~name:"vm" Types.string in let result_p = Param.mk ~name:"result" Types.string in - declare "Policy.get_backend_vm" [] (dbg_p @-> vm_p @-> sr_p @-> vdi_p @-> returning result_p err) + declare "Policy.get_backend_vm" [] + (dbg_p @-> vm_p @-> sr_p @-> vdi_p @-> returning result_p err) end module TASK = struct @@ -867,459 +1075,439 @@ module StorageAPI (R : RPC) = struct module UPDATES = struct let get = let from_p = Param.mk ~name:"from" Types.string in - let timeout_p = Param.mk ~name:"timeout" TypeCombinators.(option Types.int) in - let result_p = Param.mk ~name:"updates" TypeCombinators.(pair (list Dynamic.id, Types.string)) in - declare "UPDATES.get" [] (dbg_p @-> from_p @-> timeout_p @-> returning result_p err) + let timeout_p = + Param.mk ~name:"timeout" TypeCombinators.(option Types.int) + in + let result_p = + Param.mk ~name:"updates" + TypeCombinators.(pair (list Dynamic.id, Types.string)) + in + declare "UPDATES.get" [] + (dbg_p @-> from_p @-> timeout_p @-> returning result_p err) end end -module type Server_impl = -sig +module type Server_impl = sig type context = unit - module Query : - sig - val query : context -> dbg: string -> query_result - - val diagnostics : context -> dbg: string -> string + module Query : sig + val query : context -> dbg:string -> query_result + val diagnostics : context -> dbg:string -> string end - module DP : - sig - val create : context -> dbg: debug_info -> id: string -> dp + module DP : sig + val create : context -> dbg:debug_info -> id:string -> dp - val destroy : - context -> dbg: debug_info -> dp: dp -> allow_leak: bool -> unit + val destroy : context -> dbg:debug_info -> dp:dp -> allow_leak:bool -> unit val attach_info : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> dp: dp -> backend + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> dp:dp -> backend val diagnostics : context -> unit -> string val stat_vdi : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> unit -> dp_stat_t - + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit -> dp_stat_t end - module SR : - sig + module SR : sig val create : - context -> - dbg: debug_info -> - sr: sr -> - name_label: string -> - name_description: string -> - device_config: ((string * string) list) -> - physical_size: int64 -> (string * string) list + context + -> dbg:debug_info + -> sr:sr + -> name_label:string + -> name_description:string + -> device_config:(string * string) list + -> physical_size:int64 + -> (string * string) list val set_name_label : - context -> - dbg: debug_info -> sr: sr -> new_name_label: string -> unit + context -> dbg:debug_info -> sr:sr -> new_name_label:string -> unit val set_name_description : - context -> - dbg: debug_info -> sr: sr -> new_name_description: string -> unit + context -> dbg:debug_info -> sr:sr -> new_name_description:string -> unit val probe : - context -> - dbg: debug_info -> - queue: string -> - device_config: ((string * string) list) -> - sm_config: ((string * string) list) -> probe_result + context + -> dbg:debug_info + -> queue:string + -> device_config:(string * string) list + -> sm_config:(string * string) list + -> probe_result val attach : - context -> - dbg: debug_info -> - sr: sr -> device_config: ((string * string) list) -> unit + context + -> dbg:debug_info + -> sr:sr + -> device_config:(string * string) list + -> unit - val detach : context -> dbg: debug_info -> sr: sr -> unit + val detach : context -> dbg:debug_info -> sr:sr -> unit - val reset : context -> dbg: debug_info -> sr: sr -> unit + val reset : context -> dbg:debug_info -> sr:sr -> unit - val destroy : context -> dbg: debug_info -> sr: sr -> unit + val destroy : context -> dbg:debug_info -> sr:sr -> unit - val scan : context -> dbg: debug_info -> sr: sr -> vdi_info list + val scan : context -> dbg:debug_info -> sr:sr -> vdi_info list val update_snapshot_info_src : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> - url: string -> - dest: sr -> - dest_vdi: vdi -> - snapshot_pairs: ((vdi * vdi) list) -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> url:string + -> dest:sr + -> dest_vdi:vdi + -> snapshot_pairs:(vdi * vdi) list + -> unit val update_snapshot_info_dest : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> - src_vdi: vdi_info -> - snapshot_pairs: ((vdi * vdi_info) list) -> unit - - val stat : context -> dbg: debug_info -> sr: sr -> sr_info + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> src_vdi:vdi_info + -> snapshot_pairs:(vdi * vdi_info) list + -> unit - val list : context -> dbg: debug_info -> sr list + val stat : context -> dbg:debug_info -> sr:sr -> sr_info + val list : context -> dbg:debug_info -> sr list end - module VDI : - sig + module VDI : sig val create : - context -> - dbg: debug_info -> sr: sr -> vdi_info: vdi_info -> vdi_info + context -> dbg:debug_info -> sr:sr -> vdi_info:vdi_info -> vdi_info val set_name_label : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> new_name_label: string -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> new_name_label:string + -> unit val set_name_description : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> new_name_description: string -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> new_name_description:string + -> unit val snapshot : - context -> - dbg: debug_info -> sr: sr -> vdi_info: vdi_info -> vdi_info + context -> dbg:debug_info -> sr:sr -> vdi_info:vdi_info -> vdi_info val clone : - context -> - dbg: debug_info -> sr: sr -> vdi_info: vdi_info -> vdi_info + context -> dbg:debug_info -> sr:sr -> vdi_info:vdi_info -> vdi_info val resize : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> new_size: int64 -> int64 + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> new_size:int64 -> int64 - val destroy : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val destroy : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit - val stat : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> vdi_info + val stat : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> vdi_info val introduce : - context -> - dbg: debug_info -> - sr: sr -> - uuid: string -> - sm_config: ((string * string) list) -> - location: string -> vdi_info + context + -> dbg:debug_info + -> sr:sr + -> uuid:string + -> sm_config:(string * string) list + -> location:string + -> vdi_info val set_persistent : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> persistent: bool -> unit + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> persistent:bool -> unit val epoch_begin : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> vm: vm -> persistent: bool -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> vm:vm + -> persistent:bool + -> unit val attach : - context -> - dbg: debug_info -> - dp: dp -> sr: sr -> vdi: vdi -> read_write: bool -> attach_info + context + -> dbg:debug_info + -> dp:dp + -> sr:sr + -> vdi:vdi + -> read_write:bool + -> attach_info val attach2 : - context -> - dbg: debug_info -> - dp: dp -> sr: sr -> vdi: vdi -> read_write: bool -> backend + context + -> dbg:debug_info + -> dp:dp + -> sr:sr + -> vdi:vdi + -> read_write:bool + -> backend val attach3 : - context -> - dbg: debug_info -> - dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> read_write: bool -> backend + context + -> dbg:debug_info + -> dp:dp + -> sr:sr + -> vdi:vdi + -> vm:vm + -> read_write:bool + -> backend val activate : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> unit val activate3 : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> unit val deactivate : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> unit val detach : - context -> dbg: debug_info -> dp: dp -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> unit val epoch_end : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> vm: vm -> unit + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> vm:vm -> unit - val get_url : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> string + val get_url : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> string val similar_content : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> vdi_info list + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> vdi_info list val get_by_name : - context -> dbg: debug_info -> sr: sr -> name: string -> vdi_info + context -> dbg:debug_info -> sr:sr -> name:string -> vdi_info val set_content_id : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> content_id: content_id -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> content_id:content_id + -> unit val compose : - context -> - dbg: debug_info -> sr: sr -> vdi1: vdi -> vdi2: vdi -> unit + context -> dbg:debug_info -> sr:sr -> vdi1:vdi -> vdi2:vdi -> unit val add_to_sm_config : - context -> - dbg: debug_info -> - sr: sr -> vdi: vdi -> key: string -> value: string -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> key:string + -> value:string + -> unit val remove_from_sm_config : - context -> - dbg: debug_info -> sr: sr -> vdi: vdi -> key: string -> unit + context -> dbg:debug_info -> sr:sr -> vdi:vdi -> key:string -> unit - val enable_cbt : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val enable_cbt : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit - val disable_cbt : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val disable_cbt : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit - val data_destroy : - context -> dbg: debug_info -> sr: sr -> vdi: vdi -> unit + val data_destroy : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> unit val list_changed_blocks : - context -> - dbg: debug_info -> - sr: sr -> vdi_from: vdi -> vdi_to: vdi -> string - + context -> dbg:debug_info -> sr:sr -> vdi_from:vdi -> vdi_to:vdi -> string end - val get_by_name : - context -> dbg: debug_info -> name: string -> (sr * vdi_info) + val get_by_name : context -> dbg:debug_info -> name:string -> sr * vdi_info - module DATA : - sig + module DATA : sig val copy_into : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> - url: string -> dest: sr -> dest_vdi: vdi -> Task.id + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> url:string + -> dest:sr + -> dest_vdi:vdi + -> Task.id val copy : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> dp: dp -> url: string -> dest: sr -> Task.id - - module MIRROR : - sig + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> dp:dp + -> url:string + -> dest:sr + -> Task.id + + module MIRROR : sig val start : - context -> - dbg: debug_info -> - sr: sr -> - vdi: vdi -> dp: dp -> url: string -> dest: sr -> Task.id + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> dp:dp + -> url:string + -> dest:sr + -> Task.id - val stop : context -> dbg: debug_info -> id: Mirror.id -> unit + val stop : context -> dbg:debug_info -> id:Mirror.id -> unit - val stat : - context -> dbg: debug_info -> id: Mirror.id -> Mirror.t + val stat : context -> dbg:debug_info -> id:Mirror.id -> Mirror.t val receive_start : - context -> - dbg: debug_info -> - sr: sr -> - vdi_info: vdi_info -> - id: Mirror.id -> - similar: Mirror.similars -> Mirror. - mirror_receive_result - - val receive_finalize : - context -> dbg: debug_info -> id: Mirror.id -> unit + context + -> dbg:debug_info + -> sr:sr + -> vdi_info:vdi_info + -> id:Mirror.id + -> similar:Mirror.similars + -> Mirror.mirror_receive_result - val receive_cancel : - context -> dbg: debug_info -> id: Mirror.id -> unit + val receive_finalize : context -> dbg:debug_info -> id:Mirror.id -> unit - val list : - context -> dbg: debug_info -> (Mirror.id * Mirror.t) list + val receive_cancel : context -> dbg:debug_info -> id:Mirror.id -> unit + val list : context -> dbg:debug_info -> (Mirror.id * Mirror.t) list end - end - module Policy : - sig + module Policy : sig val get_backend_vm : - context -> - dbg: debug_info -> vm: string -> sr: sr -> vdi: vdi -> string - + context -> dbg:debug_info -> vm:string -> sr:sr -> vdi:vdi -> string end - module TASK : - sig - val stat : context -> dbg: debug_info -> task: Task.id -> Task.t + module TASK : sig + val stat : context -> dbg:debug_info -> task:Task.id -> Task.t - val cancel : context -> dbg: debug_info -> task: Task.id -> unit + val cancel : context -> dbg:debug_info -> task:Task.id -> unit - val destroy : context -> dbg: debug_info -> task: Task.id -> unit - - val list : context -> dbg: debug_info -> Task.t list + val destroy : context -> dbg:debug_info -> task:Task.id -> unit + val list : context -> dbg:debug_info -> Task.t list end - module UPDATES : - sig + module UPDATES : sig val get : - context -> - dbg: debug_info -> - from: string -> - timeout: (int option) -> ((Dynamic.id list) * string) - + context + -> dbg:debug_info + -> from:string + -> timeout:int option + -> Dynamic.id list * string end - end - - module Server (Impl : Server_impl) () = struct - module S = StorageAPI(Idl.Exn.GenServer ()) + module S = StorageAPI (Idl.Exn.GenServer ()) let _ = - S.Query.query (fun dbg -> Impl.Query.query () ~dbg); - S.Query.diagnostics (fun dbg -> Impl.Query.diagnostics () ~dbg); - - S.DP.create (fun dbg id -> Impl.DP.create () ~dbg ~id); - S.DP.destroy (fun dbg dp allow_leak -> Impl.DP.destroy () ~dbg ~dp ~allow_leak); - S.DP.attach_info (fun dbg sr vdi dp -> Impl.DP.attach_info () ~dbg ~sr ~vdi ~dp); - S.DP.diagnostics (fun () -> Impl.DP.diagnostics () ()); - S.DP.stat_vdi (fun dbg sr vdi () -> Impl.DP.stat_vdi () ~dbg ~sr~vdi ()); - - S.SR.create (fun dbg sr name_label name_description device_config physical_size -> - Impl.SR.create () ~dbg ~sr ~name_label ~name_description ~device_config ~physical_size); + S.Query.query (fun dbg -> Impl.Query.query () ~dbg) ; + S.Query.diagnostics (fun dbg -> Impl.Query.diagnostics () ~dbg) ; + S.DP.create (fun dbg id -> Impl.DP.create () ~dbg ~id) ; + S.DP.destroy (fun dbg dp allow_leak -> + Impl.DP.destroy () ~dbg ~dp ~allow_leak) ; + S.DP.attach_info (fun dbg sr vdi dp -> + Impl.DP.attach_info () ~dbg ~sr ~vdi ~dp) ; + S.DP.diagnostics (fun () -> Impl.DP.diagnostics () ()) ; + S.DP.stat_vdi (fun dbg sr vdi () -> Impl.DP.stat_vdi () ~dbg ~sr ~vdi ()) ; + S.SR.create + (fun dbg sr name_label name_description device_config physical_size -> + Impl.SR.create () ~dbg ~sr ~name_label ~name_description ~device_config + ~physical_size) ; S.SR.set_name_label (fun dbg sr new_name_label -> - Impl.SR.set_name_label () ~dbg ~sr ~new_name_label); + Impl.SR.set_name_label () ~dbg ~sr ~new_name_label) ; S.SR.set_name_description (fun dbg sr new_name_description -> - Impl.SR.set_name_description () ~dbg ~sr ~new_name_description); + Impl.SR.set_name_description () ~dbg ~sr ~new_name_description) ; S.SR.probe (fun dbg queue device_config sm_config -> - Impl.SR.probe () ~dbg ~queue ~device_config ~sm_config); + Impl.SR.probe () ~dbg ~queue ~device_config ~sm_config) ; S.SR.attach (fun dbg sr device_config -> - Impl.SR.attach () ~dbg ~sr ~device_config); - S.SR.detach (fun dbg sr -> - Impl.SR.detach () ~dbg ~sr); - S.SR.reset (fun dbg sr -> - Impl.SR.reset () ~dbg ~sr); - S.SR.destroy (fun dbg sr -> - Impl.SR.destroy () ~dbg ~sr); - S.SR.scan (fun dbg sr -> - Impl.SR.scan () ~dbg ~sr); - S.SR.update_snapshot_info_src (fun dbg sr vdi url dest dest_vdi snapshot_pairs -> - Impl.SR.update_snapshot_info_src () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs); + Impl.SR.attach () ~dbg ~sr ~device_config) ; + S.SR.detach (fun dbg sr -> Impl.SR.detach () ~dbg ~sr) ; + S.SR.reset (fun dbg sr -> Impl.SR.reset () ~dbg ~sr) ; + S.SR.destroy (fun dbg sr -> Impl.SR.destroy () ~dbg ~sr) ; + S.SR.scan (fun dbg sr -> Impl.SR.scan () ~dbg ~sr) ; + S.SR.update_snapshot_info_src + (fun dbg sr vdi url dest dest_vdi snapshot_pairs -> + Impl.SR.update_snapshot_info_src () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi + ~snapshot_pairs) ; S.SR.update_snapshot_info_dest (fun dbg sr vdi src_vdi snapshot_pairs -> - Impl.SR.update_snapshot_info_dest () ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs); - S.SR.stat (fun dbg sr -> - Impl.SR.stat () ~dbg ~sr); - S.SR.list (fun dbg -> - Impl.SR.list () ~dbg); - - - S.VDI.create (fun dbg sr vdi_info -> - Impl.VDI.create () ~dbg ~sr ~vdi_info); + Impl.SR.update_snapshot_info_dest () ~dbg ~sr ~vdi ~src_vdi + ~snapshot_pairs) ; + S.SR.stat (fun dbg sr -> Impl.SR.stat () ~dbg ~sr) ; + S.SR.list (fun dbg -> Impl.SR.list () ~dbg) ; + S.VDI.create (fun dbg sr vdi_info -> Impl.VDI.create () ~dbg ~sr ~vdi_info) ; S.VDI.set_name_label (fun dbg sr vdi new_name_label -> - Impl.VDI.set_name_label () ~dbg ~sr ~vdi ~new_name_label); + Impl.VDI.set_name_label () ~dbg ~sr ~vdi ~new_name_label) ; S.VDI.set_name_description (fun dbg sr vdi new_name_description -> - Impl.VDI.set_name_description () ~dbg ~sr ~vdi ~new_name_description); + Impl.VDI.set_name_description () ~dbg ~sr ~vdi ~new_name_description) ; S.VDI.snapshot (fun dbg sr vdi_info -> - Impl.VDI.snapshot () ~dbg ~sr ~vdi_info); - S.VDI.clone (fun dbg sr vdi_info -> - Impl.VDI.clone () ~dbg ~sr ~vdi_info); + Impl.VDI.snapshot () ~dbg ~sr ~vdi_info) ; + S.VDI.clone (fun dbg sr vdi_info -> Impl.VDI.clone () ~dbg ~sr ~vdi_info) ; S.VDI.resize (fun dbg sr vdi new_size -> - Impl.VDI.resize () ~dbg ~sr ~vdi ~new_size); - S.VDI.destroy (fun dbg sr vdi -> - Impl.VDI.destroy () ~dbg ~sr ~vdi); - S.VDI.stat (fun dbg sr vdi -> - Impl.VDI.stat () ~dbg ~sr ~vdi); + Impl.VDI.resize () ~dbg ~sr ~vdi ~new_size) ; + S.VDI.destroy (fun dbg sr vdi -> Impl.VDI.destroy () ~dbg ~sr ~vdi) ; + S.VDI.stat (fun dbg sr vdi -> Impl.VDI.stat () ~dbg ~sr ~vdi) ; S.VDI.introduce (fun dbg sr uuid sm_config location -> - Impl.VDI.introduce () ~dbg ~sr ~uuid ~sm_config ~location); + Impl.VDI.introduce () ~dbg ~sr ~uuid ~sm_config ~location) ; S.VDI.set_persistent (fun dbg sr vdi persistent -> - Impl.VDI.set_persistent () ~dbg ~sr ~vdi ~persistent); + Impl.VDI.set_persistent () ~dbg ~sr ~vdi ~persistent) ; S.VDI.epoch_begin (fun dbg sr vdi vm persistent -> - Impl.VDI.epoch_begin () ~dbg ~sr ~vdi ~vm ~persistent); + Impl.VDI.epoch_begin () ~dbg ~sr ~vdi ~vm ~persistent) ; S.VDI.attach (fun dbg dp sr vdi read_write -> - Impl.VDI.attach () ~dbg ~dp ~sr ~vdi ~read_write); + Impl.VDI.attach () ~dbg ~dp ~sr ~vdi ~read_write) ; S.VDI.attach2 (fun dbg dp sr vdi read_write -> - Impl.VDI.attach2 () ~dbg ~dp ~sr ~vdi ~read_write); + Impl.VDI.attach2 () ~dbg ~dp ~sr ~vdi ~read_write) ; S.VDI.attach3 (fun dbg dp sr vdi vm read_write -> - Impl.VDI.attach3 () ~dbg ~dp ~sr ~vdi ~vm ~read_write); - S.VDI.activate (fun dbg dp sr vdi -> - Impl.VDI.activate () ~dbg ~dp ~sr ~vdi); + Impl.VDI.attach3 () ~dbg ~dp ~sr ~vdi ~vm ~read_write) ; + S.VDI.activate (fun dbg dp sr vdi -> Impl.VDI.activate () ~dbg ~dp ~sr ~vdi) ; S.VDI.activate3 (fun dbg dp sr vdi vm -> - Impl.VDI.activate3 () ~dbg ~dp ~sr ~vdi ~vm); + Impl.VDI.activate3 () ~dbg ~dp ~sr ~vdi ~vm) ; S.VDI.deactivate (fun dbg dp sr vdi vm -> - Impl.VDI.deactivate () ~dbg ~dp ~sr ~vdi ~vm); + Impl.VDI.deactivate () ~dbg ~dp ~sr ~vdi ~vm) ; S.VDI.detach (fun dbg dp sr vdi vm -> - Impl.VDI.detach () ~dbg ~dp ~sr ~vdi ~vm); + Impl.VDI.detach () ~dbg ~dp ~sr ~vdi ~vm) ; S.VDI.epoch_end (fun dbg sr vdi vm -> - Impl.VDI.epoch_end () ~dbg ~sr ~vdi ~vm); - S.VDI.get_url (fun dbg sr vdi -> - Impl.VDI.get_url () ~dbg ~sr ~vdi); + Impl.VDI.epoch_end () ~dbg ~sr ~vdi ~vm) ; + S.VDI.get_url (fun dbg sr vdi -> Impl.VDI.get_url () ~dbg ~sr ~vdi) ; S.VDI.similar_content (fun dbg sr vdi -> - Impl.VDI.similar_content () ~dbg ~sr ~vdi); + Impl.VDI.similar_content () ~dbg ~sr ~vdi) ; S.VDI.get_by_name (fun dbg sr name -> - Impl.VDI.get_by_name () ~dbg ~sr ~name); + Impl.VDI.get_by_name () ~dbg ~sr ~name) ; S.VDI.set_content_id (fun dbg sr vdi content_id -> - Impl.VDI.set_content_id () ~dbg ~sr ~vdi ~content_id); + Impl.VDI.set_content_id () ~dbg ~sr ~vdi ~content_id) ; S.VDI.compose (fun dbg sr vdi1 vdi2 -> - Impl.VDI.compose () ~dbg ~sr ~vdi1 ~vdi2); + Impl.VDI.compose () ~dbg ~sr ~vdi1 ~vdi2) ; S.VDI.add_to_sm_config (fun dbg sr vdi key value -> - Impl.VDI.add_to_sm_config () ~dbg ~sr ~vdi ~key ~value); + Impl.VDI.add_to_sm_config () ~dbg ~sr ~vdi ~key ~value) ; S.VDI.remove_from_sm_config (fun dbg sr vdi key -> - Impl.VDI.remove_from_sm_config () ~dbg ~sr ~vdi ~key); - S.VDI.enable_cbt (fun dbg sr vdi -> - Impl.VDI.enable_cbt () ~dbg ~sr ~vdi); - S.VDI.disable_cbt (fun dbg sr vdi -> - Impl.VDI.disable_cbt () ~dbg ~sr ~vdi); + Impl.VDI.remove_from_sm_config () ~dbg ~sr ~vdi ~key) ; + S.VDI.enable_cbt (fun dbg sr vdi -> Impl.VDI.enable_cbt () ~dbg ~sr ~vdi) ; + S.VDI.disable_cbt (fun dbg sr vdi -> Impl.VDI.disable_cbt () ~dbg ~sr ~vdi) ; S.VDI.data_destroy (fun dbg sr vdi -> - Impl.VDI.data_destroy () ~dbg ~sr ~vdi); + Impl.VDI.data_destroy () ~dbg ~sr ~vdi) ; S.VDI.list_changed_blocks (fun dbg sr vdi_from vdi_to -> - Impl.VDI.list_changed_blocks () ~dbg ~sr ~vdi_from ~vdi_to); - - S.get_by_name (fun dbg name -> - Impl.get_by_name () ~dbg ~name); - + Impl.VDI.list_changed_blocks () ~dbg ~sr ~vdi_from ~vdi_to) ; + S.get_by_name (fun dbg name -> Impl.get_by_name () ~dbg ~name) ; S.DATA.copy_into (fun dbg sr vdi url dest dest_vdi -> - Impl.DATA.copy_into () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi); + Impl.DATA.copy_into () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi) ; S.DATA.copy (fun dbg sr vdi dp url dest -> - Impl.DATA.copy () ~dbg ~sr ~vdi ~dp ~url ~dest); - + Impl.DATA.copy () ~dbg ~sr ~vdi ~dp ~url ~dest) ; S.DATA.MIRROR.start (fun dbg sr vdi dp url dest -> - Impl.DATA.MIRROR.start () ~dbg ~sr ~vdi ~dp ~url ~dest); - S.DATA.MIRROR.stop (fun dbg id -> - Impl.DATA.MIRROR.stop () ~dbg ~id); - S.DATA.MIRROR.stat (fun dbg id -> - Impl.DATA.MIRROR.stat () ~dbg ~id); + Impl.DATA.MIRROR.start () ~dbg ~sr ~vdi ~dp ~url ~dest) ; + S.DATA.MIRROR.stop (fun dbg id -> Impl.DATA.MIRROR.stop () ~dbg ~id) ; + S.DATA.MIRROR.stat (fun dbg id -> Impl.DATA.MIRROR.stat () ~dbg ~id) ; S.DATA.MIRROR.receive_start (fun dbg sr vdi_info id similar -> - Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~similar); + Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~similar) ; S.DATA.MIRROR.receive_cancel (fun dbg id -> - Impl.DATA.MIRROR.receive_cancel () ~dbg ~id); + Impl.DATA.MIRROR.receive_cancel () ~dbg ~id) ; S.DATA.MIRROR.receive_finalize (fun dbg id -> - Impl.DATA.MIRROR.receive_finalize () ~dbg ~id); - S.DATA.MIRROR.list (fun dbg -> - Impl.DATA.MIRROR.list () ~dbg); - + Impl.DATA.MIRROR.receive_finalize () ~dbg ~id) ; + S.DATA.MIRROR.list (fun dbg -> Impl.DATA.MIRROR.list () ~dbg) ; S.Policy.get_backend_vm (fun dbg vm sr vdi -> - Impl.Policy.get_backend_vm () ~dbg ~vm ~sr ~vdi); - - S.TASK.stat (fun dbg task -> - Impl.TASK.stat () ~dbg ~task); - S.TASK.cancel (fun dbg task -> - Impl.TASK.cancel () ~dbg ~task); - S.TASK.destroy (fun dbg task -> - Impl.TASK.destroy () ~dbg ~task); - S.TASK.list (fun dbg -> - Impl.TASK.list () ~dbg); - + Impl.Policy.get_backend_vm () ~dbg ~vm ~sr ~vdi) ; + S.TASK.stat (fun dbg task -> Impl.TASK.stat () ~dbg ~task) ; + S.TASK.cancel (fun dbg task -> Impl.TASK.cancel () ~dbg ~task) ; + S.TASK.destroy (fun dbg task -> Impl.TASK.destroy () ~dbg ~task) ; + S.TASK.list (fun dbg -> Impl.TASK.list () ~dbg) ; S.UPDATES.get (fun dbg from timeout -> Impl.UPDATES.get () ~dbg ~from ~timeout) - (* Bind all *) let process call = Idl.Exn.server S.implementation call - end - diff --git a/storage/storage_skeleton.ml b/storage/storage_skeleton.ml index 51e8301c..5e93071e 100644 --- a/storage/storage_skeleton.ml +++ b/storage/storage_skeleton.ml @@ -13,98 +13,161 @@ *) [@@@ocaml.warning "-27"] -let u x = raise (Storage_interface.(Storage_error (Errors.Unimplemented x))) +let u x = raise Storage_interface.(Storage_error (Errors.Unimplemented x)) type context = unit module UPDATES = struct let get ctx ~dbg ~from ~timeout = (* block forever *) - while true do Thread.delay 5. done; - [], "" + while true do + Thread.delay 5. + done ; + ([], "") end module Query = struct let query ctx ~dbg = u "Query.query" + let diagnostics ctx ~dbg = u "Query.diagnostics" end module DP = struct let create ctx ~dbg ~id = u "DP.create" + let destroy ctx ~dbg ~dp ~allow_leak = u "DP.destroy" + let attach_info ctx ~dbg ~sr ~vdi ~dp = u "DP.attach_info" + let diagnostics ctx () = u "DP.diagnostics" + let stat_vdi ctx ~dbg ~sr ~vdi () = u "DP.stat_vdi" end module SR = struct - let create ctx ~dbg ~sr ~name_label ~name_description ~device_config ~physical_size = u "SR.create" + let create ctx ~dbg ~sr ~name_label ~name_description ~device_config + ~physical_size = + u "SR.create" + let attach ctx ~dbg ~sr ~device_config = u "SR.attach" + let set_name_label ctx ~dbg ~sr ~new_name_label = u "SR.set_name_label" - let set_name_description ctx ~dbg ~sr ~new_name_description = u "SR.set_name_description" + + let set_name_description ctx ~dbg ~sr ~new_name_description = + u "SR.set_name_description" + let detach ctx ~dbg ~sr = u "SR.detach" + let reset ctx ~dbg ~sr = u "SR.reset" + let destroy ctx ~dbg ~sr = u "SR.destroy" + let probe ctx ~dbg ~queue ~device_config ~sm_config = u "SR.probe" + let scan ctx ~dbg ~sr = u "SR.scan" - let update_snapshot_info_src ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs = u "SR.update_snapshot_info_src" - let update_snapshot_info_dest ctx ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = u "SR.update_snapshot_info_dest" + + let update_snapshot_info_src ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi + ~snapshot_pairs = + u "SR.update_snapshot_info_src" + + let update_snapshot_info_dest ctx ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = + u "SR.update_snapshot_info_dest" + let stat ctx ~dbg ~sr = u "SR.stat" + let list ctx ~dbg = u "SR.list" end module VDI = struct let create ctx ~dbg ~sr ~vdi_info = u "VDI.create" + let set_name_label ctx ~dbg ~sr ~vdi ~new_name_label = u "VDI.set_name_label" - let set_name_description ctx ~dbg ~sr ~vdi ~new_name_description = u "VDI.set_name_description" + + let set_name_description ctx ~dbg ~sr ~vdi ~new_name_description = + u "VDI.set_name_description" + let snapshot ctx ~dbg ~sr ~vdi_info = u "VDI.snapshot" + let clone ctx ~dbg ~sr ~vdi_info = u "VDI.clone" + let resize ctx ~dbg ~sr ~vdi ~new_size = u "VDI.resize" + let destroy ctx ~dbg ~sr ~vdi = u "VDI.destroy" + let stat ctx ~dbg ~sr ~vdi = u "VDI.stat" + let introduce ctx ~dbg ~sr ~uuid ~sm_config ~location = u "VDI.introduce" + let set_persistent ctx ~dbg ~sr ~vdi ~persistent = u "VDI.set_persistent" + let epoch_begin ctx ~dbg ~sr ~vdi ~vm ~persistent = () + let attach ctx ~dbg ~dp ~sr ~vdi ~read_write = u "VDI.attach" + let attach2 ctx ~dbg ~dp ~sr ~vdi ~read_write = u "VDI.attach2" + let attach3 ctx ~dbg ~dp ~sr ~vdi ~vm ~read_write = u "VDI.attach3" + let activate ctx ~dbg ~dp ~sr ~vdi = u "VDI.activate" + let activate3 ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.activate3" - let deactivate ctx ~dbg ~dp ~sr ~vdi ~vm= u "VDI.deactivate" + + let deactivate ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.deactivate" + let detach ctx ~dbg ~dp ~sr ~vdi ~vm = u "VDI.detach" + let epoch_end ctx ~dbg ~sr ~vdi ~vm = () + let get_url ctx ~dbg ~sr ~vdi = u "VDI.get_url" + let similar_content ctx ~dbg ~sr ~vdi = u "VDI.similar_content" + let get_by_name ctx ~dbg ~sr ~name = u "VDI.get_by_name" + let set_content_id ctx ~dbg ~sr ~vdi ~content_id = u "VDI.set_content_id" + let compose ctx ~dbg ~sr ~vdi1 ~vdi2 = u "VDI.compose" + let add_to_sm_config ctx ~dbg ~sr ~vdi ~key ~value = u "VDI.add_to_sm_config" - let remove_from_sm_config ctx ~dbg ~sr ~vdi ~key = u "VDI.remove_from_sm_config" + + let remove_from_sm_config ctx ~dbg ~sr ~vdi ~key = + u "VDI.remove_from_sm_config" + let enable_cbt ctx ~dbg ~sr ~vdi = u "VDI.enable_cbt" + let disable_cbt ctx ~dbg ~sr ~vdi = u "VDI.disable_cbt" + let data_destroy ctx ~dbg ~sr ~vdi = u "VDI.data_destroy" - let list_changed_blocks ctx ~dbg ~sr ~vdi_from ~vdi_to = u "VDI.list_changed_blocks" + + let list_changed_blocks ctx ~dbg ~sr ~vdi_from ~vdi_to = + u "VDI.list_changed_blocks" end let get_by_name ctx ~dbg ~name = u "get_by_name" module DATA = struct let copy_into ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi = u "DATA.copy_into" + let copy ctx ~dbg ~sr ~vdi ~dp ~url ~dest = u "DATA.copy" module MIRROR = struct - (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and writes - data synchronously. It returns the id of the VDI.*) + (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and + writes data synchronously. It returns the id of the VDI.*) let start ctx ~dbg ~sr ~vdi ~dp ~url ~dest = u "DATA.MIRROR.start" + let stop ctx ~dbg ~id = u "DATA.MIRROR.stop" + let stat ctx ~dbg ~id = u "DATA.MIRROR.stat" - let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar = u "DATA.MIRROR.receive_start" - let receive_finalize ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize" + + let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar = + u "DATA.MIRROR.receive_start" + + let receive_finalize ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize" + let receive_cancel ctx ~dbg ~id = u "DATA.MIRROR.receive_cancel" - + let list ctx ~dbg = u "DATA.MIRROR.list" end - end module Policy = struct @@ -113,8 +176,10 @@ end module TASK = struct let stat ctx ~dbg ~task = u "TASK.stat" + let cancel ctx ~dbg ~task = u "TASK.cancel" + let destroy ctx ~dbg ~task = u "TASK.destroy" + let list ctx ~dbg = u "TASK.list" end - diff --git a/storage/storage_skeleton_test.ml b/storage/storage_skeleton_test.ml index 6ec46362..60763c11 100644 --- a/storage/storage_skeleton_test.ml +++ b/storage/storage_skeleton_test.ml @@ -13,4 +13,4 @@ *) (* if this type-checks then the storage_skeleton is complete *) -module Test = Storage_interface.Server(Storage_skeleton) +module Test = Storage_interface.Server (Storage_skeleton) diff --git a/storage/storage_test.ml b/storage/storage_test.ml index dc661714..98eb1fb1 100644 --- a/storage/storage_test.ml +++ b/storage/storage_test.ml @@ -15,62 +15,69 @@ open Storage_interface open Storage_client -(* Principles: - 1. we don't delete or manipulate VDIs we didn't create - 2. we create VDIs with non-clashing names - 3. we always clean up (as best we can) after every test. -*) +(* Principles: 1. we don't delete or manipulate VDIs we didn't create 2. we + create VDIs with non-clashing names 3. we always clean up (as best we can) + after every test. *) (* We assume that no-one else has made VDIs with this name prefix: *) let safe_prefix = Printf.sprintf "storage_test.%d" (Unix.getpid ()) + let dbg = safe_prefix let _vdi_create = "VDI_CREATE" + let _vdi_delete = "VDI_DELETE" + let _vdi_attach = "VDI_ATTACH" + let _vdi_detach = "VDI_DETACH" + let _vdi_activate = "VDI_ACTIVATE" + let _vdi_deactivate = "VDI_DEACTIVATE" + let _vdi_clone = "VDI_CLONE" + let _vdi_resize = "VDI_RESIZE" (* Names which are likely to cause problems *) -let names = [ - (* start with an easy one *) - "simple"; - ""; - "."; - ".."; - "/"; - "!"; - String.make 128 '0'; -] - -(* For each VDI we check that: - 1. it shows up in a SR.scan - 2. attach RO, activate, deactivate, detach works - 3. attach RW, activate, deactivate, detach works -*) +let names = + [ + (* start with an easy one *) + "simple" + ; "" + ; "." + ; ".." + ; "/" + ; "!" + ; String.make 128 '0' + ] + +(* For each VDI we check that: 1. it shows up in a SR.scan 2. attach RO, + activate, deactivate, detach works 3. attach RW, activate, deactivate, detach + works *) let vdi_exists sr vdi = let all = Client.SR.scan dbg sr in - List.fold_left (fun acc vdi_info -> acc || (vdi_info.vdi = vdi)) false all + List.fold_left (fun acc vdi_info -> acc || vdi_info.vdi = vdi) false all let create sr name_label = - let vdi_info = { - default_vdi_info with - name_label = safe_prefix ^ "." ^ name_label; - virtual_size = 1000000000L; - } in + let vdi_info = + { + default_vdi_info with + name_label= safe_prefix ^ "." ^ name_label + ; virtual_size= 1000000000L + } + in let vdi = Client.VDI.create dbg sr vdi_info in - assert(vdi_exists sr vdi.vdi); + assert (vdi_exists sr vdi.vdi) ; (* Check the disk has size >= the amount we requested *) - assert(vdi.virtual_size >= vdi_info.virtual_size); + assert (vdi.virtual_size >= vdi_info.virtual_size) ; vdi let destroy sr vdi = - Client.VDI.destroy dbg sr vdi.vdi; - assert(not (vdi_exists sr vdi.vdi)) + Client.VDI.destroy dbg sr vdi.vdi ; + assert (not (vdi_exists sr vdi.vdi)) let test_create_destroy sr n () = destroy sr (create sr n) @@ -81,19 +88,19 @@ let attach_detach sr vdi read_write = let test_attach_detach sr n () = let vdi = create sr n in - List.iter (attach_detach sr vdi) [ true; false ]; + List.iter (attach_detach sr vdi) [true; false] ; destroy sr vdi let attach_activate_deactivate_detach sr vdi read_write = let vm = Vm.of_string "0" in let _ = Client.VDI.attach dbg dbg sr vdi.vdi read_write in - Client.VDI.activate dbg dbg sr vdi.vdi; - Client.VDI.deactivate dbg dbg sr vdi.vdi vm; + Client.VDI.activate dbg dbg sr vdi.vdi ; + Client.VDI.deactivate dbg dbg sr vdi.vdi vm ; Client.VDI.detach dbg dbg sr vdi.vdi vm let test_activate_deactivate sr n () = let vdi = create sr n in - List.iter (attach_activate_deactivate_detach sr vdi) [ true; false ]; + List.iter (attach_activate_deactivate_detach sr vdi) [true; false] ; destroy sr vdi let test_clone sr n () = @@ -101,12 +108,12 @@ let test_clone sr n () = List.iter (fun _read_write -> (* Check whether the backend writes type= *) - let vdi = { vdi with sm_config = [] } in + let vdi = {vdi with sm_config= []} in let x = Client.VDI.clone dbg sr vdi in - Client.VDI.destroy dbg sr x.vdi; - assert(List.mem_assoc "type" x.sm_config); - assert(List.assoc "type" x.sm_config <> "raw"); - ) [ true; false ]; + Client.VDI.destroy dbg sr x.vdi ; + assert (List.mem_assoc "type" x.sm_config) ; + assert (List.assoc "type" x.sm_config <> "raw")) + [true; false] ; destroy sr vdi let test_clone_attach sr n () = @@ -116,83 +123,150 @@ let test_clone_attach sr n () = let vdis = Client.SR.scan dbg sr in let x = Client.VDI.clone dbg sr vdi in let vdis' = Client.SR.scan dbg sr in - attach_activate_deactivate_detach sr x read_write; - Client.VDI.destroy dbg sr x.vdi; - assert ((List.length vdis + 1) = (List.length vdis')) - ) [ true; false ]; + attach_activate_deactivate_detach sr x read_write ; + Client.VDI.destroy dbg sr x.vdi ; + assert (List.length vdis + 1 = List.length vdis')) + [true; false] ; destroy sr vdi let test_resize sr n () = let vdi = create sr n in let new_size_request = Int64.mul 2L vdi.virtual_size in let new_size_actual = Client.VDI.resize dbg sr vdi.vdi new_size_request in - assert (new_size_actual >= new_size_request); + assert (new_size_actual >= new_size_request) ; destroy sr vdi -let vdi_create_destroy sr = "vdi_create_destroy" , (List.map (fun n -> "name " ^ n , `Quick, test_create_destroy sr n) names) -let vdi_attach_detach sr = "vdi_attach_detach" , (List.map (fun n -> "name " ^ n , `Quick, test_attach_detach sr n) names) -let vdi_activate_deactivate sr = "vdi_activate_deactivate" , (List.map (fun n -> "name " ^ n , `Quick, test_activate_deactivate sr n) names) -let vdi_clone sr = "vdi_clone" , (List.map (fun n -> "name " ^ n , `Quick, test_clone sr n) names) -let vdi_clone_attach sr = "vdi_clone_attach" , (List.map (fun n -> "name " ^ n , `Quick, test_clone_attach sr n) names) -let vdi_resize sr = "vdi_resize" , (List.map (fun n -> "name " ^ n , `Quick, test_resize sr n) names) +let vdi_create_destroy sr = + ( "vdi_create_destroy" + , List.map (fun n -> ("name " ^ n, `Quick, test_create_destroy sr n)) names ) + +let vdi_attach_detach sr = + ( "vdi_attach_detach" + , List.map (fun n -> ("name " ^ n, `Quick, test_attach_detach sr n)) names ) + +let vdi_activate_deactivate sr = + ( "vdi_activate_deactivate" + , List.map + (fun n -> ("name " ^ n, `Quick, test_activate_deactivate sr n)) + names ) + +let vdi_clone sr = + ("vdi_clone", List.map (fun n -> ("name " ^ n, `Quick, test_clone sr n)) names) + +let vdi_clone_attach sr = + ( "vdi_clone_attach" + , List.map (fun n -> ("name " ^ n, `Quick, test_clone_attach sr n)) names ) + +let vdi_resize sr = + ( "vdi_resize" + , List.map (fun n -> ("name " ^ n, `Quick, test_resize sr n)) names ) open Cmdliner -let start verbose queue sr = match queue, sr with +let start verbose queue sr = + match (queue, sr) with | Some queue, Some sr -> - Storage_interface.queue_name := queue; - Xcp_client.use_switch := true; - - let q = Client.Query.query dbg in - let features = List.map (fun s -> - try - let i = String.index s '/' in - Some (String.sub s 0 i, Int64.of_string (String.sub s (i+1) (String.length s - i - 1))) - with _ -> Some (s, 1L)) q.features in - let features = List.fold_left (fun acc x -> match x with Some x -> x::acc | None -> acc) [] features in - - let needs_capabilities caps suite = - if List.fold_left (fun acc x -> acc && (List.mem_assoc x features)) true caps - then [ suite ] else [] in - - let suite = - (List.concat [ - needs_capabilities [ _vdi_create; _vdi_delete ] (vdi_create_destroy sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_attach; _vdi_detach ] (vdi_attach_detach sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_attach; _vdi_detach; _vdi_activate; _vdi_deactivate ] (vdi_activate_deactivate sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_clone ] (vdi_clone sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_attach; _vdi_detach; _vdi_activate; _vdi_deactivate; _vdi_clone ] (vdi_clone_attach sr); - needs_capabilities [ _vdi_create; _vdi_delete; _vdi_resize ] (vdi_resize sr); - ]) in - Alcotest.run ~and_exit:false ~argv:[|Array.get Sys.argv 0|] "storage" suite + Storage_interface.queue_name := queue ; + Xcp_client.use_switch := true ; + let q = Client.Query.query dbg in + let features = + List.map + (fun s -> + try + let i = String.index s '/' in + Some + ( String.sub s 0 i + , Int64.of_string + (String.sub s (i + 1) (String.length s - i - 1)) ) + with _ -> Some (s, 1L)) + q.features + in + let features = + List.fold_left + (fun acc x -> match x with Some x -> x :: acc | None -> acc) + [] features + in + let needs_capabilities caps suite = + if + List.fold_left + (fun acc x -> acc && List.mem_assoc x features) + true caps + then + [suite] + else + [] + in + let suite = + List.concat + [ + needs_capabilities [_vdi_create; _vdi_delete] (vdi_create_destroy sr) + ; needs_capabilities + [_vdi_create; _vdi_delete; _vdi_attach; _vdi_detach] + (vdi_attach_detach sr) + ; needs_capabilities + [ + _vdi_create + ; _vdi_delete + ; _vdi_attach + ; _vdi_detach + ; _vdi_activate + ; _vdi_deactivate + ] + (vdi_activate_deactivate sr) + ; needs_capabilities + [_vdi_create; _vdi_delete; _vdi_clone] + (vdi_clone sr) + ; needs_capabilities + [ + _vdi_create + ; _vdi_delete + ; _vdi_attach + ; _vdi_detach + ; _vdi_activate + ; _vdi_deactivate + ; _vdi_clone + ] + (vdi_clone_attach sr) + ; needs_capabilities + [_vdi_create; _vdi_delete; _vdi_resize] + (vdi_resize sr) + ] + in + Alcotest.run ~and_exit:false ~argv:[|Sys.argv.(0)|] "storage" suite | _, _ -> - Printf.fprintf stderr "Please supply both a queue name and an SR\n%!"; - () + Printf.fprintf stderr "Please supply both a queue name and an SR\n%!" ; + () let cmd = let doc = "Storage component test" in - let man = [ - `S "DESCRIPTION"; - `P "Test a storage implementation via the SMAPI."; - `S "USAGE"; - `P "$(tname) "; - `P "-- test the service listening on using the existing attached SR ."; - ] in + let man = + [ + `S "DESCRIPTION" + ; `P "Test a storage implementation via the SMAPI." + ; `S "USAGE" + ; `P "$(tname) " + ; `P + "-- test the service listening on using the existing \ + attached SR ." + ] + in let verbose = let doc = "Print verbose output" in - Arg.(value & flag & info ["verbose"; "v"] ~doc) in + Arg.(value & flag & info ["verbose"; "v"] ~doc) + in let queue = let doc = "The queue name where the storage implementation is listening." in - Arg.(value & pos 0 (some string) None & info [] ~doc) in + Arg.(value & pos 0 (some string) None & info [] ~doc) + in let sr_t = let parse s = Ok (Sr.of_string s) in let print fmt s = s |> Sr.string_of |> Arg.(conv_printer string) fmt in - Arg.conv ~docv:"SR" (parse, print) in + Arg.conv ~docv:"SR" (parse, print) + in let sr = let doc = "The attached SR." in - Arg.(value & pos 1 (some sr_t) None & info [] ~doc) in - - Term.(const start $ verbose $ queue $ sr), - Term.info "test" ~doc ~man + Arg.(value & pos 1 (some sr_t) None & info [] ~doc) + in + (Term.(const start $ verbose $ queue $ sr), Term.info "test" ~doc ~man) let () = Term.exit @@ Term.eval ~catch:true cmd diff --git a/storage/suite.ml b/storage/suite.ml index 5f55a6bc..f1abefbb 100644 --- a/storage/suite.ml +++ b/storage/suite.ml @@ -1,16 +1,11 @@ - let test_parse_nbd_uri () = - let nbd = Storage_interface.{ uri = "nbd:unix:socket:exportname=disk" } in - Alcotest.(check (pair string string)) "correctly parsed NBD URI" - ("socket", "disk") + let nbd = Storage_interface.{uri= "nbd:unix:socket:exportname=disk"} in + Alcotest.(check (pair string string)) + "correctly parsed NBD URI" ("socket", "disk") (Storage_interface.parse_nbd_uri nbd) -let test_helpers = - [ "test_parse_nbd_uri", `Quick, test_parse_nbd_uri - ] +let test_helpers = [("test_parse_nbd_uri", `Quick, test_parse_nbd_uri)] let () = Alcotest.run "Storage_interface unit tests" - [ "helpers", test_helpers - ; "VDI automaton", Vdi_automaton_test.tests - ] + [("helpers", test_helpers); ("VDI automaton", Vdi_automaton_test.tests)] diff --git a/storage/vdi_automaton.ml b/storage/vdi_automaton.ml index 39c3e2ab..76128189 100644 --- a/storage/vdi_automaton.ml +++ b/storage/vdi_automaton.ml @@ -11,111 +11,139 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** - * @group Storage - *) - +(** * @group Storage *) (** An automaton representing the VDI state machine *) type ro_rw = RO | RW [@@deriving rpcty] -let string_of_ro_rw = function - | RO -> "RO" | RW -> "RW" +let string_of_ro_rw = function RO -> "RO" | RW -> "RW" -type state = - | Detached - | Attached of ro_rw - | Activated of ro_rw +type state = Detached | Attached of ro_rw | Activated of ro_rw [@@deriving rpcty] let string_of_state = function - | Detached -> "detached" - | Attached ro_rw -> Printf.sprintf "attached %s" (string_of_ro_rw ro_rw) - | Activated ro_rw -> Printf.sprintf "activated %s" (string_of_ro_rw ro_rw) + | Detached -> + "detached" + | Attached ro_rw -> + Printf.sprintf "attached %s" (string_of_ro_rw ro_rw) + | Activated ro_rw -> + Printf.sprintf "activated %s" (string_of_ro_rw ro_rw) -let every_state = [ - Detached; - Attached RO; Attached RW; - Activated RO; Activated RW -] +let every_state = + [Detached; Attached RO; Attached RW; Activated RO; Activated RW] -type op = - | Nothing - | Attach of ro_rw - | Detach - | Activate - | Deactivate +type op = Nothing | Attach of ro_rw | Detach | Activate | Deactivate -let every_op = [ - Nothing; - Attach RO; Attach RW; - Activate; - Detach; Deactivate; -] +let every_op = [Nothing; Attach RO; Attach RW; Activate; Detach; Deactivate] let string_of_op = function - | Nothing -> "nothing" - | Attach ro_rw -> Printf.sprintf "attach(%s)" (string_of_ro_rw ro_rw) - | Detach -> "detach" - | Activate -> Printf.sprintf "activate" - | Deactivate -> "deactivate" + | Nothing -> + "nothing" + | Attach ro_rw -> + Printf.sprintf "attach(%s)" (string_of_ro_rw ro_rw) + | Detach -> + "detach" + | Activate -> + Printf.sprintf "activate" + | Deactivate -> + "deactivate" exception Bad_transition of state * op let ( + ) state operation = - let error () = raise (Bad_transition (state, operation)) in - - let ro_rw x y = match x,y with - | RO, RO -> RO - | RW, RW -> RW - | RO, RW -> error () - | RW, RO -> RW in - match state, operation with - | x, Nothing -> x - | Detached, Attach x -> Attached x - | Detached, Activate -> error () - | Detached, Deactivate -> Detached - | Detached, Detach -> Detached - | Attached x, Attach y -> Attached (ro_rw x y) - | Attached x, Activate -> Activated x - | Attached _, Detach -> Detached - | Attached x, Deactivate -> Attached x - | Activated x, Attach y -> Activated (ro_rw x y) - | Activated x, Activate -> Activated x - | Activated x, Deactivate -> Attached x - | Activated _, Detach -> error () + let error () = raise (Bad_transition (state, operation)) in + let ro_rw x y = + match (x, y) with + | RO, RO -> + RO + | RW, RW -> + RW + | RO, RW -> + error () + | RW, RO -> + RW + in + match (state, operation) with + | x, Nothing -> + x + | Detached, Attach x -> + Attached x + | Detached, Activate -> + error () + | Detached, Deactivate -> + Detached + | Detached, Detach -> + Detached + | Attached x, Attach y -> + Attached (ro_rw x y) + | Attached x, Activate -> + Activated x + | Attached _, Detach -> + Detached + | Attached x, Deactivate -> + Attached x + | Activated x, Attach y -> + Activated (ro_rw x y) + | Activated x, Activate -> + Activated x + | Activated x, Deactivate -> + Attached x + | Activated _, Detach -> + error () let superstate states = - let activated = List.fold_left (fun acc s -> - acc || (s = Activated RO) || (s = Activated RW)) false states in - let rw = List.fold_left (fun acc s -> - acc || (s = Activated RW) || (s = Attached RW)) false states in - if states = [] - then Detached - else - if activated - then Activated (if rw then RW else RO) - else Attached (if rw then RW else RO) + let activated = + List.fold_left + (fun acc s -> acc || s = Activated RO || s = Activated RW) + false states + in + let rw = + List.fold_left + (fun acc s -> acc || s = Activated RW || s = Attached RW) + false states + in + if states = [] then + Detached + else if activated then + Activated (if rw then RW else RO) + else + Attached (if rw then RW else RO) exception No_operation of state * state (* x - y = [ (op, state_on_fail)+ ] *) -let ( - ) x y = match x, y with - | Detached, Detached -> [ Nothing, Detached ] - | Attached RO, Attached RO -> [ Nothing, Attached RO ] - | Activated RO, Activated RO -> [ Nothing, Activated RO ] - | Attached RW, Attached RW -> [ Nothing, Attached RW ] - | Activated RW, Activated RW -> [ Nothing, Activated RW ] - | Attached r, Detached -> [ Detach, Attached r ] - | Activated RO, Attached RO -> [ Deactivate, Activated RO ] - | Activated RW, Attached RW -> [ Deactivate, Activated RW ] - | Activated r, Detached -> [ Deactivate, Activated r; Detach, Attached r ] - | Detached, Attached RO -> [ Attach RO, Detached ] - | Detached, Attached RW -> [ Attach RW, Detached ] - | Detached, Activated RO -> [ Attach RO, Detached; Activate, Attached RO ] - | Detached, Activated RW -> [ Attach RW, Detached; Activate, Attached RW ] - | Attached RO, Activated RO -> [ Activate, Attached RO ] - | Attached RW, Activated RW -> [ Activate, Attached RW ] - | _, _ -> raise (No_operation (x, y)) - +let ( - ) x y = + match (x, y) with + | Detached, Detached -> + [(Nothing, Detached)] + | Attached RO, Attached RO -> + [(Nothing, Attached RO)] + | Activated RO, Activated RO -> + [(Nothing, Activated RO)] + | Attached RW, Attached RW -> + [(Nothing, Attached RW)] + | Activated RW, Activated RW -> + [(Nothing, Activated RW)] + | Attached r, Detached -> + [(Detach, Attached r)] + | Activated RO, Attached RO -> + [(Deactivate, Activated RO)] + | Activated RW, Attached RW -> + [(Deactivate, Activated RW)] + | Activated r, Detached -> + [(Deactivate, Activated r); (Detach, Attached r)] + | Detached, Attached RO -> + [(Attach RO, Detached)] + | Detached, Attached RW -> + [(Attach RW, Detached)] + | Detached, Activated RO -> + [(Attach RO, Detached); (Activate, Attached RO)] + | Detached, Activated RW -> + [(Attach RW, Detached); (Activate, Attached RW)] + | Attached RO, Activated RO -> + [(Activate, Attached RO)] + | Attached RW, Activated RW -> + [(Activate, Attached RW)] + | _, _ -> + raise (No_operation (x, y)) diff --git a/storage/vdi_automaton_test.ml b/storage/vdi_automaton_test.ml index c1bddb81..0faf3955 100644 --- a/storage/vdi_automaton_test.ml +++ b/storage/vdi_automaton_test.ml @@ -12,28 +12,26 @@ * GNU Lesser General Public License for more details. *) -(* For any state [s] and operation [o] where [s' = s + o], - [if s <> s' then s - s' = op] *) +(* For any state [s] and operation [o] where [s' = s + o], [if s <> s' then s - + s' = op] *) let all_pairs x y = - List.fold_left (fun acc x -> List.map (fun y -> x, y) y @ acc) [] x + List.fold_left (fun acc x -> List.map (fun y -> (x, y)) y @ acc) [] x let run () = List.iter (fun (s, op) -> - try - let s' = Vdi_automaton.(s + op) in - let op' = List.map fst Vdi_automaton.(s - s') in - if s <> s' && [ op ] <> op' then - failwith Vdi_automaton.( - Printf.sprintf "s = %s; op = %s; s + op = %s; s - (s + op) = %s" - (string_of_state s) - (string_of_op op) - (string_of_state s') - (String.concat ", " (List.map string_of_op op'))) - with Vdi_automaton.Bad_transition(_, _) -> () - ) (all_pairs Vdi_automaton.every_state Vdi_automaton.every_op); - Printf.printf "Passed." + try + let s' = Vdi_automaton.(s + op) in + let op' = List.map fst Vdi_automaton.(s - s') in + if s <> s' && [op] <> op' then + failwith + Vdi_automaton.( + Printf.sprintf "s = %s; op = %s; s + op = %s; s - (s + op) = %s" + (string_of_state s) (string_of_op op) (string_of_state s') + (String.concat ", " (List.map string_of_op op'))) + with Vdi_automaton.Bad_transition (_, _) -> ()) + (all_pairs Vdi_automaton.every_state Vdi_automaton.every_op) ; + Printf.printf "Passed." -let tests = - [ "VDI automaton test", `Quick, run ] +let tests = [("VDI automaton test", `Quick, run)] diff --git a/v6/v6_cli.ml b/v6/v6_cli.ml index e3ec72b6..3d869938 100644 --- a/v6/v6_cli.ml +++ b/v6/v6_cli.ml @@ -1,25 +1,28 @@ (* Licensing CLI *) -module Cmds =V6_interface.RPC_API(Cmdlinergen.Gen ()) +module Cmds = V6_interface.RPC_API (Cmdlinergen.Gen ()) let version_str description = - let maj,min,mic = description.Idl.Interface.version in + let maj, min, mic = description.Idl.Interface.version in Printf.sprintf "%d.%d.%d" maj min mic let default_cmd = - let doc = String.concat "" [ - "A CLI for the V6d API. This allows scripting of the licensing daemon "; - "for testing and debugging. This tool is not intended to be used as an "; - "end user tool"] in - Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())), - Cmdliner.Term.info "licensing_cli" ~version:(version_str Cmds.description) ~doc + let doc = + String.concat "" + [ + "A CLI for the V6d API. This allows scripting of the licensing daemon " + ; "for testing and debugging. This tool is not intended to be used as an " + ; "end user tool" + ] + in + ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) + , Cmdliner.Term.info "licensing_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = let rpc = V6_client.rpc in - Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ())) - -let _ = - match cli () with - | `Ok f -> f () - | _ -> () + Cmdliner.Term.eval_choice default_cmd + (List.map (fun t -> t rpc) (Cmds.implementation ())) +let _ = match cli () with `Ok f -> f () | _ -> () diff --git a/v6/v6_client.ml b/v6/v6_client.ml index 486b0d52..41201980 100644 --- a/v6/v6_client.ml +++ b/v6/v6_client.ml @@ -16,27 +16,32 @@ open V6_interface open Xcp_client let retry_econnrefused f = - let rec loop retry = - let result = - try - Some (f ()) - with Unix.Unix_error((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> - Thread.delay 1.; - None in - match result with - | Some x -> x - | None -> if retry then loop false else raise (V6_error V6d_failure) - in - loop true - + let rec loop retry = + let result = + try Some (f ()) + with Unix.Unix_error ((Unix.ECONNREFUSED | Unix.ENOENT), _, _) -> + Thread.delay 1. ; None + in + match result with + | Some x -> + x + | None -> + if retry then loop false else raise (V6_error V6d_failure) + in + loop true let json_url () = "file:" ^ json_path + let xml_url () = "file:" ^ xml_path let rpc call = - if !use_switch - then json_switch_rpc !queue_name call - else xml_http_rpc ~srcstr:"xapi" ~dststr:"v6d" xml_url call + if !use_switch then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:"xapi" ~dststr:"v6d" xml_url call + +module Client = V6_interface.RPC_API (Idl.Exn.GenClient (struct + let rpc = rpc +end)) -module Client = V6_interface.RPC_API(Idl.Exn.GenClient(struct let rpc=rpc end)) include Client diff --git a/v6/v6_interface.ml b/v6/v6_interface.ml index 83a7b099..85be7936 100644 --- a/v6/v6_interface.ml +++ b/v6/v6_interface.ml @@ -12,157 +12,172 @@ * GNU Lesser General Public License for more details. *) -(** - @group Licensing -*) +(** @group Licensing *) open Rpc + open Idl -module D = Debug.Make(struct let name = "v6_interface" end) +module D = Debug.Make (struct let name = "v6_interface" end) + open D let service_name = "v6d" + let queue_name = ref (Xcp_service.common_prefix ^ service_name) + let default_sockets_dir = "/var/lib/xcp" + let default_path = ref (Filename.concat default_sockets_dir service_name) + let uri () = "file:" ^ !default_path + let json_path = "/var/xapi/v6.json" + let xml_path = "/var/xapi/v6" (** Uninterpreted/sanitised string associated with operation *) -type debug_info = string -[@@deriving rpcty] +type debug_info = string [@@deriving rpcty] (** Record representing software edition *) -type edition = - { - title : string ; - (** Name of edition, this will be passed to apply_edition *) - official_title : string ; - (** Marketing title used to advertise edition *) - code : string ; - (** Abbreviated form of name, used to show up in logs and on command line *) - order : int ; - (** Number indicating ordering among other editions; - low numbers correspond to fewer features, and vice versa *) - } +type edition = { + title: string (** Name of edition, this will be passed to apply_edition *) + ; official_title: string (** Marketing title used to advertise edition *) + ; code: string + (** Abbreviated form of name, used to show up in logs and on command + line *) + ; order: int + (** Number indicating ordering among other editions; low numbers + correspond to fewer features, and vice versa *) +} [@@deriving rpcty] (** List of edition records *) -type edition_list = edition list -[@@deriving rpcty] +type edition_list = edition list [@@deriving rpcty] (** Record of edition info, including xapi parameters and features *) -type edition_info = - { - edition_name: string; - (** Name of edition *) - xapi_params: (string * string) list; - (** List of parameters used by Xapi *) - additional_params: (string * string) list; - (** Addition parameters supplied *) - experimental_features: (string * bool) list; - (** List of experimental features and whether they're available in this edition *) - } +type edition_info = { + edition_name: string (** Name of edition *) + ; xapi_params: (string * string) list (** List of parameters used by Xapi *) + ; additional_params: (string * string) list + (** Addition parameters supplied *) + ; experimental_features: (string * bool) list + (** List of experimental features and whether they're available in this + edition *) +} [@@deriving rpcty] (** [string * string] list *) -type string_pair_lst = (string * string) list -[@@deriving rpcty] +type string_pair_lst = (string * string) list [@@deriving rpcty] (** Wrapper for specific errors in managing features *) type errors = | Invalid_edition of string - (** Thrown by apply_edition on receiving unfamiliar edition. - * Note: get_editions returns list of all valid editions *) + (** Thrown by apply_edition on receiving unfamiliar edition. * Note: + get_editions returns list of all valid editions *) | License_expired - (** Thrown by license_check when expiry date matches or precedes current date *) - | License_processing_error - (** License could not be processed *) - | License_checkout_error of string - (** License could not be checked out *) + (** Thrown by license_check when expiry date matches or precedes current + date *) + | License_processing_error (** License could not be processed *) + | License_checkout_error of string (** License could not be checked out *) | Missing_connection_details - (** Thrown if connection port or address parameter not supplied to check_license *) - | V6d_failure - (** Daemon failed to enable features *) + (** Thrown if connection port or address parameter not supplied to + check_license *) + | V6d_failure (** Daemon failed to enable features *) | Internal_error of string - (** Exception raised if an unexpected error is triggered by the library *) -[@@default V6d_failure] -[@@deriving rpcty] + (** Exception raised if an unexpected error is triggered by the library *) +[@@default V6d_failure] [@@deriving rpcty] (** Pass error variant as exn for error handler *) exception V6_error of errors -let () = (* register printer *) +let () = + (* register printer *) let sprintf = Printf.sprintf in let string_of_error e = - Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string in + Rpcmarshal.marshal errors.Rpc.Types.ty e |> Rpc.to_string + in let printer = function | V6_error e -> Some (sprintf "V6_interface.V6_error(%s)" (string_of_error e)) - | _ -> None in + | _ -> + None + in Printexc.register_printer printer (** handle exception generation and raising *) -let err = Error. - { def = errors - ; raiser = (fun e -> - log_backtrace (); - let exn = V6_error e in - error "%s (%s)" (Printexc.to_string exn) __LOC__; - raise exn) - ; matcher = (function - | V6_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; +let err = + Error. + { + def= errors + ; raiser= + (fun e -> + log_backtrace () ; + let exn = V6_error e in + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + raise exn) + ; matcher= + (function + | V6_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__; + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; Some (Internal_error (Printexc.to_string exn))) } (** functor to autogenerate code using PPX *) -module RPC_API(R : RPC) = struct +module RPC_API (R : RPC) = struct open R (* description of V6d interface module *) - let description = Interface.{ - name = "Licensing"; - namespace = None; - description = - [ - "This interface is used by Xapi and V6d to manage " - ; "enabling and disabling features." - ]; - version=(1,0,0); } + let description = + Interface. + { + name= "Licensing" + ; namespace= None + ; description= + [ + "This interface is used by Xapi and V6d to manage " + ; "enabling and disabling features." + ] + ; version= (1, 0, 0) + } (* define implementation *) let implementation = implement description (* define general parameters for API calls *) - let debug_info_p = Param.mk ~description:[ - "An uninterpreted string to associate with the operation." - ] debug_info + let debug_info_p = + Param.mk + ~description:["An uninterpreted string to associate with the operation."] + debug_info (* ---- API call definitions ---- *) let apply_edition = let edition_p = Param.mk ~description:["Edition title"] Types.string in let edition_info_p = Param.mk ~description:["Edition info"] edition_info in - let current_params_p = Param.mk ~description:["Xapi parameters"] string_pair_lst in + let current_params_p = + Param.mk ~description:["Xapi parameters"] string_pair_lst + in declare "apply_edition" ["Checks license info to ensures enabled features are compatible."] - ( debug_info_p @-> edition_p @-> current_params_p @-> returning edition_info_p err ) + (debug_info_p + @-> edition_p + @-> current_params_p + @-> returning edition_info_p err + ) let get_editions = - let edition_list_p = Param.mk ~description:["List of editions"] edition_list in + let edition_list_p = + Param.mk ~description:["List of editions"] edition_list + in declare "get_editions" ["Gets list of accepted editions."] - ( debug_info_p @-> returning edition_list_p err ) + (debug_info_p @-> returning edition_list_p err) let get_version = let result_p = Param.mk ~description:["String of version."] Types.string in - declare "get_version" - ["Returns version"] - ( debug_info_p @-> returning result_p err ) - + declare "get_version" ["Returns version"] + (debug_info_p @-> returning result_p err) end diff --git a/varstore/deprivileged/varstore_deprivileged_cli.ml b/varstore/deprivileged/varstore_deprivileged_cli.ml index 7361d472..b4a582fd 100644 --- a/varstore/deprivileged/varstore_deprivileged_cli.ml +++ b/varstore/deprivileged/varstore_deprivileged_cli.ml @@ -21,7 +21,9 @@ let version_str description = let default_cmd = let doc = "debug CLI" in ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) - , Cmdliner.Term.info "varstored_cli" ~version:(version_str Cmds.description) ~doc ) + , Cmdliner.Term.info "varstored_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli = let uri = ref "" in @@ -33,19 +35,19 @@ let cli = call in let wrapper file next = - uri := "file://" ^ file; + uri := "file://" ^ file ; next in let doc = "Path to deprivileged socket in /var/run/xen" in let path = - Cmdliner.Arg.(required & opt (some file) None & info ["socket"] ~doc ~docv:"SOCKET") + Cmdliner.Arg.( + required & opt (some file) None & info ["socket"] ~doc ~docv:"SOCKET") in - Cmdliner.Term.eval_choice - default_cmd + Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> let term, info = t rpc in - Cmdliner.Term.(const wrapper $ path $ term $ const ()), info ) + (Cmdliner.Term.(const wrapper $ path $ term $ const ()), info)) (Cmds.implementation ())) let () = Cmdliner.Term.exit cli diff --git a/varstore/deprivileged/varstore_deprivileged_interface.ml b/varstore/deprivileged/varstore_deprivileged_interface.ml index dde8b0ae..c4734f0a 100644 --- a/varstore/deprivileged/varstore_deprivileged_interface.ml +++ b/varstore/deprivileged/varstore_deprivileged_interface.ml @@ -22,19 +22,26 @@ type nvram = (string * string) list [@@deriving rpcty] module RPC_API (R : RPC) = struct open R - (* A restricted interface to VM's NVRAM, varstored is sandboxed and has no direct access to XAPI *) + (* A restricted interface to VM's NVRAM, varstored is sandboxed and has no + direct access to XAPI *) let description = let open Interface in - { name = "Xenopsd_varstored" - ; namespace = None - ; description = + { + name= "Xenopsd_varstored" + ; namespace= None + ; description= ["This interface is used by varstored to set VM NVRAM and send alerts"] - ; version = 0, 1, 0 } + ; version= (0, 1, 0) + } let implementation = implement description + let unit_p = Param.mk ~name:"unit" Types.unit + let nvram_p = Param.mk ~name:"NVRAM" nvram + let string_p = Param.mk Types.string + let int64_p = Param.mk Types.int64 (* The APIs here should be wire-compatible with the ones in XAPI, @@ -43,44 +50,44 @@ module RPC_API (R : RPC) = struct * The parameters cannot be named *) let session_login = - declare - "session.login_with_password" + declare "session.login_with_password" ["Dummy, for wire compatibility with XAPI"] - (string_p @-> string_p @-> string_p @-> string_p @-> returning string_p err) + (string_p + @-> string_p + @-> string_p + @-> string_p + @-> returning string_p err + ) let session_logout = - declare - "session.logout" + declare "session.logout" ["Dummy, for wire compatibility with XAPI"] (string_p @-> returning unit_p err) let get_by_uuid = - declare - "VM.get_by_uuid" + declare "VM.get_by_uuid" ["Dummy, for wire compatibility with XAPI"] (string_p @-> string_p @-> returning string_p err) let get_NVRAM = - declare - "VM.get_NVRAM" + declare "VM.get_NVRAM" ["Get the current VM's NVRAM contents"] (string_p @-> string_p @-> returning nvram_p err) let set_NVRAM = - declare - "VM.set_NVRAM_EFI_variables" + declare "VM.set_NVRAM_EFI_variables" ["Set the current VM's NVRAM contents"] (string_p @-> string_p @-> string_p @-> returning unit_p err) let message_create = - declare - "message.create" + declare "message.create" ["Send an alert when booting a UEFI guest fails"] - ( string_p + (string_p @-> string_p @-> int64_p @-> string_p @-> string_p @-> string_p - @-> returning unit_p err ) + @-> returning unit_p err + ) end diff --git a/varstore/privileged/varstore_privileged_cli.ml b/varstore/privileged/varstore_privileged_cli.ml index 087642a6..c0d84c79 100644 --- a/varstore/privileged/varstore_privileged_cli.ml +++ b/varstore/privileged/varstore_privileged_cli.ml @@ -13,6 +13,7 @@ *) open Varstore_privileged_interface + module Cmds = RPC_API (Cmdlinergen.Gen ()) let version_str description = @@ -21,23 +22,29 @@ let version_str description = let default_cmd = let doc = - String.concat - " " - [ "A CLI for the deprivileged socket spawning API." + String.concat " " + [ + "A CLI for the deprivileged socket spawning API." ; "This allows scripting of the varstored deprivileging daemon" ; "for testing and debugging. This tool is not intended to be used" - ; "as an end user tool" ] + ; "as an end user tool" + ] in ( Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())) - , Cmdliner.Term.info "varstore_cli" ~version:(version_str Cmds.description) ~doc ) + , Cmdliner.Term.info "varstore_cli" + ~version:(version_str Cmds.description) + ~doc ) let cli () = match - Cmdliner.Term.eval_choice - default_cmd - (List.map (fun t -> t Varstore_privileged_client.rpc) (Cmds.implementation ())) + Cmdliner.Term.eval_choice default_cmd + (List.map + (fun t -> t Varstore_privileged_client.rpc) + (Cmds.implementation ())) with - | `Ok f -> f () - | _ -> () + | `Ok f -> + f () + | _ -> + () let _ = cli () diff --git a/varstore/privileged/varstore_privileged_client.ml b/varstore/privileged/varstore_privileged_client.ml index d8b45011..19391476 100644 --- a/varstore/privileged/varstore_privileged_client.ml +++ b/varstore/privileged/varstore_privileged_client.ml @@ -17,6 +17,4 @@ open Varstore_privileged_interface (* daemon only listens on message-switch *) let rpc call = Xcp_client.json_switch_rpc ~timeout:20 queue_name call -module Client = RPC_API (Idl.Exn.GenClient (struct - let rpc = rpc -end)) +module Client = RPC_API (Idl.Exn.GenClient (struct let rpc = rpc end)) diff --git a/varstore/privileged/varstore_privileged_interface.ml b/varstore/privileged/varstore_privileged_interface.ml index c89b5ca0..8330a4c7 100644 --- a/varstore/privileged/varstore_privileged_interface.ml +++ b/varstore/privileged/varstore_privileged_interface.ml @@ -12,18 +12,18 @@ * GNU Lesser General Public License for more details. *) -(** Varstored is deprivileged and should not have full access to XAPI. - This interface provides a way to spawn a new listening socket - restricted to a small number of API calls targeting only 1 VM. - Xenopsd is a client of this interface and calls it through message-switch. - A new privileged daemon (varstored-socket-deprivd) implements the interface - and spawns the listening sockets. - *) +(** Varstored is deprivileged and should not have full access to XAPI. This + interface provides a way to spawn a new listening socket restricted to a + small number of API calls targeting only 1 VM. Xenopsd is a client of this + interface and calls it through message-switch. A new privileged daemon + (varstored-socket-deprivd) implements the interface and spawns the listening + sockets. *) open Rpc open Idl let service_name = "xapi_depriv" + let queue_name = Xcp_service.common_prefix ^ service_name type error = InternalError of string [@@deriving rpcty] @@ -40,22 +40,28 @@ module Uuidm = struct (** Validate UUIDs by converting them to Uuidm.t in the API *) let typ_of = Rpc.Types.Abstract - { aname = "uuid" - ; test_data = [Uuidm.v `V4] - ; rpc_of = (fun t -> Rpc.String (Uuidm.to_string t)) - ; of_rpc = + { + aname= "uuid" + ; test_data= [Uuidm.v `V4] + ; rpc_of= (fun t -> Rpc.String (Uuidm.to_string t)) + ; of_rpc= (function - | Rpc.String s -> - (match Uuidm.of_string s with - | Some uuid -> Ok uuid + | Rpc.String s -> ( + match Uuidm.of_string s with + | Some uuid -> + Ok uuid | None -> - Error (`Msg (Printf.sprintf "typ_of_vm_uuid: not a valid UUID: %s" s))) + Error + (`Msg + (Printf.sprintf "typ_of_vm_uuid: not a valid UUID: %s" s)) + ) | r -> - Error - (`Msg - (Printf.sprintf - "typ_of_vm_uuid: expected rpc string but got %s" - (Rpc.to_string r)))) } + Error + (`Msg + (Printf.sprintf + "typ_of_vm_uuid: expected rpc string but got %s" + (Rpc.to_string r)))) + } end type vm_uuid = Uuidm.t [@@deriving rpcty] @@ -65,25 +71,29 @@ module RPC_API (R : RPC) = struct let description = Interface. - { name = "Depriv" - ; namespace = None - ; description = - ["Interface for creating a deprivileged XAPI socket for a specific VM."] - ; version = 1, 0, 0 } + { + name= "Depriv" + ; namespace= None + ; description= + [ + "Interface for creating a deprivileged XAPI socket for a specific \ + VM." + ] + ; version= (1, 0, 0) + } let implementation = implement description (** An uninterpreted string associated with the operation. *) - type debug_info = string - [@@deriving rpcty] + type debug_info = string [@@deriving rpcty] let debug_info_p = - Param.mk - ~name:"dbg" + Param.mk ~name:"dbg" ~description:["An uninterpreted string to associate with the operation."] debug_info let err = E.error + let unit_p = Param.mk Types.unit let path_p = @@ -94,15 +104,15 @@ module RPC_API (R : RPC) = struct let create = let vm_uuid_p = Param.mk ~name:"vm_uuid" ~description:["VM UUID"] vm_uuid in - declare - "create" - [ "Create a deprivileged socket that only accepts API calls for a" - ; "specific VM. The socket will be writable only to the specified group." ] + declare "create" + [ + "Create a deprivileged socket that only accepts API calls for a" + ; "specific VM. The socket will be writable only to the specified group." + ] (debug_info_p @-> vm_uuid_p @-> gid_p @-> path_p @-> returning unit_p err) let destroy = - declare - "destroy" + declare "destroy" ["Stop listening on sockets for the specified group"] (debug_info_p @-> gid_p @-> path_p @-> returning unit_p err) end diff --git a/xen/device_number.ml b/xen/device_number.ml index 49a08e04..6e8c7d47 100644 --- a/xen/device_number.ml +++ b/xen/device_number.ml @@ -1,192 +1,227 @@ -type bus_type = - | Xen - | Scsi - | Floppy - | Ide -[@@deriving rpcty] +type bus_type = Xen | Scsi | Floppy | Ide [@@deriving rpcty] type spec = bus_type * int * int [@@deriving rpcty] type t = spec [@@deriving rpcty] let to_debug_string = function - | (Xen, disk, partition) -> Printf.sprintf "Xen(%d, %d)" disk partition - | (Scsi, disk, partition) -> Printf.sprintf "Scsi(%d, %d)" disk partition - | (Floppy, disk, partition) -> Printf.sprintf "Floppy(%d, %d)" disk partition - | (Ide , disk, partition) -> Printf.sprintf "Ide(%d, %d)" disk partition + | Xen, disk, partition -> + Printf.sprintf "Xen(%d, %d)" disk partition + | Scsi, disk, partition -> + Printf.sprintf "Scsi(%d, %d)" disk partition + | Floppy, disk, partition -> + Printf.sprintf "Floppy(%d, %d)" disk partition + | Ide, disk, partition -> + Printf.sprintf "Ide(%d, %d)" disk partition (* ocamlp4-friendly operators *) -let (<|) = (lsl) -let (>|) = (lsr) +let ( <| ) = ( lsl ) -let int_of_string x = try int_of_string x with _ -> failwith (Printf.sprintf "int_of_string [%s]" x) +let ( >| ) = ( lsr ) -(* If this is true then we will use the deprecated (linux-specific) IDE encodings for disks > 3 *) +let int_of_string x = + try int_of_string x + with _ -> failwith (Printf.sprintf "int_of_string [%s]" x) + +(* If this is true then we will use the deprecated (linux-specific) IDE + encodings for disks > 3 *) let use_deprecated_ide_encoding = true -let make (x: spec) : t = - let max_xen = ((1 <| 20) - 1), 15 in - let max_scsi = 15, 15 in - let max_ide = if use_deprecated_ide_encoding then 19, 63 else 3, 63 in - let max_floppy = 2, 0 in - let assert_in_range description (disk_limit, partition_limit) (disk, partition) = - if disk < 0 || (disk > disk_limit) - then failwith (Printf.sprintf "%s disk number out of range 0 <= %d <= %d" description disk disk_limit); - if partition < 0 || partition > partition_limit - then failwith (Printf.sprintf "%s partition number out of range 0 <= %d <= %d" description partition partition_limit) in - begin match x with - | Xen, disk, partition -> assert_in_range "xen" max_xen (disk, partition) - | Scsi, disk, partition -> assert_in_range "scsi" max_scsi (disk, partition) - | Floppy, disk, partition -> assert_in_range "floppy" max_floppy (disk, partition) - | Ide, disk, partition -> assert_in_range "ide" max_ide (disk, partition) - end; - x - -let spec (x: t) : spec = x - -let (||) = (lor) - -let standard_ide_table = [ 3; 22 ] -let deprecated_ide_table = standard_ide_table @ [ 33; 34; 56; 57; 88; 89; 90; 91 ] +let make (x : spec) : t = + let max_xen = ((1 <| 20) - 1, 15) in + let max_scsi = (15, 15) in + let max_ide = if use_deprecated_ide_encoding then (19, 63) else (3, 63) in + let max_floppy = (2, 0) in + let assert_in_range description (disk_limit, partition_limit) (disk, partition) + = + if disk < 0 || disk > disk_limit then + failwith + (Printf.sprintf "%s disk number out of range 0 <= %d <= %d" description + disk disk_limit) ; + if partition < 0 || partition > partition_limit then + failwith + (Printf.sprintf "%s partition number out of range 0 <= %d <= %d" + description partition partition_limit) + in + ( match x with + | Xen, disk, partition -> + assert_in_range "xen" max_xen (disk, partition) + | Scsi, disk, partition -> + assert_in_range "scsi" max_scsi (disk, partition) + | Floppy, disk, partition -> + assert_in_range "floppy" max_floppy (disk, partition) + | Ide, disk, partition -> + assert_in_range "ide" max_ide (disk, partition) + ) ; + x + +let spec (x : t) : spec = x + +let ( || ) = ( lor ) + +let standard_ide_table = [3; 22] + +let deprecated_ide_table = standard_ide_table @ [33; 34; 56; 57; 88; 89; 90; 91] let to_xenstore_int = function - | Xen, disk, partition when disk < 16 -> (202 <| 8) || (disk <| 4) || partition - | Xen, disk, partition -> (1 <| 28) || (disk <| 8) || partition - | Scsi, disk, partition -> (8 <| 8) || (disk <| 4) || partition - | Floppy, disk, partition -> (203 <| 8) || (disk <| 4) || partition - | Ide, disk, partition -> - let m = List.nth deprecated_ide_table (disk / 2) in - let n = disk - (disk / 2) * 2 in (* NB integers behave differently to reals *) - (m <| 8) || (n <| 6) || partition + | Xen, disk, partition when disk < 16 -> + 202 <| 8 || disk <| 4 || partition + | Xen, disk, partition -> + 1 <| 28 || disk <| 8 || partition + | Scsi, disk, partition -> + 8 <| 8 || disk <| 4 || partition + | Floppy, disk, partition -> + 203 <| 8 || disk <| 4 || partition + | Ide, disk, partition -> + let m = List.nth deprecated_ide_table (disk / 2) in + let n = disk - (disk / 2 * 2) in + (* NB integers behave differently to reals *) + m <| 8 || n <| 6 || partition let of_xenstore_int x = - let (&&) = (land) in - - if (x && (1 <| 28)) <> 0 - then Xen, (x >| 8) && ((1 <| 20) - 1), x && ((1 <| 8) - 1) - else match x >| 8 with - | 202 -> Xen, (x >| 4) && ((1 <| 4) - 1), x && ((1 <| 4) - 1) - | 8 -> Scsi, (x >| 4) && ((1 <| 4) - 1), x && ((1 <| 4) - 1) - | 203 -> Floppy, (x >| 4) && ((1 <| 4) - 1), x && ((1 <| 4) - 1) - | n -> - let idx = snd(List.fold_left (fun (i, res) e -> i+1, if e = n then i else res) (0, -1) deprecated_ide_table) in - if idx < 0 - then failwith (Printf.sprintf "Unknown device number: %d" x); - Ide, ((x >| 6) && ((1 <| 2) - 1)) + idx * 2, x && ((1 <| 6) - 1) + let ( && ) = ( land ) in + if (x && 1 <| 28) <> 0 then + (Xen, x >| 8 && ((1 <| 20) - 1), x && ((1 <| 8) - 1)) + else + match x >| 8 with + | 202 -> + (Xen, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + | 8 -> + (Scsi, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + | 203 -> + (Floppy, x >| 4 && ((1 <| 4) - 1), x && ((1 <| 4) - 1)) + | n -> + let idx = + snd + (List.fold_left + (fun (i, res) e -> (i + 1, if e = n then i else res)) + (0, -1) deprecated_ide_table) + in + if idx < 0 then failwith (Printf.sprintf "Unknown device number: %d" x) ; + (Ide, (x >| 6 && ((1 <| 2) - 1)) + (idx * 2), x && ((1 <| 6) - 1)) type xenstore_key = int let to_xenstore_key x = to_xenstore_int x + let of_xenstore_key x = of_xenstore_int x -(* NB the device encoding is base 26 starting from 1 rather than 0 eg - 0 -> a - 25 -> z - 26 -> aa -*) +(* NB the device encoding is base 26 starting from 1 rather than 0 eg 0 -> a 25 + -> z 26 -> aa *) (** Return an integer encoded as a linux device suffix *) -let rec string_of_int26 x = - let high, low = x / 26 - 1, x mod 26 + 1 in - let high' = if high = -1 then "" else string_of_int26 high in - let low' = String.make 1 (char_of_int (low + (int_of_char 'a') - 1)) in - high' ^ low' +let rec string_of_int26 x = + let high, low = ((x / 26) - 1, (x mod 26) + 1) in + let high' = if high = -1 then "" else string_of_int26 high in + let low' = String.make 1 (char_of_int (low + int_of_char 'a' - 1)) in + high' ^ low' module String = struct - include String - let fold_right f string accu = - let accu = ref accu in - for i = length string - 1 downto 0 do - accu := f string.[i] !accu - done; - !accu - - let explode string = - fold_right (fun h t -> h :: t) string [] - - let implode list = - concat "" (List.map (String.make 1) list) + include String + + let fold_right f string accu = + let accu = ref accu in + for i = length string - 1 downto 0 do + accu := f string.[i] !accu + done ; + !accu + + let explode string = fold_right (fun h t -> h :: t) string [] + + let implode list = concat "" (List.map (String.make 1) list) end (** Convert a linux device string back into an integer *) -let int26_of_string x = - let ints = List.map (fun c -> int_of_char c - (int_of_char 'a') + 1) (String.explode x) in - List.fold_left (fun acc x -> acc * 26 + x) 0 ints - 1 - -let to_linux_device = - let p x = if x = 0 then "" else string_of_int x in - function - | Xen, disk, part -> Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) - | Scsi, disk, part -> Printf.sprintf "sd%s%s" (string_of_int26 disk) (p part) - | Floppy, disk, part -> Printf.sprintf "fd%s%s" (string_of_int26 disk) (p part) - | Ide, disk, part -> Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) +let int26_of_string x = + let ints = + List.map (fun c -> int_of_char c - int_of_char 'a' + 1) (String.explode x) + in + List.fold_left (fun acc x -> (acc * 26) + x) 0 ints - 1 + +let to_linux_device = + let p x = if x = 0 then "" else string_of_int x in + function + | Xen, disk, part -> + Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) + | Scsi, disk, part -> + Printf.sprintf "sd%s%s" (string_of_int26 disk) (p part) + | Floppy, disk, part -> + Printf.sprintf "fd%s%s" (string_of_int26 disk) (p part) + | Ide, disk, part -> + Printf.sprintf "xvd%s%s" (string_of_int26 disk) (p part) let of_linux_device x = - let letter c = 'a' <= c && (c <= 'z') in - let digit c = '0' <= c && (c <= '9') in - let take f x = - let rec inner f acc = function - | x :: xs -> - if f x then inner f (x :: acc) xs else List.rev acc, x :: xs - | [] -> List.rev acc, [] in - inner f [] x in - (* Parse a string "abc123" into x, y where x is "abc" interpreted as base-26 - and y is 123 *) - let parse_b26_int x = - let d, p = take letter x in - let d' = int26_of_string (String.implode d) in - let p' = if p = [] then 0 else int_of_string (String.implode p) in - d', p' in - (* Parse a string "123p456" into x, y where x = 123 and y = 456 *) - let parse_int_p_int x = - let d, rest = take digit x in - match rest with - | 'p' :: rest -> - let p, _ = take digit rest in - int_of_string (String.implode d), int_of_string (String.implode p) - | [] -> - int_of_string (String.implode d), 0 - | _ -> - failwith - (Printf.sprintf "expected digit+ p digit+ got: %s" (String.implode x)) in - match String.explode x with - | 'x' :: 'v' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Xen, disk, partition - | 's' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Scsi, disk, partition - | 'f' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Floppy, disk, partition - | 'h' :: 'd' :: rest -> - let disk, partition = parse_b26_int rest in - Ide, disk, partition - | 'd' :: rest -> - let disk, partition = parse_int_p_int rest in - Xen, disk, partition - | _ -> failwith (Printf.sprintf "Failed to parse device name: %s" x) + let letter c = 'a' <= c && c <= 'z' in + let digit c = '0' <= c && c <= '9' in + let take f x = + let rec inner f acc = function + | x :: xs -> + if f x then inner f (x :: acc) xs else (List.rev acc, x :: xs) + | [] -> + (List.rev acc, []) + in + inner f [] x + in + (* Parse a string "abc123" into x, y where x is "abc" interpreted as base-26 + and y is 123 *) + let parse_b26_int x = + let d, p = take letter x in + let d' = int26_of_string (String.implode d) in + let p' = if p = [] then 0 else int_of_string (String.implode p) in + (d', p') + in + (* Parse a string "123p456" into x, y where x = 123 and y = 456 *) + let parse_int_p_int x = + let d, rest = take digit x in + match rest with + | 'p' :: rest -> + let p, _ = take digit rest in + (int_of_string (String.implode d), int_of_string (String.implode p)) + | [] -> + (int_of_string (String.implode d), 0) + | _ -> + failwith + (Printf.sprintf "expected digit+ p digit+ got: %s" (String.implode x)) + in + match String.explode x with + | 'x' :: 'v' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Xen, disk, partition) + | 's' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Scsi, disk, partition) + | 'f' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Floppy, disk, partition) + | 'h' :: 'd' :: rest -> + let disk, partition = parse_b26_int rest in + (Ide, disk, partition) + | 'd' :: rest -> + let disk, partition = parse_int_p_int rest in + (Xen, disk, partition) + | _ -> + failwith (Printf.sprintf "Failed to parse device name: %s" x) let upgrade_linux_device x = - match String.explode x with - | 'h' :: 'd' :: rest -> "xvd" ^ (String.implode rest) - | _ -> x + match String.explode x with + | 'h' :: 'd' :: rest -> + "xvd" ^ String.implode rest + | _ -> + x type disk_number = int let to_disk_number = function - | Xen, disk, _ -> disk - | Scsi, disk, _ -> disk - | Floppy, disk, _ -> disk - | Ide, disk, _ -> disk - -let of_disk_number hvm n = - if hvm && (n < 4) - then Ide, n, 0 - else Xen, n, 0 - -let of_string hvm name = - try - of_disk_number hvm (int_of_string name) - with _ -> - of_linux_device name + | Xen, disk, _ -> + disk + | Scsi, disk, _ -> + disk + | Floppy, disk, _ -> + disk + | Ide, disk, _ -> + disk + +let of_disk_number hvm n = if hvm && n < 4 then (Ide, n, 0) else (Xen, n, 0) + +let of_string hvm name = + try of_disk_number hvm (int_of_string name) with _ -> of_linux_device name diff --git a/xen/device_number.mli b/xen/device_number.mli index d963599f..4b5c431c 100644 --- a/xen/device_number.mli +++ b/xen/device_number.mli @@ -1,12 +1,12 @@ (** Disks are attached to particular bus types: *) type bus_type = - | Xen (** A xen paravirtualised bus *) - | Scsi (** A SCSI bus *) - | Floppy (** A floppy bus *) - | Ide (** An IDE bus *) + | Xen (** A xen paravirtualised bus *) + | Scsi (** A SCSI bus *) + | Floppy (** A floppy bus *) + | Ide (** An IDE bus *) -(** A specification for a device number. There are more valid specifications than - valid device numbers because of hardware and/or protocol limits. *) +(** A specification for a device number. There are more valid specifications + than valid device numbers because of hardware and/or protocol limits. *) type spec = bus_type * int * int (** A valid device number *) @@ -14,46 +14,45 @@ type t val typ_of : t Rpc.Types.typ +val make : spec -> t (** [make spec] validates a given device number specification [spec] and returns a device number *) -val make: spec -> t +val spec : t -> spec (** [spec t] takes a [t] and returns the corresponding [spec] *) -val spec: t -> spec -(** [of_string hvm name] returns the interface which best matches the [name] - by applying the policy: first check if it is a disk_number, else fall back to - a linux_device for backwards compatability *) -val of_string: bool -> string -> t +val of_string : bool -> string -> t +(** [of_string hvm name] returns the interface which best matches the [name] by + applying the policy: first check if it is a disk_number, else fall back to a + linux_device for backwards compatability *) +val to_debug_string : t -> string (** [to_debug_string i] returns a pretty-printed interface *) -val to_debug_string: t -> string -(** [to_linux_device i] returns a possible linux string representation of interface [i] *) -val to_linux_device: t -> string +val to_linux_device : t -> string +(** [to_linux_device i] returns a possible linux string representation of + interface [i] *) +val of_linux_device : string -> t (** [of_linux_device x] returns the interface corresponding to string [x] *) -val of_linux_device: string -> t -(** [upgrade_linux_device x] upgrades hd* style device names to xvd* - and leaves all other device names unchanged. *) -val upgrade_linux_device: string -> string +val upgrade_linux_device : string -> string +(** [upgrade_linux_device x] upgrades hd* style device names to xvd* and leaves + all other device names unchanged. *) type xenstore_key = int +val to_xenstore_key : t -> xenstore_key (** [to_xenstore_key i] returns the xenstore key from interface [i] *) -val to_xenstore_key: t -> xenstore_key +val of_xenstore_key : xenstore_key -> t (** [of_xenstore_key key] returns an interface from a xenstore key *) -val of_xenstore_key: xenstore_key -> t type disk_number = int +val to_disk_number : t -> disk_number (** [to_disk_number i] returns the corresponding non-negative disk number *) -val to_disk_number: t -> disk_number - -(** [of_disk_number hvm n] returns the interface corresponding to disk - number [n] which depends on whether the guest is [hvm] or not. *) -val of_disk_number: bool -> disk_number -> t - +val of_disk_number : bool -> disk_number -> t +(** [of_disk_number hvm n] returns the interface corresponding to disk number + [n] which depends on whether the guest is [hvm] or not. *) diff --git a/xen/xenops_client.ml b/xen/xenops_client.ml index 88399c6c..085a72f3 100644 --- a/xen/xenops_client.ml +++ b/xen/xenops_client.ml @@ -15,52 +15,63 @@ open Xenops_interface open Xcp_client -module Client = Xenops_interface.XenopsAPI(Idl.Exn.GenClient(struct - let rpc call = - if !use_switch - then json_switch_rpc !queue_name call - else xml_http_rpc ~srcstr:"xapi" ~dststr:"xenops" default_uri call +module Client = Xenops_interface.XenopsAPI (Idl.Exn.GenClient (struct + let rpc call = + if !use_switch then + json_switch_rpc !queue_name call + else + xml_http_rpc ~srcstr:"xapi" ~dststr:"xenops" default_uri call end)) let query dbg url = - let module Remote = Xenops_interface.XenopsAPI(Idl.Exn.GenClient(struct let rpc = xml_http_rpc ~srcstr:"xenops" ~dststr:"dst_xenops" (fun () -> url) end)) in - Remote.query dbg () + let module Remote = Xenops_interface.XenopsAPI (Idl.Exn.GenClient (struct + let rpc = xml_http_rpc ~srcstr:"xenops" ~dststr:"dst_xenops" (fun () -> url) + end)) in + Remote.query dbg () let event_wait dbg ?from p = - let finished = ref false in - let event_id = ref from in - while not !finished do - let _, deltas, next_id = Client.UPDATES.get dbg !event_id (Some 30) in - event_id := Some next_id; - List.iter (fun d -> if p d then finished := true) deltas; - done + let finished = ref false in + let event_id = ref from in + while not !finished do + let _, deltas, next_id = Client.UPDATES.get dbg !event_id (Some 30) in + event_id := Some next_id ; + List.iter (fun d -> if p d then finished := true) deltas + done let task_ended dbg id = - match (Client.TASK.stat dbg id).Task.state with - | Task.Completed _ - | Task.Failed _ -> true - | Task.Pending _ -> false + match (Client.TASK.stat dbg id).Task.state with + | Task.Completed _ | Task.Failed _ -> + true + | Task.Pending _ -> + false let success_task dbg id = - let t = Client.TASK.stat dbg id in - Client.TASK.destroy dbg id; - match t.Task.state with - | Task.Completed _ -> t - | Task.Failed x -> begin - match Rpcmarshal.unmarshal Errors.error.Rpc.Types.ty x with - | Ok x -> raise (Xenops_interface.Xenopsd_error x) - | Error _ -> raise (Xenops_interface.Xenopsd_error (Errors.Internal_error (Jsonrpc.to_string x))) end - | Task.Pending _ -> failwith "task pending" + let t = Client.TASK.stat dbg id in + Client.TASK.destroy dbg id ; + match t.Task.state with + | Task.Completed _ -> + t + | Task.Failed x -> ( + match Rpcmarshal.unmarshal Errors.error.Rpc.Types.ty x with + | Ok x -> + raise (Xenops_interface.Xenopsd_error x) + | Error _ -> + raise + (Xenops_interface.Xenopsd_error + (Errors.Internal_error (Jsonrpc.to_string x))) + ) + | Task.Pending _ -> + failwith "task pending" let wait_for_task dbg id = - let finished = function - | Dynamic.Task id' -> - id = id' && (task_ended dbg id) - | _ -> - false in - let from = Client.UPDATES.last_id dbg in - if not(task_ended dbg id) then event_wait dbg ~from finished; - id - -let ignore_task (_: Task.t) = () + let finished = function + | Dynamic.Task id' -> + id = id' && task_ended dbg id + | _ -> + false + in + let from = Client.UPDATES.last_id dbg in + if not (task_ended dbg id) then event_wait dbg ~from finished ; + id +let ignore_task (_ : Task.t) = () diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index bc05ad20..cebe545c 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -18,9 +18,7 @@ open Rpc open Idl -module D = Debug.Make (struct - let name = "xenops_interface" -end) +module D = Debug.Make (struct let name = "xenops_interface" end) open D @@ -29,42 +27,49 @@ type rpc_t = Rpc.t let typ_of_rpc_t = let open Types in Abstract - { aname= "Rpc.t" + { + aname= "Rpc.t" ; test_data= [Null] ; rpc_of= (fun x -> x) - ; of_rpc= (fun x -> Ok x) } + ; of_rpc= (fun x -> Ok x) + } module TypeCombinators = struct - let option ?name ?(description= []) d = + let option ?name ?(description = []) d = let open Rpc.Types in let name = match name with Some n -> n | None -> Printf.sprintf "%s option" d.name in {name; description; ty= Option d.ty} - let list ?name ?(description= []) d = + let list ?name ?(description = []) d = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "list of %ss" d.name + | Some n -> + n + | None -> + Printf.sprintf "list of %ss" d.name in {name; description; ty= List d.ty} - let pair ?name ?(description= []) (p1, p2) = + let pair ?name ?(description = []) (p1, p2) = let open Rpc.Types in let name = match name with - | Some n -> n - | None -> Printf.sprintf "pair of %s and %s" p1.name p2.name + | Some n -> + n + | None -> + Printf.sprintf "pair of %s and %s" p1.name p2.name in {name; description; ty= Tuple (p1.ty, p2.ty)} - let triple ?name ?(description= []) (p1, p2, p3) = + let triple ?name ?(description = []) (p1, p2, p3) = let open Rpc.Types in let name = match name with - | Some n -> n + | Some n -> + n | None -> Printf.sprintf "triple of %s, %s and %s" p1.name p2.name p3.name in @@ -125,7 +130,8 @@ module Errors = struct | Failed_to_start_emulator of (string * string * string) | Ballooning_timeout_before_migration | Internal_error of string - | Unknown_error [@@default Unknown_error] [@@deriving rpcty] + | Unknown_error + [@@default Unknown_error] [@@deriving rpcty] end exception Xenopsd_error of Errors.error @@ -138,39 +144,41 @@ let () = in let printer = function | Xenopsd_error e -> - Some - (sprintf "Xenops_interface.Xenopsd_error(%s)" (string_of_error e)) - | _ -> None + Some (sprintf "Xenops_interface.Xenopsd_error(%s)" (string_of_error e)) + | _ -> + None in Printexc.register_printer printer let err = let open Error in - { def= Errors.error + { + def= Errors.error ; raiser= (fun e -> let exn = Xenopsd_error e in error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - raise exn ) + raise exn) ; matcher= (function - | Xenopsd_error e as exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - Some e - | exn -> - error "%s (%s)" (Printexc.to_string exn) __LOC__ ; - Some (Internal_error (Printexc.to_string exn))) } + | Xenopsd_error e as exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + Some e + | exn -> + error "%s (%s)" (Printexc.to_string exn) __LOC__ ; + Some (Internal_error (Printexc.to_string exn))) + } type debug_info = string [@@deriving rpcty] module Query = struct - type t = - { name: string + type t = { + name: string ; vendor: string ; version: string ; features: string list - ; instance_id: string - (* Unique to this invocation of xenopsd *) } + ; instance_id: string (* Unique to this invocation of xenopsd *) + } [@@deriving rpcty] end @@ -179,10 +187,10 @@ type disk_list = disk list (* XXX: this code shouldn't care about the vswitch/bridge difference *) module Network = struct type t = - | Local of string (** Name of a local switch *) + | Local of string (** Name of a local switch *) | Remote of string * string (** Vm.id * switch *) - | Sriov of Xcp_pci.address (** Xcp_pci.address *) - [@@deriving rpcty] + | Sriov of Xcp_pci.address (** Xcp_pci.address *) + [@@deriving rpcty] let default_network = Local "xenbr0" @@ -194,12 +202,13 @@ module Pci = struct type id = string * string [@@deriving rpcty] - type t = - { id: id + type t = { + id: id ; position: int ; address: address ; msitranslate: bool option - ; power_mgmt: bool option } + ; power_mgmt: bool option + } [@@deriving rpcty] type state = {plugged: bool} [@@deriving rpcty] @@ -212,17 +221,20 @@ module Vgpu = struct | GVT_g of gvt_g | Nvidia of nvidia | MxGPU of mxgpu - | Empty [@@default Empty] [@@deriving rpcty] + | Empty + [@@default Empty] [@@deriving rpcty] type id = string * string [@@deriving rpcty] - let pci_default = Pci.{domain = 0; bus = 0; dev = 0; fn = 0} - type t = - { id: id [@default "", ""] + let pci_default = Pci.{domain= 0; bus= 0; dev= 0; fn= 0} + + type t = { + id: id [@default "", ""] ; position: int [@default 0] - ; virtual_pci_address: Pci.address option [@default None] (* SRIOV VF *) + ; virtual_pci_address: Pci.address option [@default None] (* SRIOV VF *) ; physical_pci_address: Pci.address [@default pci_default] - ; implementation: implementation [@default Empty] } + ; implementation: implementation [@default Empty] + } [@@deriving rpcty] let upgrade_pci_info x = @@ -230,25 +242,31 @@ module Vgpu = struct | {implementation= GVT_g {physical_pci_address= Some address; _}; _} | {implementation= Nvidia {physical_pci_address= Some address; _}; _} | {implementation= MxGPU {physical_function= Some address; _}; _} -> - {x with physical_pci_address= address} - | _ -> x + {x with physical_pci_address= address} + | _ -> + x - type state = {active: bool; plugged: bool; emulator_pid: int option} [@@deriving rpcty] + type state = {active: bool; plugged: bool; emulator_pid: int option} + [@@deriving rpcty] end module Vusb = struct type id = string * string [@@deriving rpcty] - type t = - {id: id; hostbus: string; hostport: string; version: string; path: string; speed: float} + type t = { + id: id + ; hostbus: string + ; hostport: string + ; version: string + ; path: string + ; speed: float + } [@@deriving rpcty] type state = {plugged: bool} [@@deriving rpcty] end -module Vm = struct - include Xenops_types.Vm -end +module Vm = struct include Xenops_types.Vm end module Vbd = struct type mode = ReadOnly | ReadWrite [@@deriving rpcty] @@ -267,8 +285,8 @@ module Vbd = struct type qos = Ionice of qos_scheduler [@@deriving rpcty] - type t = - { id: id [@default "", ""] + type t = { + id: id [@default "", ""] ; position: Device_number.t option [@default None] ; mode: mode [@default ReadWrite] ; backend: disk option [@default None] @@ -277,14 +295,16 @@ module Vbd = struct ; extra_backend_keys: (string * string) list [@default []] ; extra_private_keys: (string * string) list [@default []] ; qos: qos option [@default None] - ; persistent: bool [@default true] } + ; persistent: bool [@default true] + } [@@deriving rpcty] - type state = - { active: bool + type state = { + active: bool ; plugged: bool ; qos_target: qos option - ; backend_present: disk option } + ; backend_present: disk option + } [@@deriving rpcty] end @@ -333,8 +353,8 @@ module Vif = struct type t = site * server list * interface [@@deriving rpcty] end - type t = - { id: id [@default "", ""] + type t = { + id: id [@default "", ""] ; position: int [@default 0] ; mac: string [@default "fe:ff:ff:ff:ff:ff"] ; carrier: bool [@default true] @@ -345,32 +365,35 @@ module Vif = struct ; locking_mode: locking_mode [@default default_locking_mode] ; extra_private_keys: (string * string) list [@default []] ; ipv4_configuration: ipv4_configuration - [@default default_ipv4_configuration] + [@default default_ipv4_configuration] ; ipv6_configuration: ipv6_configuration - [@default default_ipv6_configuration] + [@default default_ipv6_configuration] ; pvs_proxy: PVS_proxy.t option [@default None] - ; vlan: int64 option [@default None] } + ; vlan: int64 option [@default None] + } [@@deriving rpcty] - type state = - { active: bool + type state = { + active: bool ; plugged: bool ; kthread_pid: int ; media_present: bool ; device: string option - ; pvs_rules_active: bool } + ; pvs_rules_active: bool + } [@@deriving rpcty] end module Metadata = struct - type t = - { vm: Vm.t + type t = { + vm: Vm.t ; vbds: Vbd.t list [@default []] ; vifs: Vif.t list [@default []] ; pcis: Pci.t list [@default []] ; vgpus: Vgpu.t list [@default []] ; vusbs: Vusb.t list [@default []] - ; domains: string option [@default None] } + ; domains: string option [@default None] + } [@@deriving rpcty] end @@ -385,16 +408,17 @@ module Task = struct type state = Pending of float | Completed of completion_t | Failed of rpc_t [@@deriving rpcty] - type t = - { id: id + type t = { + id: id ; dbg: string ; ctime: float ; state: state ; subtasks: (string * state) list ; debug_info: (string * string) list - ; backtrace: string (* An s-expression encoded Backtrace.t *) - ; cancellable: bool - } + ; backtrace: string + ; (* An s-expression encoded Backtrace.t *) + cancellable: bool + } [@@deriving rpcty] type t_list = t list [@@deriving rpcty] @@ -427,8 +451,8 @@ module Dynamic = struct end module Host = struct - type cpu_info = - { cpu_count: int + type cpu_info = { + cpu_count: int ; socket_count: int ; vendor: string ; speed: string @@ -442,21 +466,26 @@ module Host = struct ; features_hvm: int64 array ; features_pv_host: int64 array ; features_hvm_host: int64 array - ; features_oldstyle: int64 array } + ; features_oldstyle: int64 array + } [@@deriving rpcty] type chipset_info = {iommu: bool; hvm: bool} [@@deriving rpcty] type hypervisor = {version: string; capabilities: string} [@@deriving rpcty] - type t = - { cpu_info: cpu_info + type t = { + cpu_info: cpu_info ; hypervisor: hypervisor - ; chipset_info: chipset_info } + ; chipset_info: chipset_info + } [@@deriving rpcty] - type guest_agent_feature = - {name: string; licensed: bool; parameters: (string * string) list} + type guest_agent_feature = { + name: string + ; licensed: bool + ; parameters: (string * string) list + } [@@deriving rpcty] type guest_agent_feature_list = guest_agent_feature list [@@deriving rpcty] @@ -467,10 +496,12 @@ module XenopsAPI (R : RPC) = struct let description = let open Interface in - { name= "Xen" + { + name= "Xen" ; namespace= None ; description= ["This interface is used by xapi to talk to xenopsd"] - ; version= (1, 0, 0) } + ; version= (1, 0, 0) + } let implementation = implement description @@ -490,12 +521,11 @@ module XenopsAPI (R : RPC) = struct let get_diagnostics = let result_p = Param.mk Rpc.Types.string in declare "get_diagnostics" - ["Get diagnostics information from the backend"] + ["Get diagnostics information from the backend"] (debug_info_p @-> unit_p @-> returning result_p err) module TASK = struct - let task_id_p = - Param.mk ~description:["Task identifier"] ~name:"id" Task.id + let task_id_p = Param.mk ~description:["Task identifier"] ~name:"id" Task.id let task_t_p = Param.mk ~description:["The state of the task"] ~name:"task" Task.t @@ -505,7 +535,8 @@ module XenopsAPI (R : RPC) = struct Task.t_list let stat = - declare "Task.stat" ["Get the state of the task"] + declare "Task.stat" + ["Get the state of the task"] (debug_info_p @-> task_id_p @-> returning task_t_p err) let cancel = @@ -517,14 +548,14 @@ module XenopsAPI (R : RPC) = struct (debug_info_p @-> task_id_p @-> returning unit_p err) let list = - declare "Task.list" ["List all the current tasks"] + declare "Task.list" + ["List all the current tasks"] (debug_info_p @-> returning task_list_p err) end module HOST = struct let host_t_p = - Param.mk ~description:["The state of the host"] ~name:"host" - Host.t + Param.mk ~description:["The state of the host"] ~name:"host" Host.t let console_data_p = Param.mk ~description:["The console data"] ~name:"console_data" @@ -538,8 +569,9 @@ module XenopsAPI (R : RPC) = struct Param.mk ~description:["The debug keys"] ~name:"debug_keys" Types.string let pool_size_p = - Param.mk ~description:["The size of the worker pool"] ~name:"pool_size" - Types.int + Param.mk + ~description:["The size of the worker pool"] + ~name:"pool_size" Types.int let feature_list_p = Param.mk ~description:["The list of features"] ~name:"features" @@ -548,19 +580,23 @@ module XenopsAPI (R : RPC) = struct type cpu_features_array = int64 array [@@deriving rpcty] let cpu_features_array_p = - Param.mk ~description:["An array containing the raw CPU feature flags"] + Param.mk + ~description:["An array containing the raw CPU feature flags"] ~name:"features_array" cpu_features_array let stat = - declare "HOST.stat" ["Get the state of the host"] + declare "HOST.stat" + ["Get the state of the host"] (debug_info_p @-> returning host_t_p err) let get_console_data = - declare "HOST.get_console_data" ["Get the console data of the host"] + declare "HOST.get_console_data" + ["Get the console data of the host"] (debug_info_p @-> returning console_data_p err) let get_total_memory_mib = - declare "HOST.get_total_memory_mib" ["Get the total memory of the host"] + declare "HOST.get_total_memory_mib" + ["Get the total memory of the host"] (debug_info_p @-> returning memory_p err) let send_debug_keys = @@ -578,8 +614,11 @@ module XenopsAPI (R : RPC) = struct let upgrade_cpu_features = let is_hvm_p = Param.mk ~name:"is_hvm" Types.bool in declare "HOST.upgrade_cpu_features" [] - ( debug_info_p @-> cpu_features_array_p @-> is_hvm_p - @-> returning cpu_features_array_p err ) + (debug_info_p + @-> cpu_features_array_p + @-> is_hvm_p + @-> returning cpu_features_array_p err + ) end module VM = struct @@ -605,15 +644,18 @@ module XenopsAPI (R : RPC) = struct let migrate = let vdimap = - Param.mk ~name:"vdi_map" ~description:["Map of src VDI -> dest VDI"] + Param.mk ~name:"vdi_map" + ~description:["Map of src VDI -> dest VDI"] (list (pair (Types.string, Types.string))) in let vifmap = - Param.mk ~name:"vif_map" ~description:["Map of src VIF -> dest network"] + Param.mk ~name:"vif_map" + ~description:["Map of src VIF -> dest network"] (list (pair (Types.string, Network.t))) in let pcimap = - Param.mk ~name:"pci_map" ~description:["Map of src PCI -> dest PCI"] + Param.mk ~name:"pci_map" + ~description:["Map of src PCI -> dest PCI"] (list (pair (Types.string, Pci.address))) in let xenops_url = @@ -622,8 +664,14 @@ module XenopsAPI (R : RPC) = struct Types.string in declare "VM.migrate" [] - ( debug_info_p @-> vm_id_p @-> vdimap @-> vifmap @-> pcimap - @-> xenops_url @-> returning task_id_p err ) + (debug_info_p + @-> vm_id_p + @-> vdimap + @-> vifmap + @-> pcimap + @-> xenops_url + @-> returning task_id_p err + ) let create = declare "VM.create" [] @@ -658,34 +706,46 @@ module XenopsAPI (R : RPC) = struct let run_script = declare "VM.run_script" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"script" Types.string - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_xsdata = declare "VM.set_xsdata" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"xsdata" (list (pair (Types.string, Types.string))) - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_vcpus = declare "VM.set_vcpus" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"vcpus" Types.int - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_shadow_multiplier = declare "VM.set_shadow_multiplier" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"multiplier" Types.float - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let set_memory_dynamic_range = let min_p = Param.mk ~name:"minimum" Types.int64 in let max_p = Param.mk ~name:"maximum" Types.int64 in declare "VM.set_memory_dynamic_range" [] - ( debug_info_p @-> vm_id_p @-> min_p @-> max_p - @-> returning task_id_p err ) + (debug_info_p + @-> vm_id_p + @-> min_p + @-> max_p + @-> returning task_id_p err + ) let stat = let stat_p = Param.mk (pair (Vm.t, Vm.state)) in @@ -702,9 +762,11 @@ module XenopsAPI (R : RPC) = struct let delay = declare "VM.delay" [] - ( debug_info_p @-> vm_id_p + (debug_info_p + @-> vm_id_p @-> Param.mk ~name:"delay" Types.float - @-> returning task_id_p err ) + @-> returning task_id_p err + ) let start = let paused_p = Param.mk ~name:"paused" Types.bool in @@ -745,16 +807,19 @@ module XenopsAPI (R : RPC) = struct let import_metadata = declare "VM.import_metadata" [] - ( debug_info_p + (debug_info_p @-> Param.mk ~name:"metadata" Types.string - @-> returning vm_id_p err ) + @-> returning vm_id_p err + ) end module PCI = struct open TypeCombinators let pci_t_p = Param.mk ~name:"pci" Pci.t + let pci_id_p = Param.mk ~name:"id" Pci.id + let pci_addr_p = Param.mk ~name:"pci_addr" Pci.address let add = @@ -776,7 +841,8 @@ module XenopsAPI (R : RPC) = struct (debug_info_p @-> VM.vm_id_p @-> returning stat_list_p err) let dequarantine = - declare "PCI.dequarantine" ["De-quarantine PCI device into dom0"] + declare "PCI.dequarantine" + ["De-quarantine PCI device into dom0"] (debug_info_p @-> pci_addr_p @-> returning unit_p err) end @@ -913,8 +979,11 @@ module XenopsAPI (R : RPC) = struct let set_locking_mode = let locking_mode_p = Param.mk ~name:"locking_mode" Vif.locking_mode in declare "VIF.set_locking_mode" [] - ( debug_info_p @-> vif_id_p @-> locking_mode_p - @-> returning task_id_p err ) + (debug_info_p + @-> vif_id_p + @-> locking_mode_p + @-> returning task_id_p err + ) let set_ipv4_configuration = let config_p = @@ -1002,10 +1071,11 @@ module XenopsAPI (R : RPC) = struct let trigger = declare "DEBUG.trigger" [] - ( debug_info_p + (debug_info_p @-> Param.mk ~name:"cmd" Types.string @-> Param.mk ~name:"args" (list Types.string) - @-> returning unit_p err ) + @-> returning unit_p err + ) let shutdown = declare "DEBUG.shutdown" [] diff --git a/xen/xenops_types.ml b/xen/xenops_types.ml index 6f52cc36..87aaa353 100644 --- a/xen/xenops_types.ml +++ b/xen/xenops_types.ml @@ -2,197 +2,171 @@ open Sexplib.Std open Xcp_pci module TopLevel = struct - type power_state = - | Running - | Halted - | Suspended - | Paused + type power_state = Running | Halted | Suspended | Paused [@@deriving sexp, rpcty] type disk = - | Local of string (** path to a local block device *) - | VDI of string (** typically "SR/VDI" *) + | Local of string (** path to a local block device *) + | VDI of string (** typically "SR/VDI" *) [@@deriving sexp, rpcty] end module Vgpu = struct type gvt_g = { - physical_pci_address: address option; (** unused; promoted to Vgpu.t *) - low_gm_sz: int64; - high_gm_sz: int64; - fence_sz: int64; - monitor_config_file: string option; - } [@@deriving sexp, rpcty] - - (** Example for nvidia: - { - physical_pci_address : None - config_file: None - virtual_pci_address : Some {domain; bus; device; fn} - type_id: 45 - uuid: aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee - extra_args:key1=v1,key2=v2,key3=v3 + physical_pci_address: address option (** unused; promoted to Vgpu.t *) + ; low_gm_sz: int64 + ; high_gm_sz: int64 + ; fence_sz: int64 + ; monitor_config_file: string option } - *) + [@@deriving sexp, rpcty] + + (** Example for nvidia: { physical_pci_address : None config_file: None + virtual_pci_address : Some {domain; bus; device; fn} type_id: 45 uuid: + aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee extra_args:key1=v1,key2=v2,key3=v3 } *) type nvidia = { - physical_pci_address: address option; (** unused; promoted to Vgpu.t *) - config_file: string option; - virtual_pci_address: address [@default {domain = 0000; bus = 0; dev = 11; fn = 0}]; - type_id: string option; - uuid: string option; - extra_args: string [@default ""]; (** string is passed on as is and no structure is assumed *) - } [@@deriving sexp, rpcty] + physical_pci_address: address option (** unused; promoted to Vgpu.t *) + ; config_file: string option + ; virtual_pci_address: address + [@default {domain= 0000; bus= 0; dev= 11; fn= 0}] + ; type_id: string option + ; uuid: string option + ; extra_args: string [@default ""] + (** string is passed on as is and no structure is assumed *) + } + [@@deriving sexp, rpcty] type mxgpu = { - physical_function: address option; (** unused; promoted to Vgpu.t *) - vgpus_per_pgpu: int64; - framebufferbytes: int64; - } [@@deriving sexp, rpcty] - + physical_function: address option (** unused; promoted to Vgpu.t *) + ; vgpus_per_pgpu: int64 + ; framebufferbytes: int64 + } + [@@deriving sexp, rpcty] end module Nvram_uefi_variables = struct - type onboot = - | Persist - | Reset - [@@deriving rpcty, sexp] + type onboot = Persist | Reset [@@deriving rpcty, sexp] type t = { - on_boot: onboot [@default Persist]; - backend: string [@default "xapidb"]; - } [@@deriving rpcty, sexp] + on_boot: onboot [@default Persist] + ; backend: string [@default "xapidb"] + } + [@@deriving rpcty, sexp] let default_t = match Rpcmarshal.unmarshal t.Rpc.Types.ty Rpc.(Dict []) with - | Ok x -> x + | Ok x -> + x | Error (`Msg m) -> - failwith (Printf.sprintf "Error creating Nvram_uefi_variables.default_t: %s" m) + failwith + (Printf.sprintf "Error creating Nvram_uefi_variables.default_t: %s" m) end module Vm = struct - type igd_passthrough = - | GVT_d - [@@deriving rpcty, sexp] + type igd_passthrough = GVT_d [@@deriving rpcty, sexp] type video_card = | Cirrus | Standard_VGA | Vgpu | IGD_passthrough of igd_passthrough - [@@default Cirrus] - [@@deriving rpcty, sexp] + [@@default Cirrus] [@@deriving rpcty, sexp] - type firmware_type = - | Bios - | Uefi of Nvram_uefi_variables.t + type firmware_type = Bios | Uefi of Nvram_uefi_variables.t [@@deriving rpcty, sexp] let default_firmware = Bios [@@deriving rpcty] type hvm_info = { - hap: bool [@default true]; - shadow_multiplier: float [@default 1.0]; - timeoffset: string [@default ""]; - video_mib: int [@default 4]; - video: video_card [@default Cirrus]; - acpi: bool [@default true]; - serial: string option [@default None]; - keymap: string option [@default None]; - vnc_ip: string option [@default None]; - pci_emulations: string list [@default []]; - pci_passthrough: bool [@default false]; - boot_order: string [@default ""]; - qemu_disk_cmdline: bool [@default false]; - qemu_stubdom: bool [@default false]; - firmware: firmware_type [@default default_firmware]; + hap: bool [@default true] + ; shadow_multiplier: float [@default 1.0] + ; timeoffset: string [@default ""] + ; video_mib: int [@default 4] + ; video: video_card [@default Cirrus] + ; acpi: bool [@default true] + ; serial: string option [@default None] + ; keymap: string option [@default None] + ; vnc_ip: string option [@default None] + ; pci_emulations: string list [@default []] + ; pci_passthrough: bool [@default false] + ; boot_order: string [@default ""] + ; qemu_disk_cmdline: bool [@default false] + ; qemu_stubdom: bool [@default false] + ; firmware: firmware_type [@default default_firmware] } [@@deriving rpcty, sexp] type pv_direct_boot = { - kernel: string [@default ""]; - cmdline: string [@default ""]; - ramdisk: string option [@default None]; + kernel: string [@default ""] + ; cmdline: string [@default ""] + ; ramdisk: string option [@default None] } [@@deriving rpcty, sexp] type pv_indirect_boot = { - bootloader: string [@default ""]; - extra_args: string [@default ""]; - legacy_args: string [@default ""]; - bootloader_args: string [@default ""]; - devices: TopLevel.disk list [@default []]; + bootloader: string [@default ""] + ; extra_args: string [@default ""] + ; legacy_args: string [@default ""] + ; bootloader_args: string [@default ""] + ; devices: TopLevel.disk list [@default []] } [@@deriving rpcty, sexp] - type pv_boot = - | Direct of pv_direct_boot - | Indirect of pv_indirect_boot + type pv_boot = Direct of pv_direct_boot | Indirect of pv_indirect_boot [@@deriving rpcty, sexp] type pv_info = { - boot: pv_boot; - framebuffer: bool [@default true]; - framebuffer_ip: string option [@default None]; - vncterm: bool [@default true]; - vncterm_ip: string option [@default None]; - pci_passthrough: bool [@default false] + boot: pv_boot + ; framebuffer: bool [@default true] + ; framebuffer_ip: string option [@default None] + ; vncterm: bool [@default true] + ; vncterm_ip: string option [@default None] + ; pci_passthrough: bool [@default false] } [@@deriving rpcty, sexp] - type builder_info = - | HVM of hvm_info - | PV of pv_info - | PVinPVH of pv_info + type builder_info = HVM of hvm_info | PV of pv_info | PVinPVH of pv_info [@@deriving rpcty, sexp] type id = string [@@deriving rpcty, sexp] - type action = - | Coredump - | Shutdown - | Start - | Pause - [@@deriving rpcty, sexp] + type action = Coredump | Shutdown | Start | Pause [@@deriving rpcty, sexp] type scheduler_params = { - priority: (int * int) option; (** weight, cap *) - affinity: int list list (** vcpu -> pcpu list *) - } [@@deriving rpcty, sexp] + priority: (int * int) option (** weight, cap *) + ; affinity: int list list (** vcpu -> pcpu list *) + } + [@@deriving rpcty, sexp] type t = { - id: id; - name: string [@default "unnamed"]; - ssidref: int32; - xsdata: (string * string) list; - platformdata: (string * string) list; - bios_strings: (string * string) list; - ty: builder_info; - suppress_spurious_page_faults: bool; - machine_address_size: int option; - memory_static_max: int64; - memory_dynamic_max: int64; - memory_dynamic_min: int64; - vcpu_max: int; (** boot-time maximum *) - vcpus: int; (** ideal number to use *) - scheduler_params: scheduler_params; - on_crash: action list; - on_shutdown: action list; - on_reboot: action list; - pci_msitranslate: bool; - pci_power_mgmt: bool; - has_vendor_device: bool [@default false]; - } [@@deriving rpcty, sexp] - - type console_protocol = - | Rfb - | Vt100 + id: id + ; name: string [@default "unnamed"] + ; ssidref: int32 + ; xsdata: (string * string) list + ; platformdata: (string * string) list + ; bios_strings: (string * string) list + ; ty: builder_info + ; suppress_spurious_page_faults: bool + ; machine_address_size: int option + ; memory_static_max: int64 + ; memory_dynamic_max: int64 + ; memory_dynamic_min: int64 + ; vcpu_max: int (** boot-time maximum *) + ; vcpus: int (** ideal number to use *) + ; scheduler_params: scheduler_params + ; on_crash: action list + ; on_shutdown: action list + ; on_reboot: action list + ; pci_msitranslate: bool + ; pci_power_mgmt: bool + ; has_vendor_device: bool [@default false] + } [@@deriving rpcty, sexp] - type console = { - protocol: console_protocol; - port: int; - path: string; - } [@@deriving rpcty, sexp] + type console_protocol = Rfb | Vt100 [@@deriving rpcty, sexp] + + type console = {protocol: console_protocol; port: int; path: string} + [@@deriving rpcty, sexp] type domain_type = | Domain_HVM @@ -202,24 +176,24 @@ module Vm = struct [@@deriving rpcty, sexp] type state = { - power_state: TopLevel.power_state; - domids: int list; - consoles: console list; - memory_target: int64; - memory_actual: int64; - memory_limit: int64; - vcpu_target: int; (** actual number of vcpus *) - shadow_multiplier_target: float; (** actual setting *) - rtc_timeoffset: string; - uncooperative_balloon_driver: bool; - guest_agent: (string * string) list; - xsdata_state: (string * string) list; - pv_drivers_detected: bool; - last_start_time: float; - hvm: bool; - nomigrate: bool; (** true means VM must not migrate *) - nested_virt: bool; (** true means VM uses nested virtualisation *) - domain_type: domain_type; - } [@@deriving rpcty, sexp] - + power_state: TopLevel.power_state + ; domids: int list + ; consoles: console list + ; memory_target: int64 + ; memory_actual: int64 + ; memory_limit: int64 + ; vcpu_target: int (** actual number of vcpus *) + ; shadow_multiplier_target: float (** actual setting *) + ; rtc_timeoffset: string + ; uncooperative_balloon_driver: bool + ; guest_agent: (string * string) list + ; xsdata_state: (string * string) list + ; pv_drivers_detected: bool + ; last_start_time: float + ; hvm: bool + ; nomigrate: bool (** true means VM must not migrate *) + ; nested_virt: bool (** true means VM uses nested virtualisation *) + ; domain_type: domain_type + } + [@@deriving rpcty, sexp] end From 77515fcb3735b11614321956c772a8b63dd704be Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 4 May 2020 10:12:30 +0100 Subject: [PATCH 10/42] maintenance: reformat comments with stars in them Signed-off-by: Pau Ruiz Safont --- cluster/cluster_client.ml | 2 +- lib/coverage/enabled.ml | 4 ++-- lib/debug.ml | 6 +++--- lib/task_server.ml | 3 ++- lib/updates.ml | 2 +- lib_test/device_number_test.ml | 2 +- memory/memory_interface.ml | 3 ++- rrd/ds.ml | 4 +++- rrd/rrd_interface.ml | 14 +++++++------- storage/storage_interface.ml | 11 ++++++----- storage/vdi_automaton.ml | 2 +- v6/v6_interface.ml | 2 +- .../varstore_deprivileged_interface.ml | 9 +++++---- 13 files changed, 35 insertions(+), 29 deletions(-) diff --git a/cluster/cluster_client.ml b/cluster/cluster_client.ml index 18a8260e..1ff675c4 100644 --- a/cluster/cluster_client.ml +++ b/cluster/cluster_client.ml @@ -14,5 +14,5 @@ let rpc_internal url call = let rpc url call = rpc_internal url call |> Idl.IdM.return (* There is also a Remote API between clustering daemons on different hosts. - * Call this a Local API because it is an API inside a host *) + Call this a Local API because it is an API inside a host *) module LocalClient = Cluster_interface.LocalAPI (IDL.GenClient ()) diff --git a/lib/coverage/enabled.ml b/lib/coverage/enabled.ml index 2b05579b..4d36e40d 100644 --- a/lib/coverage/enabled.ml +++ b/lib/coverage/enabled.ml @@ -1,4 +1,4 @@ -(** This module sets up the env variable for bisect_ppx which describes * where +(** This module sets up the env variable for bisect_ppx which describes where log files are written. *) module D = Debug.Make (struct let name = "coverage" end) @@ -123,7 +123,7 @@ module Dispatcher = struct () end -(** [init name] sets up coverage profiling for binary [name]. You could * use +(** [init name] sets up coverage profiling for binary [name]. You could use [Sys.argv.(0)] for [name]. *) let init name = D.info "About to initialize coverage runtime" ; diff --git a/lib/debug.ml b/lib/debug.ml index c3901aa3..96442986 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -60,9 +60,9 @@ let gettimestring () = tm.Unix.tm_sec (int_of_float (1000.0 *. msec)) -(** [escape str] efficiently escapes non-printable characters and in -* addition the backslash character. The function is efficient in the -* sense that it will allocate a new string only when necessary *) +(** [escape str] efficiently escapes non-printable characters and in addition + the backslash character. The function is efficient in the sense that it will + allocate a new string only when necessary *) let escape = Astring.String.Ascii.escape let format include_time brand priority message = diff --git a/lib/task_server.ml b/lib/task_server.ml index 3b054f05..e870324b 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -12,7 +12,8 @@ * GNU Lesser General Public License for more details. *) -(** * @group Xenops *) +(** @group Xenops *) + open Xapi_stdext_monadic open Xapi_stdext_pervasives.Pervasiveext diff --git a/lib/updates.ml b/lib/updates.ml index 2934b6ea..385d099b 100644 --- a/lib/updates.ml +++ b/lib/updates.ml @@ -212,7 +212,7 @@ functor type dump = { updates: u list ; barriers: (int * int * u list) list - (* In barriers, first int is token id of barrier; * second int is + (* In barriers, first int is token id of barrier; second int is event id of snapshot (from "next") *) } [@@deriving rpc] diff --git a/lib_test/device_number_test.ml b/lib_test/device_number_test.ml index 24cca8b9..79c662dd 100644 --- a/lib_test/device_number_test.ml +++ b/lib_test/device_number_test.ml @@ -65,7 +65,7 @@ let test_examples = tests (* NB we always understand the deprecated linux/xenstore devices even if we - * don't generate them ourselves *) + don't generate them ourselves *) let test_deprecated = let tests = List.map diff --git a/memory/memory_interface.ml b/memory/memory_interface.ml index 512a73c6..edd0ec69 100644 --- a/memory/memory_interface.ml +++ b/memory/memory_interface.ml @@ -12,7 +12,8 @@ * GNU Lesser General Public License for more details. *) -(** * @group Memory *) +(** @group Memory *) + open Rpc open Idl diff --git a/rrd/ds.ml b/rrd/ds.ml index 955923fd..620ba3fc 100644 --- a/rrd/ds.ml +++ b/rrd/ds.ml @@ -11,7 +11,9 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** Data source * @group Performance Monitoring *) +(** Data source + + @group Performance Monitoring *) (** This is used both for updating the DSs and for creating them *) type ds = { diff --git a/rrd/rrd_interface.ml b/rrd/rrd_interface.ml index e975c520..9a9c6035 100644 --- a/rrd/rrd_interface.ml +++ b/rrd/rrd_interface.ml @@ -53,13 +53,13 @@ type interdomain_uid = { } [@@deriving rpcty] -(* Note: for types such as rrd_req, which alias - * user-defined types, it is usually not enough - * to add [@@deriving rpcty] to derive RPC types, - * and rpc functions must be declared in the definition. - * However, types such as Rrd.sampling_frequency have - * already been defined as RPC types in their original declarations - * so we are able to derive these type aliases like so *) +(* Note: for types such as rrd_req, which alias user-defined types, it is + usually not enough to add [@@deriving rpcty] to derive RPC types, and rpc + functions must be declared in the definition. + + However, types such as Rrd.sampling_frequency have already been defined as + RPC types in their original declarations so we are able to derive these + type aliases like so *) type rrd_freq = Rrd.sampling_frequency = Five_Seconds [@@deriving rpcty] diff --git a/storage/storage_interface.ml b/storage/storage_interface.ml index a0bdb319..0008ce4a 100644 --- a/storage/storage_interface.ml +++ b/storage/storage_interface.ml @@ -12,7 +12,8 @@ * GNU Lesser General Public License for more details. *) -(** * @group Storage *) +(** @group Storage *) + open Rpc open Idl @@ -665,10 +666,10 @@ module StorageAPI (R : RPC) = struct @-> returning unit_p err ) - (** [update_snapshot_info_dest sr vdi dest src_vdi snapshot_pairs] * updates - the fields is_a_snapshot, snapshot_time and snapshot_of for a * list of - snapshots on a local SR. Typically, vdi will be a mirror of * src_vdi, - and for each item in snapshot_pairs the first will be a copy * of the + (** [update_snapshot_info_dest sr vdi dest src_vdi snapshot_pairs] updates + the fields is_a_snapshot, snapshot_time and snapshot_of for a list of + snapshots on a local SR. Typically, vdi will be a mirror of src_vdi, + and for each item in snapshot_pairs the first will be a copy of the second. *) let update_snapshot_info_dest = let src_vdi_p = Param.mk ~name:"src_vdi" vdi_info in diff --git a/storage/vdi_automaton.ml b/storage/vdi_automaton.ml index 76128189..e36de90e 100644 --- a/storage/vdi_automaton.ml +++ b/storage/vdi_automaton.ml @@ -11,7 +11,7 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -(** * @group Storage *) +(** @group Storage *) (** An automaton representing the VDI state machine *) diff --git a/v6/v6_interface.ml b/v6/v6_interface.ml index 85be7936..11ba7eeb 100644 --- a/v6/v6_interface.ml +++ b/v6/v6_interface.ml @@ -72,7 +72,7 @@ type string_pair_lst = (string * string) list [@@deriving rpcty] (** Wrapper for specific errors in managing features *) type errors = | Invalid_edition of string - (** Thrown by apply_edition on receiving unfamiliar edition. * Note: + (** Thrown by apply_edition on receiving unfamiliar edition. Note: get_editions returns list of all valid editions *) | License_expired (** Thrown by license_check when expiry date matches or precedes current diff --git a/varstore/deprivileged/varstore_deprivileged_interface.ml b/varstore/deprivileged/varstore_deprivileged_interface.ml index c4734f0a..e418dc4d 100644 --- a/varstore/deprivileged/varstore_deprivileged_interface.ml +++ b/varstore/deprivileged/varstore_deprivileged_interface.ml @@ -44,10 +44,11 @@ module RPC_API (R : RPC) = struct let int64_p = Param.mk Types.int64 - (* The APIs here should be wire-compatible with the ones in XAPI, - * but ignore the parameters that varstored is not allowed to override, - * e.g. the VM ref or session id. - * The parameters cannot be named *) + (* The APIs here should be wire-compatible with the ones in XAPI, but ignore + the parameters that varstored is not allowed to override, e.g. the VM ref + or session id. + + The parameters cannot be named *) let session_login = declare "session.login_with_password" From 4a1c7c3256f8036add72bbe3ad7bc2a88be66e6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:24:23 +0100 Subject: [PATCH 11/42] maintenance: formatting fixes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/task_server.ml | 1 - memory/memory_interface.ml | 1 - storage/storage_interface.ml | 1 - storage/storage_test.ml | 16 ++++++++++------ 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/lib/task_server.ml b/lib/task_server.ml index e870324b..531204ce 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -15,7 +15,6 @@ (** @group Xenops *) open Xapi_stdext_monadic - open Xapi_stdext_pervasives.Pervasiveext open Xapi_stdext_threads.Threadext diff --git a/memory/memory_interface.ml b/memory/memory_interface.ml index edd0ec69..a74ec46b 100644 --- a/memory/memory_interface.ml +++ b/memory/memory_interface.ml @@ -15,7 +15,6 @@ (** @group Memory *) open Rpc - open Idl module D = Debug.Make (struct let name = "memory_interface" end) diff --git a/storage/storage_interface.ml b/storage/storage_interface.ml index 0008ce4a..6762b3e5 100644 --- a/storage/storage_interface.ml +++ b/storage/storage_interface.ml @@ -15,7 +15,6 @@ (** @group Storage *) open Rpc - open Idl module D = Debug.Make (struct let name = "storage_interface" end) diff --git a/storage/storage_test.ml b/storage/storage_test.ml index 98eb1fb1..6d8d15a2 100644 --- a/storage/storage_test.ml +++ b/storage/storage_test.ml @@ -15,9 +15,11 @@ open Storage_interface open Storage_client -(* Principles: 1. we don't delete or manipulate VDIs we didn't create 2. we - create VDIs with non-clashing names 3. we always clean up (as best we can) - after every test. *) +(* Principles: + 1. we don't delete or manipulate VDIs we didn't create + 2. we create VDIs with non-clashing names + 3. we always clean up (as best we can) after every test. +*) (* We assume that no-one else has made VDIs with this name prefix: *) let safe_prefix = Printf.sprintf "storage_test.%d" (Unix.getpid ()) @@ -53,9 +55,11 @@ let names = ; String.make 128 '0' ] -(* For each VDI we check that: 1. it shows up in a SR.scan 2. attach RO, - activate, deactivate, detach works 3. attach RW, activate, deactivate, detach - works *) +(* For each VDI we check that: + 1. it shows up in a SR.scan + 2. attach RO, activate, deactivate, detach works + 3. attach RW, activate, deactivate, detach works +*) let vdi_exists sr vdi = let all = Client.SR.scan dbg sr in From 03e7a2fa040965cf0c3970399f9dd8894876ef87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:16:32 +0100 Subject: [PATCH 12/42] maintenance: fix (deprecation) warnings MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit send_msg/recv_msg in Lwt_unix is deprecated because it doesn't take the correct string vs bytes type. Use the Versioned.recv_msg_2 as suggested by the deprecation notice. This avoids mutating string types. Signed-off-by: Edwin Török --- lib_test/channel_test.ml | 4 ++-- misc/channel_helper.ml | 22 ++++++++++------------ misc/dune | 1 + storage/storage_test.ml | 2 +- 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/lib_test/channel_test.ml b/lib_test/channel_test.ml index 92901a74..739fc54e 100644 --- a/lib_test/channel_test.ml +++ b/lib_test/channel_test.ml @@ -45,13 +45,13 @@ let dup_proxy x = let proto = List.find (function - | Xcp_channel_protocol.TCP_proxy (ip, port) -> true | _ -> false) + | Xcp_channel_protocol.TCP_proxy (_ip, _port) -> true | _ -> false) protos in Posix_channel.receive [proto] let check_for_leak_proxy () = - let a, b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in + let a, _b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in let before = count_fds () in let c = dup_proxy a in (* background fd closing *) diff --git a/misc/channel_helper.ml b/misc/channel_helper.ml index f4a3c84e..bf600d52 100644 --- a/misc/channel_helper.ml +++ b/misc/channel_helper.ml @@ -127,19 +127,17 @@ let advertise_t _common_options_t proxy_socket = let t_unix = Lwt_unix.accept s_unix >>= fun (fd, _peer) -> let buffer = Bytes.make (String.length token) '\000' in - let io_vector = - Lwt_unix.io_vector - ~buffer:(Bytes.unsafe_to_string buffer) - ~offset:0 ~length:(Bytes.length buffer) - in - Lwt_unix.recv_msg ~socket:fd ~io_vectors:[io_vector] >>= fun (n, fds) -> + let io_vector = Lwt_unix.IO_vectors.create () in + Lwt_unix.IO_vectors.append_bytes io_vector buffer 0 (Bytes.length buffer) ; + Lwt_unix.Versioned.recv_msg_2 ~socket:fd ~io_vectors:io_vector + >>= fun (n, fds) -> List.iter Unix.close fds ; - let token' = Bytes.sub_string buffer 0 n in - let io_vector' = - Lwt_unix.io_vector ~buffer:token' ~offset:0 ~length:(String.length token') - in - if token = token' then - Lwt_unix.send_msg ~socket:fd ~io_vectors:[io_vector'] ~fds:[proxy_socket] + let token' = Bytes.sub buffer 0 n in + let io_vector' = Lwt_unix.IO_vectors.create () in + Lwt_unix.IO_vectors.append_bytes io_vector' token' 0 (Bytes.length token') ; + if token = Bytes.to_string token' then + Lwt_unix.Versioned.send_msg_2 ~socket:fd ~io_vectors:io_vector' + ~fds:[proxy_socket] >>= fun _ -> return () else return () diff --git a/misc/dune b/misc/dune index 60dc72dd..40eb98e7 100644 --- a/misc/dune +++ b/misc/dune @@ -7,4 +7,5 @@ lwt.unix xapi-idl ) + (flags (:standard -w -39)) (preprocess (pps ppx_deriving_rpc))) diff --git a/storage/storage_test.ml b/storage/storage_test.ml index 6d8d15a2..4a7cdd22 100644 --- a/storage/storage_test.ml +++ b/storage/storage_test.ml @@ -167,7 +167,7 @@ let vdi_resize sr = open Cmdliner -let start verbose queue sr = +let start _verbose queue sr = match (queue, sr) with | Some queue, Some sr -> Storage_interface.queue_name := queue ; From be5ec7e6b200ba506aafef0295d99adef4b19c1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:15:49 +0100 Subject: [PATCH 13/42] maintenance: drop unused Scheduler code MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Scheduler.Absolute is unused, this will allow us to switch to using monotonic time. Drop duplicate code that is already present in stdext, in particular we got a better finally there. Scheduler.shutdown was never called/tested: schedulers are always global. Signed-off-by: Edwin Török --- lib/scheduler.ml | 63 ++++++++++---------------------------- lib/scheduler.mli | 12 ++------ lib_test/scheduler_test.ml | 10 ------ 3 files changed, 19 insertions(+), 66 deletions(-) diff --git a/lib/scheduler.ml b/lib/scheduler.ml index b41e7542..58ab4051 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -12,15 +12,8 @@ * GNU Lesser General Public License for more details. *) -let finally f g = - try - let result = f () in - g () ; result - with e -> g () ; raise e - -let mutex_execute m f = - Mutex.lock m ; - finally f (fun () -> Mutex.unlock m) +open Xapi_stdext_pervasives +open Xapi_stdext_threads module D = Debug.Make (struct let name = "scheduler" end) @@ -55,11 +48,11 @@ module Delay = struct if List.mem fd !to_close then Unix.close fd ; to_close := List.filter (fun x -> fd <> x) !to_close in - finally + Pervasiveext.finally (fun () -> try let pipe_out = - mutex_execute x.m (fun () -> + Threadext.Mutex.execute x.m (fun () -> if x.signalled then ( x.signalled <- false ; raise Pre_signalled @@ -80,13 +73,13 @@ module Delay = struct r = [] with Pre_signalled -> false) (fun () -> - mutex_execute x.m (fun () -> + Threadext.Mutex.execute x.m (fun () -> x.pipe_out <- None ; x.pipe_in <- None ; List.iter close' !to_close)) let signal (x : t) = - mutex_execute x.m (fun () -> + Threadext.Mutex.execute x.m (fun () -> match x.pipe_in with | Some fd -> ignore (Unix.write fd (Bytes.of_string "X") 0 1) @@ -101,14 +94,12 @@ type handle = int64 * int [@@deriving rpc] type t = { mutable schedule: item list Int64Map.t - ; mutable shutdown: bool ; delay: Delay.t ; mutable next_id: int - ; mutable thread: Thread.t option ; m: Mutex.t } -type time = Absolute of int64 | Delta of int +type time = Delta of int (*type t = int64 * int [@@deriving rpc]*) @@ -121,7 +112,7 @@ module Dump = struct let make s = let now = now () in - mutex_execute s.m (fun () -> + Threadext.Mutex.execute s.m (fun () -> Int64Map.fold (fun time xs acc -> List.map (fun i -> {time= Int64.sub time now; thing= i.name}) xs @@ -129,16 +120,10 @@ module Dump = struct s.schedule []) end -let one_shot s time (name : string) f = - let time = - match time with - | Absolute x -> - x - | Delta x -> - Int64.(add (of_int x) (now ())) - in +let one_shot s (Delta x) (name : string) f = + let time = Int64.(add (of_int x) (now ())) in let id = - mutex_execute s.m (fun () -> + Threadext.Mutex.execute s.m (fun () -> let existing = try Int64Map.find time s.schedule with _ -> [] in let id = s.next_id in s.next_id <- s.next_id + 1 ; @@ -150,7 +135,7 @@ let one_shot s time (name : string) f = (time, id) let cancel s (time, id) = - mutex_execute s.m (fun () -> + Threadext.Mutex.execute s.m (fun () -> let existing = if Int64Map.mem time s.schedule then Int64Map.find time s.schedule @@ -165,7 +150,7 @@ let cancel s (time, id) = let process_expired s = let t = now () in let expired = - mutex_execute s.m (fun () -> + Threadext.Mutex.execute s.m (fun () -> let expired, unexpired = Int64Map.partition (fun t' _ -> t' <= t) s.schedule in @@ -188,36 +173,22 @@ let rec main_loop s = () done ; let sleep_until = - mutex_execute s.m (fun () -> + Threadext.Mutex.execute s.m (fun () -> try Int64Map.min_binding s.schedule |> fst with Not_found -> Int64.add 3600L (now ())) in let seconds = Int64.sub sleep_until (now ()) in let (_ : bool) = Delay.wait s.delay (Int64.to_float seconds) in - if s.shutdown then s.thread <- None else main_loop s - -let start s = - if s.shutdown then failwith "Scheduler was shutdown" ; - s.thread <- Some (Thread.create main_loop s) + main_loop s let make () = let s = { schedule= Int64Map.empty - ; shutdown= false ; delay= Delay.make () ; next_id= 0 ; m= Mutex.create () - ; thread= None } in - start s ; s - -let shutdown s = - match s.thread with - | Some th -> - s.shutdown <- true ; - Delay.signal s.delay ; - Thread.join th - | None -> - () + let (_ : Thread.t) = Thread.create main_loop s in + s diff --git a/lib/scheduler.mli b/lib/scheduler.mli index a634af95..f0515422 100644 --- a/lib/scheduler.mli +++ b/lib/scheduler.mli @@ -26,12 +26,8 @@ val handle_of_rpc : Rpc.t -> handle val make : unit -> t (** Creates a scheduler *) -(** Items can be scheduled at an absolute time (measured in seconds since unix - epoch) or as a delta measured in for seconds from now. *) -type time = Absolute of int64 | Delta of int - -val now : unit -> int64 -(** Useful for Absolutely scheduled items *) +(** Items can be scheduled as a delta measured in seconds from now. *) +type time = Delta of int (** This module is for dumping the state of a scheduler *) module Dump : sig @@ -51,7 +47,3 @@ val one_shot : t -> time -> string -> (unit -> unit) -> handle val cancel : t -> handle -> unit (** Cancel an item *) - -val shutdown : t -> unit -(** shutdown a scheduler. Any item currently scheduled will not be executed. The - scheduler cannot be restarted. *) diff --git a/lib_test/scheduler_test.ml b/lib_test/scheduler_test.ml index 63c38a0f..f076a668 100644 --- a/lib_test/scheduler_test.ml +++ b/lib_test/scheduler_test.ml @@ -57,15 +57,6 @@ let test_one_shot () = @@ Scheduler.one_shot global_scheduler (Scheduler.Delta 1) "test_one_shot" callback) -(* Test the injection of a one-shot function at an absolute time *) -let test_one_shot_abs () = - timed_wait_callback ~msg:"one_shot_abs_success" ~time_min:1.0 (fun callback -> - let now = Scheduler.now () in - ignore - @@ Scheduler.one_shot global_scheduler - (Scheduler.Absolute (Int64.add 1L now)) - "test_one_shot" callback) - (* Tests that the scheduler still works even after a failure occurs in the injected function *) let test_one_shot_failure () = @@ -108,7 +99,6 @@ let tests = ("Test Delay", `Slow, test_delay) ; ("Test Delay cancellation", `Quick, test_delay_cancel) ; ("Test One shot", `Slow, test_one_shot) - ; ("Test One shot absolute", `Slow, test_one_shot_abs) ; ("Test One shot failure", `Slow, test_one_shot_failure) ; ("Test One shot cancellation", `Slow, test_one_shot_cancel) ; ("Test dump", `Quick, test_dump) From 38b2a226e08656c74b7bda61f7e6d5c77dc86ecc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:16:36 +0100 Subject: [PATCH 14/42] CA-338201: use a more efficient way of splitting a map MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit There is a builtin way of splitting a Map: Map.split. This is more efficient than partitioning a map, because partitioning needs to walk the entire map, whereas splitting can stop as soon as it finds a sub-tree that is greater than, and piece together subtrees. I assume that rounding was applied for scheduled events to have some form of batching, and to have a more efficient way of picking next item to schedule (we can skip an entire list of jobs scheduled at second 7, if we are at second 5). However if we have jobs with various schedules the map can still grow and require a linear walk. Signed-off-by: Edwin Török --- lib/scheduler.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/scheduler.ml b/lib/scheduler.ml index 58ab4051..0810662f 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -151,8 +151,9 @@ let process_expired s = let t = now () in let expired = Threadext.Mutex.execute s.m (fun () -> - let expired, unexpired = - Int64Map.partition (fun t' _ -> t' <= t) s.schedule + let lt, eq, unexpired = Int64Map.split t s.schedule in + let expired = + match eq with None -> lt | Some eq -> Int64Map.add t eq lt in s.schedule <- unexpired ; Int64Map.fold (fun _ stuff acc -> acc @ stuff) expired [] |> List.rev) From 8cb133e12021b1a9a781a71b6950546cf955d566 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:16:38 +0100 Subject: [PATCH 15/42] Optimization: store handles in the map MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Simplify the code by storing unique handles in the map (time + unique counter). This allows more efficient deletion. Signed-off-by: Edwin Török --- lib/scheduler.ml | 76 +++++++++++++++++++++--------------------------- 1 file changed, 33 insertions(+), 43 deletions(-) diff --git a/lib/scheduler.ml b/lib/scheduler.ml index 0810662f..da58e4f2 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -19,12 +19,6 @@ module D = Debug.Make (struct let name = "scheduler" end) open D -module Int64Map = Map.Make (struct - type t = int64 - - let compare = Int64.compare -end) - module Delay = struct (* Concrete type is the ends of a pipe *) type t = { @@ -88,12 +82,23 @@ module Delay = struct (* If the wait hasn't happened yet then store up the signal *)) end -type item = {id: int; name: string; fn: unit -> unit} - type handle = int64 * int [@@deriving rpc] +module HandleMap = Map.Make (struct + type t = handle + + let compare (x1, id1) (x2, id2) = + let c = Int64.compare x1 x2 in + if c = 0 then + id2 - id1 + else + c +end) + +type item = {id: int; name: string; fn: unit -> unit} + type t = { - mutable schedule: item list Int64Map.t + mutable schedule: item HandleMap.t ; delay: Delay.t ; mutable next_id: int ; m: Mutex.t @@ -113,50 +118,35 @@ module Dump = struct let make s = let now = now () in Threadext.Mutex.execute s.m (fun () -> - Int64Map.fold - (fun time xs acc -> - List.map (fun i -> {time= Int64.sub time now; thing= i.name}) xs - @ acc) + HandleMap.fold + (fun (time, _) i acc -> + {time= Int64.sub time now; thing= i.name} :: acc) s.schedule []) end let one_shot s (Delta x) (name : string) f = let time = Int64.(add (of_int x) (now ())) in - let id = - Threadext.Mutex.execute s.m (fun () -> - let existing = try Int64Map.find time s.schedule with _ -> [] in - let id = s.next_id in - s.next_id <- s.next_id + 1 ; - let item = {id; name; fn= f} in - s.schedule <- Int64Map.add time (item :: existing) s.schedule ; - Delay.signal s.delay ; - id) - in - (time, id) - -let cancel s (time, id) = Threadext.Mutex.execute s.m (fun () -> - let existing = - if Int64Map.mem time s.schedule then - Int64Map.find time s.schedule - else - [] - in - s.schedule <- - Int64Map.add time - (List.filter (fun i -> i.id <> id) existing) - s.schedule) + let id = s.next_id in + s.next_id <- s.next_id + 1 ; + let item = {id; name; fn= f} in + let handle = (time, id) in + s.schedule <- HandleMap.add handle item s.schedule ; + Delay.signal s.delay ; + handle) + +let cancel s handle = + Threadext.Mutex.execute s.m (fun () -> + s.schedule <- HandleMap.remove handle s.schedule) let process_expired s = let t = now () in let expired = Threadext.Mutex.execute s.m (fun () -> - let lt, eq, unexpired = Int64Map.split t s.schedule in - let expired = - match eq with None -> lt | Some eq -> Int64Map.add t eq lt - in + let expired, eq, unexpired = HandleMap.split (t, max_int) s.schedule in + assert (eq = None) ; s.schedule <- unexpired ; - Int64Map.fold (fun _ stuff acc -> acc @ stuff) expired [] |> List.rev) + HandleMap.bindings expired |> List.rev_map snd) in (* This might take a while *) List.iter @@ -175,7 +165,7 @@ let rec main_loop s = done ; let sleep_until = Threadext.Mutex.execute s.m (fun () -> - try Int64Map.min_binding s.schedule |> fst + try HandleMap.min_binding s.schedule |> fst |> fst with Not_found -> Int64.add 3600L (now ())) in let seconds = Int64.sub sleep_until (now ()) in @@ -185,7 +175,7 @@ let rec main_loop s = let make () = let s = { - schedule= Int64Map.empty + schedule= HandleMap.empty ; delay= Delay.make () ; next_id= 0 ; m= Mutex.create () From 540fe948437de2a6920c25ca2c719faf70b83afe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:16:40 +0100 Subject: [PATCH 16/42] Optimization: do not build intermediate list MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- lib/scheduler.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/scheduler.ml b/lib/scheduler.ml index da58e4f2..388643ce 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -146,16 +146,16 @@ let process_expired s = let expired, eq, unexpired = HandleMap.split (t, max_int) s.schedule in assert (eq = None) ; s.schedule <- unexpired ; - HandleMap.bindings expired |> List.rev_map snd) + expired |> HandleMap.to_seq |> Seq.map snd) in (* This might take a while *) - List.iter + Seq.iter (fun i -> try i.fn () with e -> debug "Scheduler ignoring exception: %s\n%!" (Printexc.to_string e)) expired ; - expired <> [] + expired () <> Seq.Nil (* true if work was done *) From f23bb9ffd0b73d5222f50d69f8595221fd6b2eba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:17:10 +0100 Subject: [PATCH 17/42] CA-338201: use mtime MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Use Mtime which has greater precision than seconds. This fixes CA-338201 where due to rounding you could've ended up waiting less than the expected amount of time. Using monotonic time for relative waits should be more robust (especially against NTP changes), and is already used by XAPI's periodic scheduler. Rpc.t serialization is backwards compatible, so we don't raise exceptions when deserializing handles from old XAPIs (we may have a handle serialized by the storage migration code in XAPI). However serialization/deserialization only makes sense within the same XAPI process, as otherwise you deserialize a handle which is not registered in the scheduler, so we wouldn't expect the old handles to work any way, so there is no attempt to fix up the Mtime portion of the handle, since the id would be invalid anyway. Signed-off-by: Edwin Török --- lib/dune | 2 ++ lib/scheduler.ml | 42 ++++++++++++++++++++++++++++++++++-------- 2 files changed, 36 insertions(+), 8 deletions(-) diff --git a/lib/dune b/lib/dune index 079181b4..4616ec38 100644 --- a/lib/dune +++ b/lib/dune @@ -14,6 +14,8 @@ logs message-switch-core message-switch-unix + mtime + mtime.clock.os ppx_sexp_conv.runtime-lib re rpclib.core diff --git a/lib/scheduler.ml b/lib/scheduler.ml index 388643ce..ab935e11 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -82,13 +82,21 @@ module Delay = struct (* If the wait hasn't happened yet then store up the signal *)) end -type handle = int64 * int [@@deriving rpc] +type handle = Mtime.span * int + +type handle_compat = int64 * int [@@deriving rpc] + +let rpc_of_handle (s, id) = rpc_of_handle_compat (Mtime.Span.to_uint64_ns s, id) + +let handle_of_rpc rpc = + let i64, id = handle_compat_of_rpc rpc in + (Mtime.Span.of_uint64_ns i64, id) module HandleMap = Map.Make (struct type t = handle let compare (x1, id1) (x2, id2) = - let c = Int64.compare x1 x2 in + let c = Mtime.Span.compare x1 x2 in if c = 0 then id2 - id1 else @@ -108,7 +116,11 @@ type time = Delta of int (*type t = int64 * int [@@deriving rpc]*) -let now () = Unix.gettimeofday () |> ceil |> Int64.of_float +let time_of_span span = span |> Mtime.Span.to_s |> ceil |> Int64.of_float + +let mtime_sub time now = Mtime.Span.abs_diff time now |> time_of_span + +let now () = Mtime_clock.elapsed () module Dump = struct type u = {time: int64; thing: string} [@@deriving rpc] @@ -120,12 +132,18 @@ module Dump = struct Threadext.Mutex.execute s.m (fun () -> HandleMap.fold (fun (time, _) i acc -> - {time= Int64.sub time now; thing= i.name} :: acc) + {time= mtime_sub time now; thing= i.name} :: acc) s.schedule []) end +let mtime_add x t = + let dt = + Mtime.(float x *. Mtime.s_to_ns |> Int64.of_float |> Span.of_uint64_ns) + in + Mtime.Span.add dt t + let one_shot s (Delta x) (name : string) f = - let time = Int64.(add (of_int x) (now ())) in + let time = mtime_add x (now ()) in Threadext.Mutex.execute s.m (fun () -> let id = s.next_id in s.next_id <- s.next_id + 1 ; @@ -166,10 +184,18 @@ let rec main_loop s = let sleep_until = Threadext.Mutex.execute s.m (fun () -> try HandleMap.min_binding s.schedule |> fst |> fst - with Not_found -> Int64.add 3600L (now ())) + with Not_found -> mtime_add 3600 (now ())) + in + let this = now () in + let seconds = + if Mtime.Span.compare sleep_until this > 0 then + (* be careful that this is absolute difference, + it is never negative! *) + Mtime.Span.(abs_diff sleep_until this |> to_s) + else + 0. in - let seconds = Int64.sub sleep_until (now ()) in - let (_ : bool) = Delay.wait s.delay (Int64.to_float seconds) in + let (_ : bool) = Delay.wait s.delay seconds in main_loop s let make () = From 4f41cc672245f5022a0d12ec602e41545341e88f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 28 May 2020 17:17:13 +0100 Subject: [PATCH 18/42] CA-337546: use a single persistent pipe per scheduler, avoid using pipes in Delay.wait MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Less chance of failure, and more predictable resource usage. Now we only need 2 file descriptors per scheduler, instead of 2 file descriptors for each active Delay.wait/signal call. The method of adding a oneshot entry to the scheduler that wakes up the condition variable's waiter is already used by Updates.get, and xapi_event code. Since pipes are open at PipeDelay.make () time we don't need to deal with pre-signalling (calling .signal before .wait) explicitly: signal will write a byte to the pipe, and wait will find it and not go to sleep. We also don't need a mutex for dealing with pipes. We do need to deal with pre-signalling in the Delay code. Also the old code didn't handle spurious wakeups from Condition.wait. According to the POSIX manpage for pthread_cond_wait it can spuriously wake up for any reason, so you're meant to check that you achieved the condition you were waiting for a in a loop to be robust. (the Linux manpage doesn't mention this though). Be more robust and handle spurious wakeups and pre-signalling in one go: we explicitly set our state to Signalled while holding a mutex, and explicitly set our state to TimedOut from the oneshot handler. That way we can loop until either of these is set and spurious wakeups or not guarantee we only exit the loop when one of these is true. Ideally we would've used `pthread_cond_timedwait` instead of all of this, but that is not available in the OCaml standard library and writing a C binding would need to duplicate the mutex/condition bindings too since those cannot be accessed from a C binding: the headers implementing them are private. Signed-off-by: Edwin Török --- lib/scheduler.ml | 130 +++++++++++++++++++++++++---------------------- 1 file changed, 68 insertions(+), 62 deletions(-) diff --git a/lib/scheduler.ml b/lib/scheduler.ml index ab935e11..bd0628f5 100644 --- a/lib/scheduler.ml +++ b/lib/scheduler.ml @@ -12,74 +12,38 @@ * GNU Lesser General Public License for more details. *) -open Xapi_stdext_pervasives open Xapi_stdext_threads module D = Debug.Make (struct let name = "scheduler" end) open D -module Delay = struct +module PipeDelay = struct (* Concrete type is the ends of a pipe *) type t = { (* A pipe is used to wake up a thread blocked in wait: *) - mutable pipe_out: Unix.file_descr option - ; mutable pipe_in: Unix.file_descr option - ; (* Indicates that a signal arrived before a wait: *) - mutable signalled: bool - ; m: Mutex.t + pipe_out: Unix.file_descr + ; pipe_in: Unix.file_descr } let make () = - {pipe_out= None; pipe_in= None; signalled= false; m= Mutex.create ()} - - exception Pre_signalled + let pipe_out, pipe_in = Unix.pipe () in + {pipe_out; pipe_in} let wait (x : t) (seconds : float) = let timeout = if seconds < 0.0 then 0.0 else seconds in - let to_close = ref [] in - let close' fd = - if List.mem fd !to_close then Unix.close fd ; - to_close := List.filter (fun x -> fd <> x) !to_close - in - Pervasiveext.finally - (fun () -> - try - let pipe_out = - Threadext.Mutex.execute x.m (fun () -> - if x.signalled then ( - x.signalled <- false ; - raise Pre_signalled - ) ; - let pipe_out, pipe_in = Unix.pipe () in - (* these will be unconditionally closed on exit *) - to_close := [pipe_out; pipe_in] ; - x.pipe_out <- Some pipe_out ; - x.pipe_in <- Some pipe_in ; - x.signalled <- false ; - pipe_out) - in - let r, _, _ = Unix.select [pipe_out] [] [] timeout in - (* flush the single byte from the pipe *) - if r <> [] then ignore (Unix.read pipe_out (Bytes.create 1) 0 1) ; - (* return true if we waited the full length of time, false if we were - woken *) - r = [] - with Pre_signalled -> false) - (fun () -> - Threadext.Mutex.execute x.m (fun () -> - x.pipe_out <- None ; - x.pipe_in <- None ; - List.iter close' !to_close)) + if Thread.wait_timed_read x.pipe_out timeout then + (* flush the single byte from the pipe *) + let (_ : int) = Unix.read x.pipe_out (Bytes.create 1) 0 1 in + (* return false if we were woken *) + false + else + (* return true if we waited the full length of time, false if we were woken *) + true let signal (x : t) = - Threadext.Mutex.execute x.m (fun () -> - match x.pipe_in with - | Some fd -> - ignore (Unix.write fd (Bytes.of_string "X") 0 1) - | None -> - x.signalled <- true - (* If the wait hasn't happened yet then store up the signal *)) + let (_ : int) = Unix.write x.pipe_in (Bytes.of_string "X") 0 1 in + () end type handle = Mtime.span * int @@ -107,7 +71,7 @@ type item = {id: int; name: string; fn: unit -> unit} type t = { mutable schedule: item HandleMap.t - ; delay: Delay.t + ; delay: PipeDelay.t ; mutable next_id: int ; m: Mutex.t } @@ -137,22 +101,22 @@ module Dump = struct end let mtime_add x t = - let dt = - Mtime.(float x *. Mtime.s_to_ns |> Int64.of_float |> Span.of_uint64_ns) - in + let dt = Mtime.(x *. Mtime.s_to_ns |> Int64.of_float |> Span.of_uint64_ns) in Mtime.Span.add dt t -let one_shot s (Delta x) (name : string) f = - let time = mtime_add x (now ()) in +let one_shot_f s dt (name : string) f = + let time = mtime_add dt (now ()) in Threadext.Mutex.execute s.m (fun () -> let id = s.next_id in s.next_id <- s.next_id + 1 ; let item = {id; name; fn= f} in let handle = (time, id) in s.schedule <- HandleMap.add handle item s.schedule ; - Delay.signal s.delay ; + PipeDelay.signal s.delay ; handle) +let one_shot s (Delta x) name f = one_shot_f s (float x) name f + let cancel s handle = Threadext.Mutex.execute s.m (fun () -> s.schedule <- HandleMap.remove handle s.schedule) @@ -184,7 +148,7 @@ let rec main_loop s = let sleep_until = Threadext.Mutex.execute s.m (fun () -> try HandleMap.min_binding s.schedule |> fst |> fst - with Not_found -> mtime_add 3600 (now ())) + with Not_found -> mtime_add 3600. (now ())) in let this = now () in let seconds = @@ -195,17 +159,59 @@ let rec main_loop s = else 0. in - let (_ : bool) = Delay.wait s.delay seconds in + let (_ : bool) = PipeDelay.wait s.delay seconds in main_loop s -let make () = +let make_scheduler () = let s = { schedule= HandleMap.empty - ; delay= Delay.make () + ; delay= PipeDelay.make () ; next_id= 0 ; m= Mutex.create () } in let (_ : Thread.t) = Thread.create main_loop s in s + +let make = make_scheduler + +module Delay = struct + type state = Signalled | Timedout + + let s = make_scheduler () + + type t = {c: Condition.t; m: Mutex.t; mutable state: state option} + + let make () = {c= Condition.create (); m= Mutex.create (); state= None} + + let wait t seconds = + Threadext.Mutex.execute t.m (fun () -> + let handle = + one_shot_f s seconds "Delay.wait" (fun () -> + if t.state = None then + t.state <- Some Timedout ; + Condition.broadcast t.c) + in + let rec loop () = + match t.state with + | Some Timedout -> + (* return true if we waited the full length of time *) + true + | Some Signalled -> + (* return false if we were woken, or pre-signalled *) + false + | None -> + (* initial wait or spurious wakeup *) + Condition.wait t.c t.m ; loop () + in + let result = loop () in + cancel s handle ; + t.state <- None ; + result) + + let signal t = + Threadext.Mutex.execute t.m (fun () -> + t.state <- Some Signalled ; + Condition.broadcast t.c) +end From afd48dc49892e8c231245fa6c97b9dfc3539df12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 19 May 2020 10:25:10 +0100 Subject: [PATCH 19/42] CA-337546: add mtime to opam file MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- xapi-idl.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/xapi-idl.opam b/xapi-idl.opam index 5efca903..b5106015 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -19,6 +19,7 @@ depends: [ "logs" "message-switch-core" "message-switch-unix" + "mtime" "ocaml-migrate-parsetree" "ppx_deriving_rpc" "ppx_sexp_conv" From cfdbb38f9f212a958ae11c2fe712950dcc9726d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 4 Jun 2020 10:56:44 +0100 Subject: [PATCH 20/42] Revert "Revert "add Sriov.enable_action_result Manual_successful, for manual sr-iov/vf configuration support"" This reverts commit 434da2e02faf2e3578d146778bd050b967f2dac6. --- network/network_interface.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/network/network_interface.ml b/network/network_interface.ml index 956496e5..3d42cacc 100644 --- a/network/network_interface.ml +++ b/network/network_interface.ml @@ -722,6 +722,7 @@ module Interface_API (R : RPC) = struct | Modprobe_successful_requires_reboot | Modprobe_successful | Sysfs_successful + | Manual_successful [@@deriving rpcty] type enable_result = Ok of enable_action_result | Error of string From c3ecb492d71600c663d53c8d55473f9bbf62dd0a Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 22 May 2020 08:54:35 +0100 Subject: [PATCH 21/42] CP-33121: Do not use stdext's monadic Signed-off-by: Pau Ruiz Safont --- lib/dune | 1 - lib/task_server.ml | 3 +-- lib/updates.ml | 7 +++---- lib/xcp_service.ml | 5 ++--- xapi-idl.opam | 1 - 5 files changed, 6 insertions(+), 11 deletions(-) diff --git a/lib/dune b/lib/dune index 4616ec38..c846f047 100644 --- a/lib/dune +++ b/lib/dune @@ -26,7 +26,6 @@ unix uri xapi-backtrace - xapi-stdext-monadic xapi-stdext-pervasives xapi-stdext-threads xapi-inventory diff --git a/lib/task_server.ml b/lib/task_server.ml index 531204ce..d3f0145e 100644 --- a/lib/task_server.ml +++ b/lib/task_server.ml @@ -14,7 +14,6 @@ (** @group Xenops *) -open Xapi_stdext_monadic open Xapi_stdext_pervasives.Pervasiveext open Xapi_stdext_threads.Threadext @@ -252,7 +251,7 @@ functor let check_cancelling_locked task = task.cancel_points_seen <- task.cancel_points_seen + 1 ; if task.cancelling then raise_cancelled task ; - Opt.iter + Option.iter (fun x -> if task.cancel_points_seen = x then ( info diff --git a/lib/updates.ml b/lib/updates.ml index 385d099b..1c011c64 100644 --- a/lib/updates.ml +++ b/lib/updates.ml @@ -1,7 +1,6 @@ (******************************************************************************) (* Object update tracking *) -open Xapi_stdext_monadic open Xapi_stdext_pervasives.Pervasiveext module type INTERFACE = sig @@ -146,7 +145,7 @@ functor (int * Interface.Dynamic.id list) list * Interface.Dynamic.id list * id let get dbg ?(with_cancel = fun _ f -> f ()) from timeout t = - let from = Opt.default U.initial from in + let from = Option.value ~default:U.initial from in let cancel = ref false in let cancel_fn () = Mutex.execute t.m (fun () -> @@ -154,7 +153,7 @@ functor Condition.broadcast t.c) in let id = - Opt.map + Option.map (fun timeout -> Scheduler.one_shot t.s (Scheduler.Delta timeout) dbg cancel_fn) timeout @@ -172,7 +171,7 @@ functor result in wait ())) - (fun () -> Opt.iter (Scheduler.cancel t.s) id)) + (fun () -> Option.iter (Scheduler.cancel t.s) id)) let last_id _dbg t = Mutex.execute t.m (fun () -> U.last_id t.u) diff --git a/lib/xcp_service.ml b/lib/xcp_service.ml index 2d1d1bb2..4a4cf9e7 100644 --- a/lib/xcp_service.ml +++ b/lib/xcp_service.ml @@ -11,7 +11,6 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -open Xapi_stdext_monadic module StringSet = Set.Make (String) (* Server configuration. We have built-in (hopefully) sensible defaults, @@ -628,7 +627,7 @@ let daemonize ?start_fn () = Sys.set_signal Sys.sighup Sys.Signal_ignore ; match Unix.fork () with | 0 -> - Opt.iter (fun fn -> fn ()) start_fn ; + Option.iter (fun fn -> fn ()) start_fn ; Unix.chdir "/" ; mkdir_rec (Filename.dirname !pidfile) 0o755 ; pidfile_write !pidfile ; @@ -647,4 +646,4 @@ let maybe_daemonize ?start_fn () = if !daemon then daemonize ?start_fn () else - Opt.iter (fun fn -> fn ()) start_fn + Option.iter (fun fn -> fn ()) start_fn diff --git a/xapi-idl.opam b/xapi-idl.opam index b5106015..2d9e4a83 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -31,7 +31,6 @@ depends: [ "uri" "xapi-backtrace" "xapi-stdext-date" - "xapi-stdext-monadic" "xapi-stdext-pervasives" "xapi-stdext-threads" "xapi-inventory" From 1d00c36dada37b16cdb455744c5b405fd44f36a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 1 Sep 2020 13:33:35 +0100 Subject: [PATCH 22/42] Fix backtraces in xenopsd-xc MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A failing HOST.stat call logged just the exception, but not the backtrace: ``` Sep 1 10:55:07 localhost xenopsd-xc: [error||72 ||backtrace] dbsync (update_env) R:a771d46f95c9 failed with exception Xenctrlext.Unix_error(57, "105: No buffer space availa ble") Sep 1 10:55:07 localhost xenopsd-xc: [error||72 ||backtrace] Raised Xenctrlext.Unix_error(57, "105: No buffer space available") Sep 1 10:55:07 localhost xenopsd-xc: [error||72 ||backtrace] 1/1 xenopsd-xc Raised at file (Thread 72 has no backtrace table. Was with_backtraces called?, line 0 Sep 1 10:55:07 localhost xenopsd-xc: [error||72 ||backtrace] ``` Although with_backtraces was definitely called by Debug.with_thread_associated: ``` let stat _ dbg = Debug.with_thread_associated dbg (fun () -> debug "HOST.stat" ; let module B = (val get_backend () : S) in B.HOST.stat ()) () ``` This is because `with_backtraces` removes the thread-local backtrace table that it has created on exit and returns an exception together with its backtrace. The backtrace was getting ignored, and re-queried in Debug.log_backtrace_exn. However that only works if Debug.with_* calls are nested. Fix this so we always use the backtrace if available instead of querying it. log_backtrace can also be called externally, so make sure we still attempt to retrieve the backtrace from the exception if the backtrace is empty. After the fix we now get a proper backtrace: ``` Sep 1 13:47:07 localhost xenopsd-xc: [error||44 ||backtrace] dbsync (update_env) R:531918011f4b failed with exception Xenctrlext.Unix_error(57, "105: No buffer space availa ble") Sep 1 13:47:07 localhost xenopsd-xc: [error||44 ||backtrace] Raised Xenctrlext.Unix_error(57, "105: No buffer space available") Sep 1 13:47:07 localhost xenopsd-xc: [error||44 ||backtrace] 1/3 xenopsd-xc Raised at file xenopsd/xc/xenops_server_xen.ml, line 834 Sep 1 13:47:07 localhost xenopsd-xc: [error||44 ||backtrace] 2/3 xenopsd-xc Called from file xenopsd/xc/xenops_server_xen.ml, line 930 Sep 1 13:47:07 localhost xenopsd-xc: [error||44 ||backtrace] 3/3 xenopsd-xc Called from file xapi-idl/lib/debug.ml, line 220 Sep 1 13:47:07 localhost xenopsd-xc: [error||44 ||backtrace] Sep 1 13:47:07 localhost xenopsd-xc: [error||44 ||xenops_interface] Xenctrlext.Unix_error(57, "105: No buffer space available") (File "xapi-idl/xen/xenops_interface.ml", li ne 168, characters 51-58) Sep 1 13:47:07 localhost xapi: [error||0 |dbsync (update_env) R:531918011f4b|xenops_interface] Xenops_interface.Xenopsd_error([S(Internal_error);S(Xenctrlext.Unix_error(57, "105: No buffer space available"))]) (File "xen/xenops_interface.ml", line 160, characters 49-56) ``` Signed-off-by: Edwin Török --- lib/debug.ml | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/lib/debug.ml b/lib/debug.ml index 96442986..0fd390ab 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -191,19 +191,34 @@ let rec split_c c str = :: split_c c (String.sub str (i + 1) (String.length str - i - 1)) with Not_found -> [str] -let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn _bt = - Backtrace.is_important exn ; - let all = split_c '\n' Backtrace.(to_string_hum (remove exn)) in +let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn bt = + (* We already got the backtrace in the `bt` argument when called from with_thread_associated. + Log that, and remove `exn` from the backtraces table. + If with_backtraces was not nested then looking at `bt` is the only way to get + a proper backtrace, otherwise exiting from `with_backtraces` would've removed the backtrace + from the thread-local backtraces table, and we'd always just log a message complaining about + with_backtraces not being called, which is not true because it was. + *) + let bt' = Backtrace.remove exn in + (* bt could be empty, but bt' would contain a non-empty warning, so compare 'bt' here *) + let bt = if bt = Backtrace.empty then bt' else bt in + let all = split_c '\n' Backtrace.(to_string_hum bt) in (* Write to the log line at a time *) output_log "backtrace" level msg (Printf.sprintf "Raised %s" (Printexc.to_string exn)) ; List.iter (output_log "backtrace" level msg) all -let log_backtrace e bt = log_backtrace_exn e bt +let log_backtrace_internal ?level ?msg e _bt = + Backtrace.is_important e; + log_backtrace_exn ?level ?msg e (Backtrace.remove e) + +let log_backtrace e bt = log_backtrace_internal e bt let with_thread_associated task f x = ThreadLocalTable.add tasks task ; - let result = Backtrace.with_backtraces (fun () -> f x) in + let result = Backtrace.with_backtraces (fun () -> + try f x + with e -> Backtrace.is_important e; raise e) in ThreadLocalTable.remove tasks ; match result with | `Ok result -> @@ -214,7 +229,7 @@ let with_thread_associated task f x = output_log "backtrace" Syslog.Err "error" (Printf.sprintf "%s failed with exception %s" task (Printexc.to_string exn)) ; - log_backtrace exn bt ; + log_backtrace_exn exn bt ; raise exn let with_thread_named name f x = @@ -299,5 +314,5 @@ functor let log_and_ignore_exn f = try f () - with e -> log_backtrace_exn ~level:Syslog.Debug ~msg:"debug" e () + with e -> log_backtrace_internal ~level:Syslog.Debug ~msg:"debug" e () end From e719e6eecfa6082207f6a4f65c3c0fa4e634a065 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Aug 2020 11:02:36 +0100 Subject: [PATCH 23/42] CP-34942: compatibility with rpclib 7 There were two breaking changes affecting the tests: - Avoiding marshalling integer as i8 requires the addition of the strict flag. - A new function for json-rpc to have calls without responses got added Signed-off-by: Pau Ruiz Safont --- lib_test/idl_test_common.ml | 36 ++++++++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/lib_test/idl_test_common.ml b/lib_test/idl_test_common.ml index a211d878..9709969b 100644 --- a/lib_test/idl_test_common.ml +++ b/lib_test/idl_test_common.ml @@ -33,15 +33,15 @@ module type CONFIG = sig end module type MARSHALLER = sig - val string_of_call : Rpc.call -> string + val string_of_call : ?strict:bool -> Rpc.call -> string val call_of_string : string -> Rpc.call - val string_of_response : Rpc.response -> string + val string_of_response : ?strict:bool -> Rpc.response -> string val response_of_string : string -> Rpc.response - val to_string : Rpc.t -> string + val to_string : ?strict:bool -> Rpc.t -> string val of_string : string -> Rpc.t end @@ -54,11 +54,13 @@ module TJsonrpc : MARSHALLER = struct (* there is a ?strict parameter, and the signature would not match *) let of_string s = of_string s + let to_string ?(strict : _) t = to_string t + let response_of_string r = response_of_string r - let string_of_call call = string_of_call call + let string_of_call ?(strict : _) call = string_of_call call - let string_of_response response = string_of_response response + let string_of_response ?(strict : _) response = string_of_response response end module TXmlrpc : MARSHALLER = struct @@ -69,6 +71,12 @@ module TXmlrpc : MARSHALLER = struct let response_of_string s = response_of_string s let of_string s = of_string s + + let to_string ?(strict : _) t = to_string t + + let string_of_call ?(strict : _) call = string_of_call call + + let string_of_response ?(strict : _) response = string_of_response response end (** The following module implements test cases that write test RPC requests and @@ -105,7 +113,7 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct open M - let declare name _ ty = + let declare_ response_needed name _ ty = let rec inner : type b. ((string * Rpc.t) list * Rpc.t list) list -> b fn -> unit = fun params -> function @@ -170,8 +178,8 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct | _ -> Rpc.Dict named :: List.rev unnamed in - let call = Rpc.call wire_name args in - call) + let rpccall = if response_needed then Rpc.notif else Rpc.call in + rpccall wire_name args) params in List.iteri @@ -229,6 +237,10 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct , `Quick , test_fn ) :: !tests + + let declare name desc_list ty = declare_ false name desc_list ty + + let declare_notification name desc_list ty = declare_ true name desc_list ty end let get_arg call has_named name is_opt = @@ -315,8 +327,8 @@ module TestOldRpcs (C : CONFIG) (M : MARSHALLER) = struct | Returning (_, _) -> false - let declare : string -> string list -> 'a fn -> _ res = - fun name _ ty -> + let declare_ : bool -> string -> string list -> 'a fn -> _ res = + fun _notification name _ ty -> ( (* Sanity check: ensure the description has been set before we declare any RPCs *) match !description with @@ -430,4 +442,8 @@ module TestOldRpcs (C : CONFIG) (M : MARSHALLER) = struct responses in tests := !tests @ request_tests @ response_tests + + let declare name desc_list ty = declare_ false name desc_list ty + + let declare_notification name desc_list ty = declare_ true name desc_list ty end From 5281942624eb5c5975090e9e5a873fa0359b1d10 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 10 Sep 2020 17:56:55 +0100 Subject: [PATCH 24/42] maintenance: adapt to message-switch usage of Result Signed-off-by: Pau Ruiz Safont --- lib/xcp_client.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/xcp_client.ml b/lib/xcp_client.ml index ef12ac99..de040270 100644 --- a/lib/xcp_client.ml +++ b/lib/xcp_client.ml @@ -24,9 +24,9 @@ let switch_path = ref "/var/run/message-switch/sock" let use_switch = ref true let get_ok = function - | `Ok x -> + | Ok x -> x - | `Error e -> + | Error e -> let b = Buffer.create 16 in let fmt = Format.formatter_of_buffer b in Message_switch_unix.Protocol_unix.Client.pp_error fmt e ; From ea3e58adb565013cdb7d6162f8486f6e9f62a3ec Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 5 Oct 2020 16:01:05 +0100 Subject: [PATCH 25/42] CP-34942: compatibility with rpclib 8 Signed-off-by: Pau Ruiz Safont --- lib_test/idl_test_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib_test/idl_test_common.ml b/lib_test/idl_test_common.ml index 9709969b..885d878c 100644 --- a/lib_test/idl_test_common.ml +++ b/lib_test/idl_test_common.ml @@ -178,7 +178,7 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct | _ -> Rpc.Dict named :: List.rev unnamed in - let rpccall = if response_needed then Rpc.notif else Rpc.call in + let rpccall = if response_needed then Rpc.notification else Rpc.call in rpccall wire_name args) params in From 9e2353908482573b96551b981fbd313f0733cad6 Mon Sep 17 00:00:00 2001 From: lippirk Date: Tue, 20 Oct 2020 15:23:23 +0100 Subject: [PATCH 26/42] CP-35026 optionally include client info in logs Signed-off-by: lippirk --- lib/debug.ml | 28 ++++++++++++++++++---------- lib/debug.mli | 2 +- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/lib/debug.ml b/lib/debug.ml index 0fd390ab..d6b7401f 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -47,9 +47,15 @@ module ThreadLocalTable = struct IntMap.find_opt id t.tbl end -let names = ThreadLocalTable.make () -let tasks = ThreadLocalTable.make () +type task = { + desc: string + ; client: string option +} + +let tasks: task ThreadLocalTable.t = ThreadLocalTable.make () + +let names: string ThreadLocalTable.t = ThreadLocalTable.make () let gettimestring () = let time = Unix.gettimeofday () in @@ -67,11 +73,13 @@ let escape = Astring.String.Ascii.escape let format include_time brand priority message = let id = get_thread_id () in - let name = - match ThreadLocalTable.find names with Some x -> x | None -> "" - in - let task = - match ThreadLocalTable.find tasks with Some x -> x | None -> "" + let task, name = + (* if the task's client is known, attach it to the task's name *) + let name = match ThreadLocalTable.find names with Some x -> x | None -> "" in + match ThreadLocalTable.find tasks with + | None -> "", name + | Some {desc; client=None} -> desc, name + | Some {desc; client=Some client} -> desc, Printf.sprintf "%s->%s" client name in Printf.sprintf "[%s%5s||%d %s|%s|%s] %s" (if include_time then gettimestring () else "") @@ -214,8 +222,8 @@ let log_backtrace_internal ?level ?msg e _bt = let log_backtrace e bt = log_backtrace_internal e bt -let with_thread_associated task f x = - ThreadLocalTable.add tasks task ; +let with_thread_associated ?client desc f x = + ThreadLocalTable.add tasks {desc; client} ; let result = Backtrace.with_backtraces (fun () -> try f x with e -> Backtrace.is_important e; raise e) in @@ -227,7 +235,7 @@ let with_thread_associated task f x = (* This function is a top-level exception handler typically used on fresh threads. This is the last chance to do something with the backtrace *) output_log "backtrace" Syslog.Err "error" - (Printf.sprintf "%s failed with exception %s" task + (Printf.sprintf "%s failed with exception %s" desc (Printexc.to_string exn)) ; log_backtrace_exn exn bt ; raise exn diff --git a/lib/debug.mli b/lib/debug.mli index ca224e72..78b17cd5 100644 --- a/lib/debug.mli +++ b/lib/debug.mli @@ -20,7 +20,7 @@ val init_logs : unit -> unit (** {2 Associate a task to the current actions} *) -val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b +val with_thread_associated : ?client:string -> string -> ('a -> 'b) -> 'a -> 'b (** Do an action with a task name associated with the current thread *) (** {2 Associate a name to the current thread} *) From 83de389b98214d283ca73d23255601232fc8ef1c Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 9 Nov 2020 22:16:28 +0000 Subject: [PATCH 27/42] CA-347560: Add VM.import_metadata_async This is a variant of `VM.import_metadata` that always queues the operation and returns a task id immediately (like most VM operations). This is useful, once the original (synchronous) function may block for longer periods while other operations on the VM complete. Signed-off-by: Rob Hoes --- xen/xenops_interface.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/xen/xenops_interface.ml b/xen/xenops_interface.ml index cebe545c..1d7cedc7 100644 --- a/xen/xenops_interface.ml +++ b/xen/xenops_interface.ml @@ -811,6 +811,13 @@ module XenopsAPI (R : RPC) = struct @-> Param.mk ~name:"metadata" Types.string @-> returning vm_id_p err ) + + let import_metadata_async = + declare "VM.import_metadata_async" [] + (debug_info_p + @-> Param.mk ~name:"metadata" Types.string + @-> returning task_id_p err + ) end module PCI = struct From 9746f35a21086bc84f84fae7c84625d00faea6cc Mon Sep 17 00:00:00 2001 From: BenjiReis Date: Mon, 11 Jan 2021 14:25:58 +0100 Subject: [PATCH 28/42] replace Unix.gethostbyname by Unix.getaddrinfo to support ipv6 Signed-off-by: BenjiReis --- lib/open_uri.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/open_uri.ml b/lib/open_uri.ml index b63df639..5383a61b 100644 --- a/lib/open_uri.ml +++ b/lib/open_uri.ml @@ -20,8 +20,11 @@ open Xapi_stdext_pervasives.Pervasiveext let handle_socket f s = try f s with e -> Backtrace.is_important e ; raise e let open_tcp f host port = - let host_entry = Unix.gethostbyname host in - let sockaddr = Unix.ADDR_INET (host_entry.Unix.h_addr_list.(0), port) in + let host = Scanf.ksscanf host (fun _ _ -> host) "[%s@]" Fun.id in + let he = Unix.getaddrinfo host (string_of_int port) [] in + if he = [] then begin raise Not_found end; + + let sockaddr = (List.hd he).Unix.ai_addr in let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in finally (fun () -> Unix.connect s sockaddr ; handle_socket f s) From df53887698298c73c131c04936d6e29e207b425f Mon Sep 17 00:00:00 2001 From: BenjiReis Date: Mon, 11 Jan 2021 15:19:46 +0100 Subject: [PATCH 29/42] Update lib/open_uri.ml Co-authored-by: Pau Ruiz Safont Signed-off-by: BenjiReis --- lib/open_uri.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/lib/open_uri.ml b/lib/open_uri.ml index 5383a61b..a7f710ba 100644 --- a/lib/open_uri.ml +++ b/lib/open_uri.ml @@ -20,12 +20,22 @@ open Xapi_stdext_pervasives.Pervasiveext let handle_socket f s = try f s with e -> Backtrace.is_important e ; raise e let open_tcp f host port = + Printf.fprintf stderr "*** BRS: open_tcp host: %s\n" host ; let host = Scanf.ksscanf host (fun _ _ -> host) "[%s@]" Fun.id in + Printf.fprintf stderr "*** BRS: open_tcp unwrapped host: %s\n" host ; let he = Unix.getaddrinfo host (string_of_int port) [] in - if he = [] then begin raise Not_found end; + Printf.fprintf stderr "*** BRS: getAddrInfo \n" ; + if he = [] then raise Not_found ; + Printf.fprintf stderr "*** BRS: not empty\n" ; let sockaddr = (List.hd he).Unix.ai_addr in - let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + let family = + match sockaddr with + | Unix.ADDR_INET(addr, port) -> + Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, port)) + | Unix.ADDR_UNIX _ -> Unix.PF_UNIX + in + let s = Unix.socket family Unix.SOCK_STREAM 0 in finally (fun () -> Unix.connect s sockaddr ; handle_socket f s) (fun () -> Unix.close s) From 09c2366d23cca45c7b49c3a07184904a99b5fd08 Mon Sep 17 00:00:00 2001 From: BenjiReis Date: Tue, 12 Jan 2021 09:21:54 +0100 Subject: [PATCH 30/42] use match on getaddrinfo Signed-off-by: BenjiReis --- lib/open_uri.ml | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/lib/open_uri.ml b/lib/open_uri.ml index a7f710ba..a665a01d 100644 --- a/lib/open_uri.ml +++ b/lib/open_uri.ml @@ -17,18 +17,24 @@ open Xapi_stdext_pervasives.Pervasiveext +module D = Debug.Make (struct let name = "open_uri" end) +open D + let handle_socket f s = try f s with e -> Backtrace.is_important e ; raise e let open_tcp f host port = - Printf.fprintf stderr "*** BRS: open_tcp host: %s\n" host ; + debug "*** BRS: open_tcp host: %s\n" host ; let host = Scanf.ksscanf host (fun _ _ -> host) "[%s@]" Fun.id in - Printf.fprintf stderr "*** BRS: open_tcp unwrapped host: %s\n" host ; - let he = Unix.getaddrinfo host (string_of_int port) [] in - Printf.fprintf stderr "*** BRS: getAddrInfo \n" ; - if he = [] then raise Not_found ; + debug "*** BRS: open_tcp unwrapped host: %s\n" host ; + let sockaddr = + match Unix.getaddrinfo host (string_of_int port) [] with + | [] -> + error "No addrinfo found for host: %s on port: %d" host port ; + raise Not_found + | addrinfo::_ -> addrinfo.Unix.ai_addr + in + debug "*** BRS: getAddrInfo success \n" ; - Printf.fprintf stderr "*** BRS: not empty\n" ; - let sockaddr = (List.hd he).Unix.ai_addr in let family = match sockaddr with | Unix.ADDR_INET(addr, port) -> @@ -41,6 +47,7 @@ let open_tcp f host port = (fun () -> Unix.close s) let with_open_uri uri f = + debug "*** BRS: with_open_uri uri: %s\n" (Uri.to_string uri) ; match Uri.scheme uri with | Some "http" -> ( match (Uri.host uri, Uri.port uri) with From e0cfee10ea796f908d8095beca5e1baa8ca2656e Mon Sep 17 00:00:00 2001 From: BenjiReis Date: Tue, 12 Jan 2021 11:12:59 +0100 Subject: [PATCH 31/42] finish handling IPv6 Signed-off-by: BenjiReis --- lib/open_uri.ml | 12 +----------- lib/posix_channel.ml | 7 +++++-- misc/channel_helper.ml | 9 +++++++-- 3 files changed, 13 insertions(+), 15 deletions(-) diff --git a/lib/open_uri.ml b/lib/open_uri.ml index a665a01d..ca96ae10 100644 --- a/lib/open_uri.ml +++ b/lib/open_uri.ml @@ -23,9 +23,7 @@ open D let handle_socket f s = try f s with e -> Backtrace.is_important e ; raise e let open_tcp f host port = - debug "*** BRS: open_tcp host: %s\n" host ; let host = Scanf.ksscanf host (fun _ _ -> host) "[%s@]" Fun.id in - debug "*** BRS: open_tcp unwrapped host: %s\n" host ; let sockaddr = match Unix.getaddrinfo host (string_of_int port) [] with | [] -> @@ -33,21 +31,13 @@ let open_tcp f host port = raise Not_found | addrinfo::_ -> addrinfo.Unix.ai_addr in - debug "*** BRS: getAddrInfo success \n" ; - - let family = - match sockaddr with - | Unix.ADDR_INET(addr, port) -> - Unix.domain_of_sockaddr (Unix.ADDR_INET (addr, port)) - | Unix.ADDR_UNIX _ -> Unix.PF_UNIX - in + let family = Unix.domain_of_sockaddr sockaddr in let s = Unix.socket family Unix.SOCK_STREAM 0 in finally (fun () -> Unix.connect s sockaddr ; handle_socket f s) (fun () -> Unix.close s) let with_open_uri uri f = - debug "*** BRS: with_open_uri uri: %s\n" (Uri.to_string uri) ; match Uri.scheme uri with | Some "http" -> ( match (Uri.host uri, Uri.port uri) with diff --git a/lib/posix_channel.ml b/lib/posix_channel.ml index da9dda04..af919a96 100644 --- a/lib/posix_channel.ml +++ b/lib/posix_channel.ml @@ -207,9 +207,12 @@ let receive protocols = | V4V_proxy (_, _) -> assert false (* weight is 0 above *) | TCP_proxy (ip, port) -> ( - let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + let unwrapped_ip = Scanf.ksscanf ip (fun _ _ -> ip) "[%s@]" Fun.id in + let addr = Unix.ADDR_INET (Unix.inet_addr_of_string unwrapped_ip, port) in + let family = Unix.domain_of_sockaddr addr in + let s = Unix.socket family Unix.SOCK_STREAM 0 in try - Unix.connect s (Unix.ADDR_INET (Unix.inet_addr_of_string ip, port)) ; + Unix.connect s addr ; s with e -> Unix.close s ; raise e ) diff --git a/misc/channel_helper.ml b/misc/channel_helper.ml index bf600d52..be1aea5a 100644 --- a/misc/channel_helper.ml +++ b/misc/channel_helper.ml @@ -86,9 +86,14 @@ let help = (* Commands *) let advertise_t _common_options_t proxy_socket = - let s_ip = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in + let unwrapped_ip = Scanf.ksscanf !ip (fun _ _ -> !ip) "[%s@]" Fun.id in + let addr = + Lwt_unix.ADDR_INET (Lwt_unix.inet_addr_of_string unwrapped_ip, port) + in + let family = Lwt_unix.domain_of_sockaddr addr in + let s_ip = Lwt_unix.socket family Lwt_unix.SOCK_STREAM 0 in (* INET socket, can't block *) - Lwt_unix.bind s_ip (Lwt_unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) + Lwt_unix.bind s_ip addr >>= fun () -> Lwt_unix.listen s_ip 5 ; let port = From e6d6ecd559f28063061d10228280f5bd0953dc7d Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Thu, 4 Feb 2021 14:17:39 +0000 Subject: [PATCH 32/42] Maintenance: put ciphers one per line Signed-off-by: Christian Lindig --- lib/xcp_const.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/xcp_const.ml b/lib/xcp_const.ml index dcd7b295..7eb820a2 100644 --- a/lib/xcp_const.ml +++ b/lib/xcp_const.ml @@ -1,2 +1,8 @@ let good_ciphersuites = - "ECDHE-RSA-AES256-SHA384:ECDHE-RSA-AES256-GCM-SHA384:AES256-SHA256:AES128-SHA256" + String.concat ":" + [ + "ECDHE-RSA-AES256-SHA384" + ; "ECDHE-RSA-AES256-GCM-SHA384" + ; "AES256-SHA256" + ; "AES128-SHA256" + ] From a36800549dcf2bbfbd920eecc67a24ecaebd71a3 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Thu, 4 Feb 2021 14:17:54 +0000 Subject: [PATCH 33/42] Maintenance: reformat Remove version constraint on .ocamlformat Signed-off-by: Christian Lindig --- .ocamlformat | 1 - lib/debug.ml | 34 ++++++++++++++++++---------------- lib_test/idl_test_common.ml | 4 +++- 3 files changed, 21 insertions(+), 18 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index b4d356a7..ea8e56a8 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,5 +1,4 @@ profile=ocamlformat -version=0.14.1 indicate-multiline-delimiters=closing-on-separate-line if-then-else=fit-or-vertical dock-collection-brackets=true diff --git a/lib/debug.ml b/lib/debug.ml index d6b7401f..895d48a1 100644 --- a/lib/debug.ml +++ b/lib/debug.ml @@ -47,15 +47,11 @@ module ThreadLocalTable = struct IntMap.find_opt id t.tbl end +type task = {desc: string; client: string option} -type task = { - desc: string - ; client: string option -} +let tasks : task ThreadLocalTable.t = ThreadLocalTable.make () -let tasks: task ThreadLocalTable.t = ThreadLocalTable.make () - -let names: string ThreadLocalTable.t = ThreadLocalTable.make () +let names : string ThreadLocalTable.t = ThreadLocalTable.make () let gettimestring () = let time = Unix.gettimeofday () in @@ -75,11 +71,16 @@ let format include_time brand priority message = let id = get_thread_id () in let task, name = (* if the task's client is known, attach it to the task's name *) - let name = match ThreadLocalTable.find names with Some x -> x | None -> "" in + let name = + match ThreadLocalTable.find names with Some x -> x | None -> "" + in match ThreadLocalTable.find tasks with - | None -> "", name - | Some {desc; client=None} -> desc, name - | Some {desc; client=Some client} -> desc, Printf.sprintf "%s->%s" client name + | None -> + ("", name) + | Some {desc; client= None} -> + (desc, name) + | Some {desc; client= Some client} -> + (desc, Printf.sprintf "%s->%s" client name) in Printf.sprintf "[%s%5s||%d %s|%s|%s] %s" (if include_time then gettimestring () else "") @@ -217,16 +218,17 @@ let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn bt = List.iter (output_log "backtrace" level msg) all let log_backtrace_internal ?level ?msg e _bt = - Backtrace.is_important e; - log_backtrace_exn ?level ?msg e (Backtrace.remove e) + Backtrace.is_important e ; + log_backtrace_exn ?level ?msg e (Backtrace.remove e) let log_backtrace e bt = log_backtrace_internal e bt let with_thread_associated ?client desc f x = ThreadLocalTable.add tasks {desc; client} ; - let result = Backtrace.with_backtraces (fun () -> - try f x - with e -> Backtrace.is_important e; raise e) in + let result = + Backtrace.with_backtraces (fun () -> + try f x with e -> Backtrace.is_important e ; raise e) + in ThreadLocalTable.remove tasks ; match result with | `Ok result -> diff --git a/lib_test/idl_test_common.ml b/lib_test/idl_test_common.ml index 885d878c..df8c2d36 100644 --- a/lib_test/idl_test_common.ml +++ b/lib_test/idl_test_common.ml @@ -178,7 +178,9 @@ module GenTestData (C : CONFIG) (M : MARSHALLER) = struct | _ -> Rpc.Dict named :: List.rev unnamed in - let rpccall = if response_needed then Rpc.notification else Rpc.call in + let rpccall = + if response_needed then Rpc.notification else Rpc.call + in rpccall wire_name args) params in From fc34696f5dcd0895fa05d5f6b1812736ebb670c9 Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Thu, 29 Apr 2021 09:49:17 +0100 Subject: [PATCH 34/42] ci: replace travis with github-ci Signed-off-by: Ben Anson --- .github/workflows/ocaml-ci.yml | 40 ++++++++++++++++++++++++++++++++++ .travis.yml | 12 ---------- README.md | 1 - 3 files changed, 40 insertions(+), 13 deletions(-) create mode 100644 .github/workflows/ocaml-ci.yml delete mode 100644 .travis.yml diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml new file mode 100644 index 00000000..718f5f51 --- /dev/null +++ b/.github/workflows/ocaml-ci.yml @@ -0,0 +1,40 @@ +name: Build and test + +on: + push: + pull_request: + +jobs: + ocaml-test: + name: Ocaml tests + runs-on: ubuntu-20.04 + env: + package: "xapi-idl xcp" + + steps: + - name: Checkout code + uses: actions/checkout@v2 + + - name: Pull configuration from xs-opam + run: | + curl --fail --silent https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env | cut -f2 -d " " > .env + - name: Load environment file + id: dotenv + uses: falti/dotenv-action@v0.2.4 + + - name: Use ocaml + uses: avsm/setup-ocaml@v1 + with: + ocaml-version: ${{ steps.dotenv.outputs.ocaml_version_full }} + opam-repository: ${{ steps.dotenv.outputs.repository }} + + - name: Install dependencies + run: | + opam pin add . --no-action + opam depext -u ${{ env.package }} + opam install ${{ env.package }} --deps-only --with-test -v + - name: Build + run: | + opam exec -- make build + - name: Run tests + run: opam exec -- make test diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 11fbae1d..00000000 --- a/.travis.yml +++ /dev/null @@ -1,12 +0,0 @@ -language: c -sudo: required -service: docker -install: - - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh - - wget https://raw.githubusercontent.com/xapi-project/xs-opam/master/tools/xs-opam-ci.env - - source xs-opam-ci.env -script: bash -ex .travis-docker.sh -env: - global: - - PACKAGE=xapi-idl - - PINS="xapi-idl:." diff --git a/README.md b/README.md index c320914a..c33cf6e0 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,5 @@ # xapi-idl -[![Build Status](https://travis-ci.org/xapi-project/xcp-idl.svg?branch=master)](https://travis-ci.org/xapi-project/xcp-idl) [![Coverage Status](https://coveralls.io/repos/github/xapi-project/xcp-idl/badge.svg)](https://coveralls.io/github/xapi-project/xcp-idl) This repository contains From 8ae6fe4cf50389465e9f18451a8988a5377a9479 Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Thu, 29 Apr 2021 09:51:15 +0100 Subject: [PATCH 35/42] ci: compile everything Previously the ci was missing some compilation errors Signed-off-by: Ben Anson --- .github/workflows/ocaml-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml index 718f5f51..423d1155 100644 --- a/.github/workflows/ocaml-ci.yml +++ b/.github/workflows/ocaml-ci.yml @@ -35,6 +35,6 @@ jobs: opam install ${{ env.package }} --deps-only --with-test -v - name: Build run: | - opam exec -- make build + opam exec -- make all - name: Run tests run: opam exec -- make test From 2d06fcb59219c2624c9524106e5ab644cbe6b297 Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Thu, 29 Apr 2021 09:42:25 +0100 Subject: [PATCH 36/42] Revert "Merge pull request #321 from xcp-ng/replace-gethostbyname" This reverts commit 8e859175d5b1e63f41895f1e39a39646043fe882, reversing changes made to a36800549dcf2bbfbd920eecc67a24ecaebd71a3. Signed-off-by: Ben Anson --- lib/open_uri.ml | 16 +++------------- lib/posix_channel.ml | 7 ++----- misc/channel_helper.ml | 9 ++------- 3 files changed, 7 insertions(+), 25 deletions(-) diff --git a/lib/open_uri.ml b/lib/open_uri.ml index ca96ae10..b63df639 100644 --- a/lib/open_uri.ml +++ b/lib/open_uri.ml @@ -17,22 +17,12 @@ open Xapi_stdext_pervasives.Pervasiveext -module D = Debug.Make (struct let name = "open_uri" end) -open D - let handle_socket f s = try f s with e -> Backtrace.is_important e ; raise e let open_tcp f host port = - let host = Scanf.ksscanf host (fun _ _ -> host) "[%s@]" Fun.id in - let sockaddr = - match Unix.getaddrinfo host (string_of_int port) [] with - | [] -> - error "No addrinfo found for host: %s on port: %d" host port ; - raise Not_found - | addrinfo::_ -> addrinfo.Unix.ai_addr - in - let family = Unix.domain_of_sockaddr sockaddr in - let s = Unix.socket family Unix.SOCK_STREAM 0 in + let host_entry = Unix.gethostbyname host in + let sockaddr = Unix.ADDR_INET (host_entry.Unix.h_addr_list.(0), port) in + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in finally (fun () -> Unix.connect s sockaddr ; handle_socket f s) (fun () -> Unix.close s) diff --git a/lib/posix_channel.ml b/lib/posix_channel.ml index af919a96..da9dda04 100644 --- a/lib/posix_channel.ml +++ b/lib/posix_channel.ml @@ -207,12 +207,9 @@ let receive protocols = | V4V_proxy (_, _) -> assert false (* weight is 0 above *) | TCP_proxy (ip, port) -> ( - let unwrapped_ip = Scanf.ksscanf ip (fun _ _ -> ip) "[%s@]" Fun.id in - let addr = Unix.ADDR_INET (Unix.inet_addr_of_string unwrapped_ip, port) in - let family = Unix.domain_of_sockaddr addr in - let s = Unix.socket family Unix.SOCK_STREAM 0 in + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in try - Unix.connect s addr ; + Unix.connect s (Unix.ADDR_INET (Unix.inet_addr_of_string ip, port)) ; s with e -> Unix.close s ; raise e ) diff --git a/misc/channel_helper.ml b/misc/channel_helper.ml index be1aea5a..bf600d52 100644 --- a/misc/channel_helper.ml +++ b/misc/channel_helper.ml @@ -86,14 +86,9 @@ let help = (* Commands *) let advertise_t _common_options_t proxy_socket = - let unwrapped_ip = Scanf.ksscanf !ip (fun _ _ -> !ip) "[%s@]" Fun.id in - let addr = - Lwt_unix.ADDR_INET (Lwt_unix.inet_addr_of_string unwrapped_ip, port) - in - let family = Lwt_unix.domain_of_sockaddr addr in - let s_ip = Lwt_unix.socket family Lwt_unix.SOCK_STREAM 0 in + let s_ip = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in (* INET socket, can't block *) - Lwt_unix.bind s_ip addr + Lwt_unix.bind s_ip (Lwt_unix.ADDR_INET (Unix.inet_addr_of_string !ip, 0)) >>= fun () -> Lwt_unix.listen s_ip 5 ; let port = From 00922604b2917d4bec6d33a1732b47eac73dd016 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 14 May 2021 15:56:05 +0100 Subject: [PATCH 37/42] misc: add to xapi-idl package, drop xcp add lwt to the dependencies since channel-helpers uses it Signed-off-by: Pau Ruiz Safont --- .github/workflows/ocaml-ci.yml | 2 +- misc/dune | 2 ++ xapi-idl.opam | 1 + xcp.opam | 12 ------------ 4 files changed, 4 insertions(+), 13 deletions(-) delete mode 100644 xcp.opam diff --git a/.github/workflows/ocaml-ci.yml b/.github/workflows/ocaml-ci.yml index 423d1155..b08cc575 100644 --- a/.github/workflows/ocaml-ci.yml +++ b/.github/workflows/ocaml-ci.yml @@ -9,7 +9,7 @@ jobs: name: Ocaml tests runs-on: ubuntu-20.04 env: - package: "xapi-idl xcp" + package: "xapi-idl" steps: - name: Checkout code diff --git a/misc/dune b/misc/dune index 40eb98e7..2bdcd854 100644 --- a/misc/dune +++ b/misc/dune @@ -1,6 +1,8 @@ (executable (name channel_helper) + (public_name xcp-idl-debugger) (modules channel_helper) + (package xapi-idl) (libraries cmdliner lwt diff --git a/xapi-idl.opam b/xapi-idl.opam index 2d9e4a83..816fde84 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -17,6 +17,7 @@ depends: [ "cohttp" "fd-send-recv" "logs" + "lwt" "message-switch-core" "message-switch-unix" "mtime" diff --git a/xcp.opam b/xcp.opam deleted file mode 100644 index beef5866..00000000 --- a/xcp.opam +++ /dev/null @@ -1,12 +0,0 @@ -opam-version: "2.0" -name: "xcp" -authors: "Dave Scott" -homepage: "https://github.com/xapi-project/xcp-idl" -bug-reports: "https://github.com/xapi-project/xcp-idl/issues" -dev-repo: "git://github.com/xapi-project/xcp-idl" -maintainer: "xen-api@lists.xen.org" -tags: [ "org:xapi-project" ] -depends: ["ocaml" "xapi-idl"] -synopsis: "Interface descriptions and common boilerplate for xapi services" -description: """ -This package has been renamed to 'xapi-idl' and can safely be removed""" From 04a466eed486d5822d299da280d91f8df0d55e9e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 14 May 2021 16:24:44 +0100 Subject: [PATCH 38/42] CP-34942: Use lwt 5 interfaces Signed-off-by: Pau Ruiz Safont --- misc/channel_helper.ml | 6 ++---- xapi-idl.opam | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/misc/channel_helper.ml b/misc/channel_helper.ml index bf600d52..53711b2c 100644 --- a/misc/channel_helper.ml +++ b/misc/channel_helper.ml @@ -129,15 +129,13 @@ let advertise_t _common_options_t proxy_socket = let buffer = Bytes.make (String.length token) '\000' in let io_vector = Lwt_unix.IO_vectors.create () in Lwt_unix.IO_vectors.append_bytes io_vector buffer 0 (Bytes.length buffer) ; - Lwt_unix.Versioned.recv_msg_2 ~socket:fd ~io_vectors:io_vector - >>= fun (n, fds) -> + Lwt_unix.recv_msg ~socket:fd ~io_vectors:io_vector >>= fun (n, fds) -> List.iter Unix.close fds ; let token' = Bytes.sub buffer 0 n in let io_vector' = Lwt_unix.IO_vectors.create () in Lwt_unix.IO_vectors.append_bytes io_vector' token' 0 (Bytes.length token') ; if token = Bytes.to_string token' then - Lwt_unix.Versioned.send_msg_2 ~socket:fd ~io_vectors:io_vector' - ~fds:[proxy_socket] + Lwt_unix.send_msg ~socket:fd ~io_vectors:io_vector' ~fds:[proxy_socket] >>= fun _ -> return () else return () diff --git a/xapi-idl.opam b/xapi-idl.opam index 816fde84..92c0d91c 100644 --- a/xapi-idl.opam +++ b/xapi-idl.opam @@ -17,7 +17,7 @@ depends: [ "cohttp" "fd-send-recv" "logs" - "lwt" + "lwt" {>= "5.0.0"} "message-switch-core" "message-switch-unix" "mtime" From 9b9a1f83a71cfc4d118f94c6ebff9274d241e66f Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 9 Jun 2021 09:08:44 +0000 Subject: [PATCH 39/42] Update ciphers used by stunnel/XAPI For the sake of security, CBC ciphers are required to be removed from TLS interface of XAPI. But only one would remain in available cipher list after the removal. Therefore a new configuration 'ECDHE-RSA-AES128-GCM-SHA25' is added. Note: IANA name of 'ECDHE-RSA-AES128-GCM-SHA25 is 'TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256'. Signed-off-by: Ming Lu --- lib/xcp_const.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/lib/xcp_const.ml b/lib/xcp_const.ml index 7eb820a2..1e6cfdff 100644 --- a/lib/xcp_const.ml +++ b/lib/xcp_const.ml @@ -1,8 +1,6 @@ let good_ciphersuites = String.concat ":" [ - "ECDHE-RSA-AES256-SHA384" - ; "ECDHE-RSA-AES256-GCM-SHA384" - ; "AES256-SHA256" - ; "AES128-SHA256" + "ECDHE-RSA-AES256-GCM-SHA384" + ; "ECDHE-RSA-AES128-GCM-SHA256" ] From a280f1d8433b139355f9fbb165bf54abb699bdf8 Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Thu, 1 Jul 2021 09:13:32 +0100 Subject: [PATCH 40/42] CP-36097 REQ-403 add pems to cluster config Motivation: if we add a 'pems' field to the cluster config, each cluster member will know about a common pem file, and they can use this to perform certificate checking The 'blobs' field is a list, so that a cluster can trust multiple certificates at the same time. This may be helpful in the future if we need to implement certificate rotation inside a cluster. We add a 'pems' parameter to the join API, so that joiners can use the same pem file as the cluster they are trying to join. Signed-off-by: Ben Anson --- cluster/cluster_interface.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/cluster/cluster_interface.ml b/cluster/cluster_interface.ml index e87201ac..5e87cdd3 100644 --- a/cluster/cluster_interface.ml +++ b/cluster/cluster_interface.ml @@ -36,6 +36,10 @@ type node = {addr: address; id: nodeid} [@@deriving rpcty] type all_members = node list [@@deriving rpcty] +type pems = {cn: string; blobs: string list} [@@deriving rpcty] + +type pems_opt = pems option [@@deriving rpcty] + (** This type contains all of the information required to initialise the cluster. All optional params will have the recommended defaults if None. *) type init_config = { @@ -43,6 +47,7 @@ type init_config = { ; token_timeout_ms: int64 option ; token_coefficient_ms: int64 option ; name: string option + ; pems: pems option } [@@deriving rpcty] @@ -57,6 +62,7 @@ type cluster_config = { ; config_version: int64 ; cluster_token_timeout_ms: int64 ; cluster_token_coefficient_ms: int64 + ; pems: pems option } [@@deriving rpcty] @@ -119,6 +125,11 @@ let debug_info_p = ~description:["An uninterpreted string to associate with the operation."] debug_info +let pems_opt_p = + Param.mk ~name:"pems" + ~description:["keys and certs cluster node should use"] + pems_opt + type remove = bool [@@deriving rpcty] module LocalAPI (R : RPC) = struct @@ -198,6 +209,7 @@ module LocalAPI (R : RPC) = struct @-> token_p @-> new_p @-> existing_p + @-> pems_opt_p @-> returning unit_p err ) From 8aa01738a778fabae02483c49e2710f943696b8e Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Fri, 25 Jun 2021 14:34:34 +0100 Subject: [PATCH 41/42] CP-36097 REQ-403 get-config API Motivation for this API is so that xapi can obtain a cluster's certificate. Xapi will then give that certificate to any joiners. This is necessary in order for joining to work when tls client verification is enabled Add `encode_cluster_config` and `decode_cluster_config` for convenience Signed-off-by: Ben Anson --- cluster/cluster_interface.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/cluster/cluster_interface.ml b/cluster/cluster_interface.ml index 5e87cdd3..c7b0f82e 100644 --- a/cluster/cluster_interface.ml +++ b/cluster/cluster_interface.ml @@ -66,6 +66,12 @@ type cluster_config = { } [@@deriving rpcty] +let encode_cluster_config x = + Rpcmarshal.marshal cluster_config.Rpc.Types.ty x |> Jsonrpc.to_string + +let decode_cluster_config x = + Jsonrpc.of_string x |> Rpcmarshal.unmarshal cluster_config.Rpc.Types.ty + type cluster_config_and_all_members = cluster_config * all_members [@@deriving rpcty] @@ -243,4 +249,10 @@ module LocalAPI (R : RPC) = struct declare "diagnostics" ["Returns diagnostic information about the cluster"] (debug_info_p @-> returning diagnostics_p err) + + let get_config = + let cluster_config_p = Param.mk ~name:"cluster_config" cluster_config in + declare "get-config" + ["Returns local cluster config"] + (debug_info_p @-> returning cluster_config_p err) end From c459e31b534a8745b271aa93f5b517b33236206d Mon Sep 17 00:00:00 2001 From: Ben Anson Date: Thu, 1 Jul 2021 17:08:48 +0100 Subject: [PATCH 42/42] CP-36097 REQ-403 write-pems API Motivation for this API is the following upgrade case: We have a stockholm cluster, which is upgraded to the latest version of the toolstack. Before enabling TLS verification, the cluster does not have a pem file to use, so it will use xapi's. However in order to enable TLS verification, it will need its own pem. 'write-pems' will introduce a pem to such a cluster. Signed-off-by: Ben Anson --- cluster/cluster_interface.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cluster/cluster_interface.ml b/cluster/cluster_interface.ml index c7b0f82e..194bc67e 100644 --- a/cluster/cluster_interface.ml +++ b/cluster/cluster_interface.ml @@ -255,4 +255,10 @@ module LocalAPI (R : RPC) = struct declare "get-config" ["Returns local cluster config"] (debug_info_p @-> returning cluster_config_p err) + + let write_pems = + let pems_p = Param.mk ~name:"pems" pems in + declare "write-pems" + ["Distribute pems to existing cluster"] + (debug_info_p @-> pems_p @-> returning unit_p err) end