From 6d8d21944f61f252e8e85f024b452af07b4ac70a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Thu, 25 Jul 2024 15:01:34 +0100 Subject: [PATCH 01/17] CP-50444: New `with_child_trace` function added to `tracing.ml` Adds `with_child_trace` fuction that only creates a span only if there exists a parent. Signed-off-by: Gabriel Buica --- ocaml/libs/tracing/tracing.ml | 13 ++++++++++--- ocaml/libs/tracing/tracing.mli | 9 +++++++++ 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 8b22a8680a1..28a5b2f687b 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -519,8 +519,8 @@ module TracerProvider = struct get_tracer_providers_unlocked let set ?enabled ?attributes ?endpoints ~uuid () = - let update_provider (provider : t) ?(enabled = provider.enabled) attributes - endpoints = + let update_provider (provider : t) enabled attributes endpoints = + let enabled = Option.value ~default:provider.enabled enabled in let attributes : string Attributes.t = Option.fold ~none:provider.attributes ~some:Attributes.of_list attributes @@ -537,7 +537,7 @@ module TracerProvider = struct let provider = match Hashtbl.find_opt tracer_providers uuid with | Some (provider : t) -> - update_provider provider ?enabled attributes endpoints + update_provider provider enabled attributes endpoints | None -> fail "The TracerProvider : %s does not exist" uuid in @@ -673,6 +673,13 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f = ) else f None +let with_child_trace ?attributes parent ~name f = + match parent with + | None -> + f None + | Some _ as parent -> + with_tracing ?attributes ~parent ~name f + module EnvHelpers = struct let traceparent_key = "TRACEPARENT" diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index bfb37ddf292..cd6e4204602 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -199,6 +199,15 @@ val with_tracing : -> (Span.t option -> 'a) -> 'a +val with_child_trace : + ?attributes:(string * string) list + -> Span.t option + -> name:string + -> (Span.t option -> 'a) + -> 'a +(** [with_child_trace ?attributes ?parent ~name f] is like {!val:with_tracing}, but + only creates a span if the [parent] span exists. *) + val get_observe : unit -> bool val validate_attribute : string * string -> bool From c37859ddf8684b2406249fad00257626e3cc7a0e Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Tue, 23 Jul 2024 12:49:41 +0100 Subject: [PATCH 02/17] CP-50444: Intrument `http_svr` Intruments the following path of an http request: - `handle_one`, - `callback`, - `callback1`, - `dispatch`, - `jsoncallback`, - `response`. Signed-off-by: Gabriel Buica --- dune-project | 1 + ocaml/libs/http-lib/dune | 1 + ocaml/libs/http-lib/http_svr.ml | 22 ++++++++++++++++++++++ ocaml/libs/http-lib/http_svr.mli | 2 ++ ocaml/xapi/api_server.ml | 24 ++++++++++++++++++++++-- ocaml/xapi/dune | 2 ++ xapi-rrdd.opam | 1 + 7 files changed, 51 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index 0efbe491956..88080ce624c 100644 --- a/dune-project +++ b/dune-project @@ -205,6 +205,7 @@ (xapi-rrd (= :version)) (xapi-stdext-threads (= :version)) (xapi-stdext-unix (= :version)) + xapi-tracing ) ) diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index f6de65dbe48..ead0f1d19f6 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -45,6 +45,7 @@ ipaddr polly threads.posix + tracing uri xapi-log xapi-stdext-pervasives diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 7c270874a96..51b2beacba8 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -43,6 +43,8 @@ module E = Debug.Make (struct let name = "http_internal_errors" end) let ( let* ) = Option.bind +let ( let@ ) f x = f x + type uri_path = string module Stats = struct @@ -99,8 +101,18 @@ let response_of_request req hdrs = ~headers:(connection :: cache :: hdrs) "200" "OK" +let traceparent_of_request req = + let open Tracing in + let ( let* ) = Option.bind in + let* traceparent = req.Http.Request.traceparent in + let* span_context = SpanContext.of_traceparent traceparent in + let span = Tracer.span_of_span_context span_context req.uri in + Some span + let response_fct req ?(hdrs = []) s (response_length : int64) (write_response_to_fd_fn : Unix.file_descr -> unit) = + let parent = traceparent_of_request req in + let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in let res = { (response_of_request req hdrs) with @@ -486,6 +498,8 @@ let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = (None, None) let handle_one (x : 'a Server.t) ss context req = + let parent = traceparent_of_request req in + let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in let ic = Buf_io.of_fd ss in let finished = ref false in try @@ -499,6 +513,14 @@ let handle_one (x : 'a Server.t) ss context req = Option.value ~default:empty (Radix_tree.longest_prefix req.Request.uri method_map) in + let@ _ = Tracing.with_child_trace span ~name:"handler" in + let traceparent = + let open Tracing in + Option.map + (fun span -> Span.get_context span |> SpanContext.to_traceparent) + span + in + let req = {req with traceparent} in ( match te.TE.handler with | BufIO handlerfn -> handlerfn req ic context diff --git a/ocaml/libs/http-lib/http_svr.mli b/ocaml/libs/http-lib/http_svr.mli index d85ad28a2ec..8b76d6f66c6 100644 --- a/ocaml/libs/http-lib/http_svr.mli +++ b/ocaml/libs/http-lib/http_svr.mli @@ -143,3 +143,5 @@ val https_client_of_req : Http.Request.t -> Ipaddr.t option val client_of_req_and_fd : Http.Request.t -> Unix.file_descr -> client option val string_of_client : client -> string + +val traceparent_of_request : Http.Request.t -> Tracing.Span.t option diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index ba95fbe03d9..7ac5da45e89 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -1,8 +1,12 @@ open Api_server_common module Server = Server.Make (Actions) (Forwarder) +let ( let@ ) f x = f x + (* This bit is called directly by the fake_rpc callback *) let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = + let parent = Http_svr.traceparent_of_request req in + let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in (* We now have the body string, the xml and the call name, and can also tell *) (* if we're a master or slave and whether the call came in on the unix domain socket or the tcp socket *) (* If we're a slave, and the call is from the unix domain socket or from the HIMN, and the call *isn't* *) @@ -20,7 +24,10 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = then forward req call is_json else - let response = Server.dispatch_call req fd call in + let response = + let@ _ = Tracing.with_child_trace span ~name:"Server.dispatch_call" in + Server.dispatch_call req fd call + in let translated = if is_json @@ -85,15 +92,26 @@ let create_thumbprint_header req response = (** HTML callback that dispatches an RPC and returns the response. *) let callback is_json req bio _ = + let parent = Http_svr.traceparent_of_request req in + let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = Http_svr.read_body ~limit:Constants.http_limit_max_rpc_size req bio in try - let rpc = Xmlrpc.call_of_string body in + let rpc = + let attributes = [("size", string_of_int (String.length body))] in + let@ _ = + Tracing.with_child_trace ~attributes ~name:"Xmlrpc.call_of_string" span + in + Xmlrpc.call_of_string body + in let response = callback1 is_json req fd rpc in let response_str = + let@ _ = + Tracing.with_child_trace ~name:"Xmlrpc.string_of_response" span + in if rpc.Rpc.name = "system.listMethods" then let inner = Xmlrpc.to_string response.Rpc.contents in Printf.sprintf @@ -129,6 +147,8 @@ let callback is_json req bio _ = (** HTML callback that dispatches an RPC and returns the response. *) let jsoncallback req bio _ = + let parent = Http_svr.traceparent_of_request req in + let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index aebdf144225..e3708bed112 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -149,6 +149,7 @@ tar tar-unix threads.posix + tracing unixpwd uri uuid @@ -234,6 +235,7 @@ rpclib.xml stunnel threads.posix + tracing xapi-backtrace xapi-client xapi-consts diff --git a/xapi-rrdd.opam b/xapi-rrdd.opam index 745af249f4b..89b2d827a69 100644 --- a/xapi-rrdd.opam +++ b/xapi-rrdd.opam @@ -27,6 +27,7 @@ depends: [ "xapi-rrd" {= version} "xapi-stdext-threads" {= version} "xapi-stdext-unix" {= version} + "xapi-tracing" "odoc" {with-doc} ] build: [ From 31e29c1b536951eb89cd96ebeb95620dac4b8963 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Fri, 2 Aug 2024 17:49:45 +0100 Subject: [PATCH 03/17] CA-396635: Wait for corosync to update its info Sometimes it takes the underlying cluster stack (corosync) some time to return a consistent view of the quorum. For example, it may be that the membership information correctly reflects the new members after a membership change, while the quorum field is still out of date. Add a delay here to make sure that the information from corosync represents a consistent snapshot of the current cluster state. Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_clustering.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 545674e92e0..249efa74da1 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -545,6 +545,13 @@ module Watcher = struct is an update. *) let cluster_change_interval = Mtime.Span.(5 * min) + (* CA-396635: Sometimes it takes the underlying cluster stack (corosync) some time + to return a consistent view of the quorum. For example, it may be that the membership + information correctly reflects the new members after a membership change, while the + quorum field is still out of date. Add a delay here to make sure that the information + from corosync represents a consistent snapshot of the current cluster state. *) + let stabilising_period = Mtime.Span.(5 * s) + let cluster_stack_watcher : bool Atomic.t = Atomic.make false (* we handle unclean hosts join and leave in the watcher, i.e. hosts joining and leaving @@ -558,10 +565,12 @@ module Watcher = struct "cluster change watcher call" (Clock.Timer.span_to_s cluster_change_interval) in - let find_cluster_and_update updates = + let find_cluster_and_update ?(wait = false) updates = match find_cluster_host ~__context ~host with | Some ch -> let cluster = Db.Cluster_host.get_cluster ~__context ~self:ch in + if wait then + Thread.delay (Clock.Timer.span_to_s stabilising_period) ; on_corosync_update ~__context ~cluster updates | None -> () @@ -569,7 +578,7 @@ module Watcher = struct match Idl.IdM.run @@ Cluster_client.IDL.T.get m with | Ok updates -> (* Received updates from corosync-notifyd *) - find_cluster_and_update updates + find_cluster_and_update ~wait:true updates | Error (InternalError "UPDATES.Timeout") -> (* UPDATES.get timed out, this is normal. *) (* CA-395789: We send a query to xapi-clusterd to fetch the latest state From 07db59a72d47064d137a526e75ec4a84a7bfe46f Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Tue, 23 Jul 2024 15:19:47 +0100 Subject: [PATCH 04/17] CP-50444: Intrument `request_of_bio` Intruments the request reading loop. Adds new functionality to the tracing library to update a span with a new parent. This way we can retroactively set the parent span with the correnct one. Signed-off-by: Gabriel Buica --- ocaml/libs/http-lib/http_svr.ml | 20 ++++++++++++++++++++ ocaml/libs/tracing/tracing.ml | 26 ++++++++++++++++++++++++++ ocaml/libs/tracing/tracing.mli | 12 ++++++++++++ 3 files changed, 58 insertions(+) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 51b2beacba8..1802e1dd4c9 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -453,9 +453,28 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio already sent back a suitable error code and response to the client. *) let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = try + let tracer = Tracing.Tracer.get_tracer ~name:"http_tracer" in + let loop_span = + match Tracing.Tracer.start ~tracer ~name:__FUNCTION__ ~parent:None () with + | Ok span -> + span + | Error _ -> + None + in let r, proxy = request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length ic in + let parent_span = traceparent_of_request r in + let loop_span = + Option.fold ~none:None + ~some:(fun span -> + Tracing.Tracer.update_span_with_parent span parent_span + ) + loop_span + in + let _ : (Tracing.Span.t option, exn) result = + Tracing.Tracer.finish loop_span + in (Some r, proxy) with e -> D.warn "%s (%s)" (Printexc.to_string e) __LOC__ ; @@ -583,6 +602,7 @@ let handle_connection ~header_read_timeout ~header_total_timeout request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length:max_header_length ic in + (* 2. now we attempt to process the request *) let finished = Option.fold ~none:true diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 28a5b2f687b..2356168da32 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -151,6 +151,8 @@ end module SpanContext = struct type t = {trace_id: string; span_id: string} [@@deriving rpcty] + let context trace_id span_id = {trace_id; span_id} + let to_traceparent t = Printf.sprintf "00-%s-%s-01" t.trace_id t.span_id let of_traceparent traceparent = @@ -624,6 +626,30 @@ module Tracer = struct let span = Span.start ~attributes ~name ~parent ~span_kind () in Spans.add_to_spans ~span ; Ok (Some span) + let update_span_with_parent span (parent : Span.t option) = + if Atomic.get observe then + match parent with + | None -> + Some span + | Some parent -> + span + |> Spans.remove_from_spans + |> Option.map (fun existing_span -> + let old_context = Span.get_context existing_span in + let new_context : SpanContext.t = + SpanContext.context + (SpanContext.trace_id_of_span_context parent.context) + old_context.span_id + in + let updated_span = {existing_span with parent= Some parent} in + let updated_span = {updated_span with context= new_context} in + + let () = Spans.add_to_spans ~span:updated_span in + updated_span + ) + else + Some span + let finish ?error span = Ok (Option.map diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index cd6e4204602..42b700ebb51 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -57,6 +57,8 @@ end module SpanContext : sig type t + val context : string -> string -> t + val to_traceparent : t -> string val of_traceparent : string -> t option @@ -125,6 +127,16 @@ module Tracer : sig -> unit -> (Span.t option, exn) result + val update_span_with_parent : Span.t -> Span.t option -> Span.t option + (**[update_span_with_parent s p] returns [Some span] where [span] is an + updated verison of the span [s]. + If [p] is [Some parent], [span] is a child of [parent], otherwise it is the + original [s]. + + If the span [s] is finished or is no longer considered an on-going span, + returns [None]. + *) + val finish : ?error:exn * string -> Span.t option -> (Span.t option, exn) result From 3fbcfb1b97f28630e31fa067586740c06fcb4fae Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Mon, 29 Jul 2024 11:23:40 +0100 Subject: [PATCH 05/17] tracing: fix `make check` warnings Fixes warning of unused records fields. These fields are part of the opentelementry spec but we are currently not using them in `xapi`. Signed-off-by: Gabriel Buica --- dune | 2 +- ocaml/libs/tracing/tracing.ml | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/dune b/dune index 9cf03f02dfc..e2b4842adb5 100644 --- a/dune +++ b/dune @@ -3,7 +3,7 @@ (ocamlopt_flags (:standard -g -p -w -39)) (flags (:standard -w -39)) ) - (dev (flags (:standard -g -w -39 -warn-error -69))) + (dev (flags (:standard -g -w -39))) (release (flags (:standard -w -39-6@5)) (env-vars (ALCOTEST_COMPACT 1)) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 2356168da32..04512f45453 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -127,7 +127,7 @@ let ok_none = Ok None module Status = struct type status_code = Unset | Ok | Error [@@deriving rpcty] - type t = {status_code: status_code; description: string option} + type t = {status_code: status_code; _description: string option} end module Attributes = struct @@ -169,7 +169,7 @@ module SpanContext = struct end module SpanLink = struct - type t = {context: SpanContext.t; attributes: (string * string) list} + type t = {_context: SpanContext.t; _attributes: (string * string) list} end module Span = struct @@ -210,7 +210,7 @@ module Span = struct (* Using gettimeofday over Mtime as it is better for sharing timestamps between the systems *) let begin_time = Unix.gettimeofday () in let end_time = None in - let status : Status.t = {status_code= Status.Unset; description= None} in + let status : Status.t = {status_code= Status.Unset; _description= None} in let links = [] in let events = [] in { @@ -252,7 +252,7 @@ module Span = struct let set_span_kind span span_kind = {span with span_kind} let add_link span context attributes = - let link : SpanLink.t = {context; attributes} in + let link : SpanLink.t = {_context= context; _attributes= attributes} in {span with links= link :: span.links} let add_event span name attributes = @@ -265,7 +265,7 @@ module Span = struct | exn, stacktrace -> ( let msg = Printexc.to_string exn in let exn_type = Printexc.exn_slot_name exn in - let description = + let _description = Some (Printf.sprintf "Error: %s Type: %s Backtrace: %s" msg exn_type stacktrace @@ -288,17 +288,17 @@ module Span = struct span.attributes (Attributes.of_list exn_attributes) in - {span with status= {status_code; description}; attributes} + {span with status= {status_code; _description}; attributes} | _ -> span ) let set_ok span = - let description = None in + let _description = None in let status_code = Status.Ok in match span.status.status_code with | Unset -> - {span with status= {status_code; description}} + {span with status= {status_code; _description}} | _ -> span end @@ -566,9 +566,9 @@ module TracerProvider = struct end module Tracer = struct - type t = {name: string; provider: TracerProvider.t} + type t = {_name: string; provider: TracerProvider.t} - let create ~name ~provider = {name; provider} + let create ~name ~provider = {_name= name; provider} let no_op = let provider : TracerProvider.t = @@ -579,7 +579,7 @@ module Tracer = struct ; enabled= false } in - {name= ""; provider} + {_name= ""; provider} let get_tracer ~name = if Atomic.get observe then ( @@ -600,7 +600,7 @@ module Tracer = struct let span_of_span_context context name : Span.t = { context - ; status= {status_code= Status.Unset; description= None} + ; status= {status_code= Status.Unset; _description= None} ; name ; parent= None ; span_kind= SpanKind.Client (* This will be the span of the client call*) From fcb781867815cb9ae6501f3a27a270e64aad3f37 Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Tue, 30 Jul 2024 11:29:01 +0100 Subject: [PATCH 06/17] tracing: increase the default maximum number of spans in a trace Increases the default maximum number of spans inside a trace from `1000` to `2500`. Now that we instrumented the internal http calls, with all components enabled, the number of spans inside `xapi` component for a `vm-start` operations is slightly greater than `1000`. This causes spans to be leaked, they are removed from the ongoing span table but never added in the finished tabled. Therefore, they are lost unless the limit is change in `/etc/xapi.conf`. This should fix the issue until we implement a better abstraction for the span hashtables. Signed-off-by: Gabriel Buica --- ocaml/libs/tracing/tracing.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 04512f45453..22d1e942288 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -313,7 +313,7 @@ module Spans = struct Hashtbl.length spans ) - let max_spans = Atomic.make 1000 + let max_spans = Atomic.make 2500 let set_max_spans x = Atomic.set max_spans x From 0fd7d6be3059b66b656988b3941ef457858c5ee9 Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Thu, 1 Aug 2024 11:20:46 +0100 Subject: [PATCH 07/17] CP-50444: Add specialized function for tracing http requests to `Http.Request` Like the title says, this commit adds `Http.Request.with_tracing` to `Http.Request`. This should enable updating the traceparent field of a request while we process it. Signed-off-by: Gabriel Buica --- ocaml/libs/http-lib/http.ml | 23 +++++++++++++++++++++++ ocaml/libs/http-lib/http.mli | 5 +++++ ocaml/libs/http-lib/http_svr.ml | 24 ++++-------------------- ocaml/libs/http-lib/http_svr.mli | 2 -- ocaml/xapi/api_server.ml | 12 +++++------- ocaml/xapi/server_helpers.ml | 3 +++ 6 files changed, 40 insertions(+), 29 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index c2f7e2aeda8..1f1e790de24 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -694,6 +694,29 @@ module Request = struct let headers, body = to_headers_and_body x in let frame_header = if x.frame then make_frame_header headers else "" in frame_header ^ headers ^ body + + let traceparent_of req = + let open Tracing in + let ( let* ) = Option.bind in + let* traceparent = req.traceparent in + let* span_context = SpanContext.of_traceparent traceparent in + let span = Tracer.span_of_span_context span_context req.uri in + Some span + + let with_tracing ?attributes ~name req f = + let open Tracing in + let parent = traceparent_of req in + with_child_trace ?attributes parent ~name (fun (span : Span.t option) -> + match span with + | Some span -> + let traceparent = + Some (span |> Span.get_context |> SpanContext.to_traceparent) + in + let req = {req with traceparent} in + f req + | None -> + f req + ) end module Response = struct diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 91590bcdcdd..3fbae8e4c6f 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -128,6 +128,11 @@ module Request : sig val to_wire_string : t -> string (** [to_wire_string t] returns a string which could be sent to a server *) + + val traceparent_of : t -> Tracing.Span.t option + + val with_tracing : + ?attributes:(string * string) list -> name:string -> t -> (t -> 'a) -> 'a end (** Parsed form of the HTTP response *) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 1802e1dd4c9..e04520d8567 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -101,18 +101,9 @@ let response_of_request req hdrs = ~headers:(connection :: cache :: hdrs) "200" "OK" -let traceparent_of_request req = - let open Tracing in - let ( let* ) = Option.bind in - let* traceparent = req.Http.Request.traceparent in - let* span_context = SpanContext.of_traceparent traceparent in - let span = Tracer.span_of_span_context span_context req.uri in - Some span - let response_fct req ?(hdrs = []) s (response_length : int64) (write_response_to_fd_fn : Unix.file_descr -> unit) = - let parent = traceparent_of_request req in - let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in let res = { (response_of_request req hdrs) with @@ -464,7 +455,7 @@ let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = let r, proxy = request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length ic in - let parent_span = traceparent_of_request r in + let parent_span = Http.Request.traceparent_of r in let loop_span = Option.fold ~none:None ~some:(fun span -> @@ -517,8 +508,8 @@ let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic = (None, None) let handle_one (x : 'a Server.t) ss context req = - let parent = traceparent_of_request req in - let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in + let span = Http.Request.traceparent_of req in let ic = Buf_io.of_fd ss in let finished = ref false in try @@ -533,13 +524,6 @@ let handle_one (x : 'a Server.t) ss context req = (Radix_tree.longest_prefix req.Request.uri method_map) in let@ _ = Tracing.with_child_trace span ~name:"handler" in - let traceparent = - let open Tracing in - Option.map - (fun span -> Span.get_context span |> SpanContext.to_traceparent) - span - in - let req = {req with traceparent} in ( match te.TE.handler with | BufIO handlerfn -> handlerfn req ic context diff --git a/ocaml/libs/http-lib/http_svr.mli b/ocaml/libs/http-lib/http_svr.mli index 8b76d6f66c6..d85ad28a2ec 100644 --- a/ocaml/libs/http-lib/http_svr.mli +++ b/ocaml/libs/http-lib/http_svr.mli @@ -143,5 +143,3 @@ val https_client_of_req : Http.Request.t -> Ipaddr.t option val client_of_req_and_fd : Http.Request.t -> Unix.file_descr -> client option val string_of_client : client -> string - -val traceparent_of_request : Http.Request.t -> Tracing.Span.t option diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index 7ac5da45e89..38f39e9b50f 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -5,8 +5,7 @@ let ( let@ ) f x = f x (* This bit is called directly by the fake_rpc callback *) let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = - let parent = Http_svr.traceparent_of_request req in - let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in (* We now have the body string, the xml and the call name, and can also tell *) (* if we're a master or slave and whether the call came in on the unix domain socket or the tcp socket *) (* If we're a slave, and the call is from the unix domain socket or from the HIMN, and the call *isn't* *) @@ -25,7 +24,7 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = forward req call is_json else let response = - let@ _ = Tracing.with_child_trace span ~name:"Server.dispatch_call" in + let@ req = Http.Request.with_tracing ~name:"Server.dispatch_call" req in Server.dispatch_call req fd call in let translated = @@ -92,8 +91,8 @@ let create_thumbprint_header req response = (** HTML callback that dispatches an RPC and returns the response. *) let callback is_json req bio _ = - let parent = Http_svr.traceparent_of_request req in - let@ span = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in + let span = Http.Request.traceparent_of req in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = @@ -147,8 +146,7 @@ let callback is_json req bio _ = (** HTML callback that dispatches an RPC and returns the response. *) let jsoncallback req bio _ = - let parent = Http_svr.traceparent_of_request req in - let@ _ = Tracing.with_child_trace parent ~name:__FUNCTION__ in + let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in let fd = Buf_io.fd_of bio in (* fd only used for writing *) let body = diff --git a/ocaml/xapi/server_helpers.ml b/ocaml/xapi/server_helpers.ml index ad76e38e531..e4952769c2f 100644 --- a/ocaml/xapi/server_helpers.ml +++ b/ocaml/xapi/server_helpers.ml @@ -18,6 +18,8 @@ open D exception Dispatcher_FieldNotFound of string +let ( let@ ) f x = f x + let my_assoc fld assoc_list = try List.assoc fld assoc_list with Not_found -> raise (Dispatcher_FieldNotFound fld) @@ -120,6 +122,7 @@ let dispatch_exn_wrapper f = let do_dispatch ?session_id ?forward_op ?self:_ supports_async called_fn_name op_fn marshaller fd http_req label sync_ty generate_task_for = (* if the call has been forwarded to us, then they are responsible for completing the task, so we don't need to complete it *) + let@ http_req = Http.Request.with_tracing ~name:__FUNCTION__ http_req in let called_async = sync_ty <> `Sync in if called_async && not supports_async then API.response_of_fault From cc90d32f34c83c43549605b84fe26567ef2e5628 Mon Sep 17 00:00:00 2001 From: Colin James Date: Fri, 9 Aug 2024 13:27:36 +0100 Subject: [PATCH 08/17] Output if parameter is required in JSON backend This change augments all parameter structures emitted by the JSON backend to include a "required" member that specifies whether the parameter is optional or not. Parameters are considered optional in the IDL if a default value is provided for them. The simplest example is session.login_with_password. This message permits two extra parameters, "version" and "originator" - but these are not required to successfully invoke the function. Signed-off-by: Colin James --- ocaml/idl/json_backend/gen_json.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/idl/json_backend/gen_json.ml b/ocaml/idl/json_backend/gen_json.ml index dd24c0f11cf..446eeb04b8f 100644 --- a/ocaml/idl/json_backend/gen_json.ml +++ b/ocaml/idl/json_backend/gen_json.ml @@ -197,6 +197,7 @@ end = struct ("type", `String t) ; ("name", `String p.param_name) ; ("doc", `String p.param_doc) + ; ("required", `Bool (Option.is_none p.param_default)) ] :: params , enums @ e From 571832e00303bb3e6248b042de2be2774b8973d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Mon, 12 Aug 2024 13:15:21 +0100 Subject: [PATCH 09/17] Python SDK: Move "Packaging" section out of the public docs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This has ended up in our public PyPI package description: https://pypi.org/project/XenAPI/ However it is irrelevant to a user of the package on PyPI, because they'd already get the "built" version, that has the version number inside, so they don't need OCaml or 'make' to use it. Signed-off-by: Edwin Török --- scripts/examples/python/PACKAGING.md | 8 ++++++++ scripts/examples/python/README.md | 9 --------- 2 files changed, 8 insertions(+), 9 deletions(-) create mode 100644 scripts/examples/python/PACKAGING.md diff --git a/scripts/examples/python/PACKAGING.md b/scripts/examples/python/PACKAGING.md new file mode 100644 index 00000000000..caec95e5079 --- /dev/null +++ b/scripts/examples/python/PACKAGING.md @@ -0,0 +1,8 @@ +Packaging +========= + +`setup.py` is generated using an ocaml binary that fetches the api version string from xapi. An opam switch with the [xs-opam](https://github.com/xapi-project/xs-opam) repository is needed in order to build the binary. + +To build the package `setuptools>=38.6.0` and `wheel` need to be installed in the system or in the active python virtualenv. + +To build, use the command `make`. diff --git a/scripts/examples/python/README.md b/scripts/examples/python/README.md index 7761002ac70..08bebfdb61a 100644 --- a/scripts/examples/python/README.md +++ b/scripts/examples/python/README.md @@ -8,12 +8,3 @@ Examples -------- The [examples](https://github.com/xapi-project/xen-api/tree/master/scripts/examples/python) will not work unless they have been placed in the same directory as `XenAPI.py` or `XenAPI` package from PyPI has been installed (`pip install XenAPI`) - -Packaging -========= - -`setup.py` is generated using an ocaml binary that fetches the api version string from xapi. An opam switch with the [xs-opam](https://github.com/xapi-project/xs-opam) repository is needed in order to build the binary. - -To build the package `setuptools>=38.6.0` and `wheel` need to be installed in the system or in the active python virtualenv. - -To build, use the command `make`. From 6b85e87c98ccfe69acf3ec963186db01d1bf487c Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 13 Aug 2024 09:56:00 +0100 Subject: [PATCH 10/17] Allow remediation commits for DCO Signed-off-by: Colin James --- .github/dco.yml | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 .github/dco.yml diff --git a/.github/dco.yml b/.github/dco.yml new file mode 100644 index 00000000000..1f94d940bd1 --- /dev/null +++ b/.github/dco.yml @@ -0,0 +1,3 @@ +allowRemediationCommits: + individual: true + thirdParty: true From 2b3a0a6cfeb537c28c7f14b0a8c475d906295ea6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Tue, 13 Aug 2024 10:06:38 +0100 Subject: [PATCH 11/17] CI: fix spurious failure on busy system MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ``` File "ocaml/libs/clock/dune", line 27, characters 19-33: 27 | (names test_date test_timer_run) ^^^^^^^^^^^^^^ qcheck random seed: 423397317 Testing `Timer'. This run has ID `D009HP55'. [<35;18;6M F............. ┌──────────────────────────────────────────────────────────────────────────────┐ │ [FAIL] Timer 0 Timer.remaining. │ └──────────────────────────────────────────────────────────────────────────────┘ Sleeping for 0.150000 seconds... Sleeping for 0.000500 seconds... test `Timer.remaining` failed on ≥ 1 cases: 1ms Expected to have spare time, but got excess: 1.91μs. Duration: 1ms, actual: 999μs, timer: elapsed: 1.03ms duration: 1ms ``` Here we asked for a sleep of 0.5ms, but got woken up twice as late. And the quickcheck property was expecting that the actual wake up time won't be twice as wrong. In reality it can wake up by arbitrary amounts of time later based on how busy the OS is, but we do need to check that the wakeups are not completely wrong. So skip the check on very short durations, but keep it on the longer 100ms and 300ms tests. Signed-off-by: Edwin Török --- ocaml/libs/clock/test_timer.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ocaml/libs/clock/test_timer.ml b/ocaml/libs/clock/test_timer.ml index 3729826cfa3..b94a3c470d2 100644 --- a/ocaml/libs/clock/test_timer.ml +++ b/ocaml/libs/clock/test_timer.ml @@ -25,6 +25,12 @@ let test_timer_remaining = (not (Timer.span_is_shorter Mtime.Span.(2 * actual) ~than:duration)) ; let () = match Timer.remaining timer with + | Expired _ when half < 0.05 -> + (* OS timer may not be accurate for very short sleeps, + or the system might be busy. + Skip the strict test on very short durations, we'll still test this on the 100ms+ ones. + *) + () | Expired t -> Test.fail_reportf "Expected to have spare time, but got excess: %a. Duration: %a, \ From f33d7f6a4bd7f98a57bef6538afe3cbb65216bec Mon Sep 17 00:00:00 2001 From: Stephen Cheng Date: Mon, 12 Aug 2024 03:56:45 +0100 Subject: [PATCH 12/17] CA-397171: Replace libjemalloc.so.1 with libjemalloc.so.2 jemalloc was updated to version 5.3.0: - Provides libjemalloc.so.2 instead of libjemalloc.so.1 - No longer supported `lg_dirty_mult` option Signed-off-by: Stephen Cheng --- ocaml/xenopsd/scripts/qemu-wrapper | 6 +++--- scripts/xapi-nbd.service | 4 ++-- scripts/xapi.service | 4 ++-- scripts/xcp-networkd.service | 4 ++-- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/ocaml/xenopsd/scripts/qemu-wrapper b/ocaml/xenopsd/scripts/qemu-wrapper index 15930adab43..9d9fc9aef8d 100644 --- a/ocaml/xenopsd/scripts/qemu-wrapper +++ b/ocaml/xenopsd/scripts/qemu-wrapper @@ -302,10 +302,10 @@ def main(argv): # set up library preload path for qemu such that it can use jemalloc qemu_env = os.environ if "LD_PRELOAD" not in qemu_env: - qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.1" + qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.2" else: - qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.1:" + qemu_env["LD_PRELOAD"] - qemu_env["MALLOC_CONF"] = "narenas:1,tcache:false,lg_dirty_mult:22" + qemu_env["LD_PRELOAD"] = "/usr/lib64/libjemalloc.so.2:" + qemu_env["LD_PRELOAD"] + qemu_env["MALLOC_CONF"] = "narenas:1,tcache:false" sys.stdout.flush() sys.stderr.flush() diff --git a/scripts/xapi-nbd.service b/scripts/xapi-nbd.service index 4290fe88dec..bca7b551a14 100644 --- a/scripts/xapi-nbd.service +++ b/scripts/xapi-nbd.service @@ -4,8 +4,8 @@ After=xapi.service message-switch.service syslog.target Wants=xapi.service message-switch.service syslog.target [Service] -Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.1" -Environment="MALLOC_CONF=narenas:1,tcache:false,lg_dirty_mult:22" +Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.2" +Environment="MALLOC_CONF=narenas:1,tcache:false" Environment=OCAMLRUNPARAM=b # The --certfile option must match the server-cert-path in xapi.conf # and the PathExists in xapi-nbd.path: any change must be made in all three files. diff --git a/scripts/xapi.service b/scripts/xapi.service index 58923c0a92c..e51c228989c 100644 --- a/scripts/xapi.service +++ b/scripts/xapi.service @@ -21,8 +21,8 @@ Conflicts=shutdown.target [Service] User=root -Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.1" -Environment="MALLOC_CONF=narenas:1,tcache:true,lg_dirty_mult:22" +Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.2" +Environment="MALLOC_CONF=narenas:1,tcache:true" Type=simple Restart=on-failure ExecStart=@LIBEXECDIR@/xapi-init start diff --git a/scripts/xcp-networkd.service b/scripts/xcp-networkd.service index e6aa2c5da93..eb49512cf24 100644 --- a/scripts/xcp-networkd.service +++ b/scripts/xcp-networkd.service @@ -6,8 +6,8 @@ Wants=forkexecd.service message-switch.service syslog.target [Service] Type=notify -Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.1" -Environment="MALLOC_CONF=narenas:1,tcache:false,lg_dirty_mult:22" +Environment="LD_PRELOAD=/usr/lib64/libjemalloc.so.2" +Environment="MALLOC_CONF=narenas:1,tcache:false" Environment=OCAMLRUNPARAM=b EnvironmentFile=-/etc/sysconfig/xcp-networkd ExecStart=/usr/sbin/xcp-networkd $XCP_NETWORKD_OPTIONS From 92561391840d9de31ad70249166ee43c2de9cb8d Mon Sep 17 00:00:00 2001 From: Ashwinh Date: Mon, 5 Aug 2024 15:09:38 +0000 Subject: [PATCH 13/17] CA-392685: Replace /tmp/network-reset with /var/tmp/network-reset to persist tmp file after reboot - Modified xapi_globs.ml to include this change. Signed-off-by: Ashwinh --- ocaml/xapi/xapi_globs.ml | 2 +- scripts/xe-reset-networking | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index f52dd8a2709..cdd6b8c16bb 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -639,7 +639,7 @@ let metrics_prefix_mem_vms = "xcp-rrdd-mem_vms" let metrics_prefix_pvs_proxy = "pvsproxy-" (** Path to trigger file for Network Reset. *) -let network_reset_trigger = "/tmp/network-reset" +let network_reset_trigger = "/var/tmp/network-reset" let first_boot_dir = "/etc/firstboot.d/" diff --git a/scripts/xe-reset-networking b/scripts/xe-reset-networking index 38f676a5aaa..a5bd437f9d3 100755 --- a/scripts/xe-reset-networking +++ b/scripts/xe-reset-networking @@ -24,7 +24,7 @@ from optparse import OptionParser pool_conf = '@ETCXENDIR@/pool.conf' inventory_file = '@INVENTORY@' management_conf = '/etc/firstboot.d/data/management.conf' -network_reset = '/tmp/network-reset' +network_reset = '/var/tmp/network-reset' def read_dict_file(fname): f = open(fname, 'r') From 69ee5b97e1f0cd26f83ac087c4962c82d65379f4 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 13 Aug 2024 12:24:23 +0100 Subject: [PATCH 14/17] Retroactively sign off 8337fa94b76097428621d1e1987 On behalf of Colin , I, Colin James , hereby add my Signed-off-by to this commit: 8337fa94b76097428621d1e1987c5d66c1b82095 Signed-off-by: Colin James From b33ceee9970b6447f1cd153e7678fda2615e6e83 Mon Sep 17 00:00:00 2001 From: Mark Syms Date: Tue, 6 Aug 2024 14:27:18 +0100 Subject: [PATCH 15/17] CA-396751: write updated RRDD data before headers Ensure that the updated data and metadata are written before the headers are updated otherwise xcp-rrdd might start reading the data block before all the data is populated and thus run off the end of the data. Signed-off-by: Mark Syms --- ocaml/xcp-rrdd/scripts/rrdd/rrdd.py | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py b/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py index a5dadf326c8..1132fa92b53 100644 --- a/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py +++ b/ocaml/xcp-rrdd/scripts/rrdd/rrdd.py @@ -283,7 +283,8 @@ def wait_until_next_reading(self, neg_shift=1): self.lazy_complete_init() next_reading = self.register() wait_time = next_reading - neg_shift - if wait_time < 0: wait_time %= self.frequency_in_seconds + if wait_time < 0: + wait_time %= self.frequency_in_seconds time.sleep(wait_time) return except socket.error: @@ -310,13 +311,10 @@ def update(self): metadata_json = json.dumps(metadata, sort_keys=True).encode('utf-8') metadata_checksum = crc32(metadata_json) & 0xffffffff - self.dest.seek(0) - self.dest.write('DATASOURCES'.encode()) - self.dest.write(pack(">LLLQ", - data_checksum, - metadata_checksum, - len(self.datasources), - timestamp)) + # First write the updated data and metadata + encoded_datasource_header = 'DATASOURCES'.encode() + # DATASOURCES + 20 for 32 + 32 + 32 + 64 + self.dest.seek(len(encoded_datasource_header) + 20) for val in data_values: # This is already big endian encoded self.dest.write(val) @@ -324,6 +322,16 @@ def update(self): self.dest.write(pack(">L", len(metadata_json))) self.dest.write(metadata_json) self.dest.flush() + + # Now write the updated header + self.dest.seek(0) + self.dest.write(encoded_datasource_header) + self.dest.write(pack(">LLLQ", + data_checksum, + metadata_checksum, + len(self.datasources), + timestamp)) + self.dest.flush() self.datasources = [] time.sleep( 0.003) # wait a bit to ensure wait_until_next_reading will block From ce24e0a8fbbab5e84a2c0a380ba22e1d6bdf67a3 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 13 Aug 2024 16:47:12 +0800 Subject: [PATCH 16/17] CA-397268: vbd.create failed: The device name is invalid In the commit 62db5cb, the device name validation was consolidated with the function which converts name to device number. Particularly, the function "Device_number.of_string" is used for both the validation and the conversion. But one issue was introduced in the validation is that the "None" value returned from "Device_number.of_string" is considered as valid. This causes the error "the device name is invalid". This commit just fixes this issue. Signed-off-by: Ming Lu --- ocaml/xapi/xapi_vbd_helpers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index 1285c740c27..94471108e41 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -377,7 +377,7 @@ let clear_current_operations ~__context ~self = (** Check if the device string has the right form *) let valid_device dev ~_type = dev = "autodetect" - || Option.is_none (Device_number.of_string dev ~hvm:false) + || Option.is_some (Device_number.of_string dev ~hvm:false) || match _type with | `Floppy -> From d04ba273582d6572820661c04e0ea25145f32112 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 14 Aug 2024 14:10:03 +0800 Subject: [PATCH 17/17] CA-397268: Add unit test for valid_device Signed-off-by: Ming Lu --- ocaml/tests/test_xapi_vbd_helpers.ml | 29 ++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/ocaml/tests/test_xapi_vbd_helpers.ml b/ocaml/tests/test_xapi_vbd_helpers.ml index 0aa4ef0a6d1..101abf6dd82 100644 --- a/ocaml/tests/test_xapi_vbd_helpers.ml +++ b/ocaml/tests/test_xapi_vbd_helpers.ml @@ -85,6 +85,34 @@ let test_ca253933_valid_operations () = in List.iter operation_is_valid valid_operations +let test_valid_device () = + let valid_devices = + [ + ("autodetect", `Floppy) + ; ("sda", `Disk) + ; ("sda0", `Disk) + ; ("sdp", `Disk) + ; ("sdp99", `Disk) + ; ("xvda", `Disk) + ; ("xvda0", `Disk) + ; ("xvdp", `Disk) + ; ("xvdp99", `Disk) + ; ("hda", `Disk) + ; ("hda0", `Disk) + ; ("hdp", `Disk) + ; ("hdp99", `Disk) + ; ("fda", `Disk) + ; ("fdb", `Disk) + ; ("0", `CD) + ; ("1", `CD) + ] + in + let check (dev, _type) = + let f = Xapi_vbd_helpers.valid_device in + Alcotest.(check bool) "must be equal" true (f dev ~_type) + in + List.iter check valid_devices + let test = [ ( "test_ca253933_invalid_operations" @@ -92,4 +120,5 @@ let test = , test_ca253933_invalid_operations ) ; ("test_ca253933_valid_operations", `Quick, test_ca253933_valid_operations) + ; ("test_valid_device", `Quick, test_valid_device) ]