From 3476a22562171cbb79de61359f11d627abe2586c Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Thu, 28 Nov 2024 14:47:51 +0000 Subject: [PATCH 01/73] Simple test for periodic scheduler Test that the event is correctly executed. Signed-off-by: Frediano Ziglio --- .../xapi-stdext/lib/xapi-stdext-threads/dune | 6 +-- .../lib/xapi-stdext-threads/scheduler_test.ml | 37 +++++++++++++++++++ .../xapi-stdext-threads/scheduler_test.mli | 0 3 files changed, 40 insertions(+), 3 deletions(-) create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml create mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.mli diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune index 7fcff9e08c2..d8036380cd7 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/dune @@ -1,7 +1,7 @@ (library (public_name xapi-stdext-threads) (name xapi_stdext_threads) - (modules :standard \ ipq scheduler threadext_test ipq_test) + (modules :standard \ ipq scheduler threadext_test ipq_test scheduler_test) (libraries mtime mtime.clock.os @@ -22,8 +22,8 @@ ) (tests - (names threadext_test ipq_test) + (names threadext_test ipq_test scheduler_test) (package xapi-stdext-threads) - (modules threadext_test ipq_test) + (modules threadext_test ipq_test scheduler_test) (libraries xapi_stdext_threads alcotest mtime.clock.os mtime fmt threads.posix xapi_stdext_threads_scheduler) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml new file mode 100644 index 00000000000..272b0572943 --- /dev/null +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml @@ -0,0 +1,37 @@ +(* + * Copyright (C) 2024 Cloud Software Group + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module Scheduler = Xapi_stdext_threads_scheduler.Scheduler + +let started = Atomic.make false + +let start_schedule () = + if not (Atomic.exchange started true) then + Thread.create Scheduler.loop () |> ignore + +let send event data = Event.(send event data |> sync) + +let receive event = Event.(receive event |> sync) + +let test_single () = + let finished = Event.new_channel () in + Scheduler.add_to_queue "one" Scheduler.OneShot 0.001 (fun () -> + send finished true + ) ; + start_schedule () ; + Alcotest.(check bool) "result" true (receive finished) + +let tests = [("test_single", `Quick, test_single)] + +let () = Alcotest.run "Scheduler" [("generic", tests)] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.mli new file mode 100644 index 00000000000..e69de29bb2d From 624926133b9b821391c2f5cfcbde72ed35afdb87 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Fri, 6 Dec 2024 09:56:53 +0000 Subject: [PATCH 02/73] Limit mutex contention in add_to_queue Signed-off-by: Frediano Ziglio --- .../lib/xapi-stdext-threads/scheduler.ml | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml index 3e8543ec04d..50c4c17d4b9 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml @@ -49,14 +49,11 @@ module Clock = struct end let add_to_queue ?(signal = true) name ty start newfunc = - with_lock lock (fun () -> - let ( ++ ) = Clock.add_span in - Ipq.add queue - { - Ipq.ev= {func= newfunc; ty; name} - ; Ipq.time= Mtime_clock.now () ++ start - } - ) ; + let ( ++ ) = Clock.add_span in + let item = + {Ipq.ev= {func= newfunc; ty; name}; Ipq.time= Mtime_clock.now () ++ start} + in + with_lock lock (fun () -> Ipq.add queue item) ; if signal then Delay.signal delay let remove_from_queue name = From f86c07666fd098b471511cd742c6bb08b8e21514 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Fri, 6 Dec 2024 10:05:22 +0000 Subject: [PATCH 03/73] Compare correctly Mtime.t Do not use ">" or other operators to compare Mtime.t, the value is intended to be unsigned and should be compared with Int64.unsigned_compare as Mtime functions do. Signed-off-by: Frediano Ziglio --- ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml index 50c4c17d4b9..2e0f28f8800 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml @@ -72,7 +72,7 @@ let loop () = else let next = with_lock lock (fun () -> Ipq.maximum queue) in let now = Mtime_clock.now () in - if next.Ipq.time < now then ( + if Mtime.is_earlier next.Ipq.time ~than:now then ( let todo = (with_lock lock (fun () -> Ipq.pop_maximum queue)).Ipq.ev in From 2950dd91f171b1be1297e446a8585fa1a1e10555 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Fri, 6 Dec 2024 10:10:19 +0000 Subject: [PATCH 04/73] Protect queue with mutex in remove_from_queue Signed-off-by: Frediano Ziglio --- ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml index 2e0f28f8800..03ee8ef976e 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml @@ -57,6 +57,7 @@ let add_to_queue ?(signal = true) name ty start newfunc = if signal then Delay.signal delay let remove_from_queue name = + with_lock lock @@ fun () -> let index = Ipq.find_p queue (fun {name= n; _} -> name = n) in if index > -1 then Ipq.remove queue index From 529eeaa98c9d225ac9a49c70094acfde4b6f62c7 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Fri, 6 Dec 2024 10:17:45 +0000 Subject: [PATCH 05/73] Remove signal parameter from add_to_queue The parameter was false only to support an internal usage, external users should always alert the thread loop. Signed-off-by: Frediano Ziglio --- .../libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml | 8 ++++++-- .../xapi-stdext/lib/xapi-stdext-threads/scheduler.mli | 3 +-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml index 03ee8ef976e..a8c56dc47e8 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml @@ -48,7 +48,7 @@ module Clock = struct Mtime.min_stamp end -let add_to_queue ?(signal = true) name ty start newfunc = +let add_to_queue_internal ?(signal = true) name ty start newfunc = let ( ++ ) = Clock.add_span in let item = {Ipq.ev= {func= newfunc; ty; name}; Ipq.time= Mtime_clock.now () ++ start} @@ -56,6 +56,9 @@ let add_to_queue ?(signal = true) name ty start newfunc = with_lock lock (fun () -> Ipq.add queue item) ; if signal then Delay.signal delay +let add_to_queue name ty start newfunc = + add_to_queue_internal name ty start newfunc + let remove_from_queue name = with_lock lock @@ fun () -> let index = Ipq.find_p queue (fun {name= n; _} -> name = n) in @@ -82,7 +85,8 @@ let loop () = | OneShot -> () | Periodic timer -> - add_to_queue ~signal:false todo.name todo.ty timer todo.func + add_to_queue_internal ~signal:false todo.name todo.ty timer + todo.func ) else (* Sleep until next event. *) let sleep = Mtime.(span next.Ipq.time now) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.mli index b087a35c5cf..d4d19b1f790 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.mli @@ -18,8 +18,7 @@ type func_ty = | OneShot (** Fire just once *) | Periodic of float (** Fire periodically with a given period in seconds *) -val add_to_queue : - ?signal:bool -> string -> func_ty -> float -> (unit -> unit) -> unit +val add_to_queue : string -> func_ty -> float -> (unit -> unit) -> unit (** Start a new timer. *) val remove_from_queue : string -> unit From 2c192c955825b7f8833c2e2565cc02fc887f44a6 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Tue, 26 Nov 2024 22:30:31 +0000 Subject: [PATCH 06/73] Fix multiple issues in periodic scheduler - Do not wait huge amount of time if the queue is empty but use Delay.wait if possible; - Fix delete of periodic events. In case the event is processed it's removed from the queue. Previously remove_from_queue was not able to mark this event as removed; - Do not race between checking the first event and removing it. These 2 actions were done in 2 separate critical section, now they are done in a single one. Signed-off-by: Frediano Ziglio --- .../lib/xapi-stdext-threads/scheduler.ml | 79 ++++++++++++------- 1 file changed, 50 insertions(+), 29 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml index a8c56dc47e8..a544ed79bbb 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml @@ -27,6 +27,8 @@ let delay = Delay.make () let queue_default = {func= (fun () -> ()); ty= OneShot; name= ""} +let (pending_event : t option ref) = ref None + let (queue : t Ipq.t) = Ipq.create 50 queue_default let lock = Mutex.create () @@ -48,50 +50,68 @@ module Clock = struct Mtime.min_stamp end -let add_to_queue_internal ?(signal = true) name ty start newfunc = +let add_to_queue name ty start newfunc = let ( ++ ) = Clock.add_span in let item = {Ipq.ev= {func= newfunc; ty; name}; Ipq.time= Mtime_clock.now () ++ start} in with_lock lock (fun () -> Ipq.add queue item) ; - if signal then Delay.signal delay - -let add_to_queue name ty start newfunc = - add_to_queue_internal name ty start newfunc + Delay.signal delay let remove_from_queue name = with_lock lock @@ fun () -> - let index = Ipq.find_p queue (fun {name= n; _} -> name = n) in - if index > -1 then - Ipq.remove queue index + match !pending_event with + | Some ev when ev.name = name -> + pending_event := None + | Some _ | None -> + let index = Ipq.find_p queue (fun {name= n; _} -> name = n) in + if index > -1 then + Ipq.remove queue index + +let add_periodic_pending () = + with_lock lock @@ fun () -> + match !pending_event with + | Some ({ty= Periodic timer; _} as ev) -> + let ( ++ ) = Clock.add_span in + let item = {Ipq.ev; Ipq.time= Mtime_clock.now () ++ timer} in + Ipq.add queue item ; + pending_event := None + | Some {ty= OneShot; _} -> + pending_event := None + | None -> + () let loop () = debug "%s started" __MODULE__ ; try while true do - let empty = with_lock lock (fun () -> Ipq.is_empty queue) in - if empty then - Thread.delay 10.0 - (* Doesn't happen often - the queue isn't usually empty *) - else - let next = with_lock lock (fun () -> Ipq.maximum queue) in - let now = Mtime_clock.now () in - if Mtime.is_earlier next.Ipq.time ~than:now then ( - let todo = - (with_lock lock (fun () -> Ipq.pop_maximum queue)).Ipq.ev - in + let now = Mtime_clock.now () in + let deadline, item = + with_lock lock @@ fun () -> + (* empty: wait till we get something *) + if Ipq.is_empty queue then + (Clock.add_span now 10.0, None) + else + let next = Ipq.maximum queue in + if Mtime.is_later next.Ipq.time ~than:now then + (* not expired: wait till time or interrupted *) + (next.Ipq.time, None) + else ( + (* remove expired item *) + Ipq.pop_maximum queue |> ignore ; + (* save periodic to be scheduled again *) + if next.Ipq.ev.ty <> OneShot then pending_event := Some next.Ipq.ev ; + (now, Some next.Ipq.ev) + ) + in + match item with + | Some todo -> (try todo.func () with _ -> ()) ; - match todo.ty with - | OneShot -> - () - | Periodic timer -> - add_to_queue_internal ~signal:false todo.name todo.ty timer - todo.func - ) else (* Sleep until next event. *) + add_periodic_pending () + | None -> ( + (* Sleep until next event. *) let sleep = - Mtime.(span next.Ipq.time now) - |> Mtime.Span.(add ms) - |> Clock.span_to_s + Mtime.(span deadline now) |> Mtime.Span.(add ms) |> Clock.span_to_s in try ignore (Delay.wait delay sleep) with e -> @@ -107,6 +127,7 @@ let loop () = normal delay. New events may be missed." detailed_msg ; Thread.delay sleep + ) done with _ -> error From 935c84f865bcdafac73fe203d6c5c1f058a4f22d Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Thu, 28 Nov 2024 15:19:12 +0000 Subject: [PATCH 07/73] Add test for removing periodic event in periodic scheduler Potentially a periodic event can be cancelled while this is processed. Simulate this behavior removing the event inside the handler. This was fixed by previous commit. Signed-off-by: Frediano Ziglio --- .../lib/xapi-stdext-threads/scheduler_test.ml | 30 ++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml index 272b0572943..8b0baeb74b1 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml @@ -24,6 +24,12 @@ let send event data = Event.(send event data |> sync) let receive event = Event.(receive event |> sync) +let elapsed_ms cnt = + let elapsed_ns = Mtime_clock.count cnt |> Mtime.Span.to_uint64_ns in + Int64.(div elapsed_ns 1000000L |> to_int) + +let is_less = Alcotest.(testable (pp int)) Stdlib.( > ) + let test_single () = let finished = Event.new_channel () in Scheduler.add_to_queue "one" Scheduler.OneShot 0.001 (fun () -> @@ -32,6 +38,28 @@ let test_single () = start_schedule () ; Alcotest.(check bool) "result" true (receive finished) -let tests = [("test_single", `Quick, test_single)] +let test_remove_self () = + let which = Event.new_channel () in + Scheduler.add_to_queue "self" (Scheduler.Periodic 0.001) 0.001 (fun () -> + (* this should remove the periodic scheduling *) + Scheduler.remove_from_queue "self" ; + (* add an operation to stop the test *) + Scheduler.add_to_queue "stop" Scheduler.OneShot 0.1 (fun () -> + send which "stop" + ) ; + send which "self" + ) ; + start_schedule () ; + let cnt = Mtime_clock.counter () in + Alcotest.(check string) "same event name" "self" (receive which) ; + Alcotest.(check string) "same event name" "stop" (receive which) ; + let elapsed_ms = elapsed_ms cnt in + Alcotest.check is_less "small time" 300 elapsed_ms + +let tests = + [ + ("test_single", `Quick, test_single) + ; ("test_remove_self", `Quick, test_remove_self) + ] let () = Alcotest.run "Scheduler" [("generic", tests)] From 60e12576ac08f6db431b1ddb251cba0b54c8d30e Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Thu, 28 Nov 2024 16:32:38 +0000 Subject: [PATCH 08/73] Add test for handling event if queue was empty in periodic scheduler Previously if the queue was empty and the loop thread was active the scheduler took quite some time to pick up the new event. Check that this is done in a timely fashion to avoid regressions in code. Signed-off-by: Frediano Ziglio --- .../lib/xapi-stdext-threads/scheduler_test.ml | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml index 8b0baeb74b1..2828b3a10a3 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml @@ -56,10 +56,28 @@ let test_remove_self () = let elapsed_ms = elapsed_ms cnt in Alcotest.check is_less "small time" 300 elapsed_ms +let test_empty () = + let finished = Event.new_channel () in + Scheduler.add_to_queue "one" Scheduler.OneShot 0.001 (fun () -> + send finished true + ) ; + start_schedule () ; + Alcotest.(check bool) "finished" true (receive finished) ; + (* wait loop to go to wait with no work to do *) + Thread.delay 0.1 ; + Scheduler.add_to_queue "two" Scheduler.OneShot 0.001 (fun () -> + send finished true + ) ; + let cnt = Mtime_clock.counter () in + Alcotest.(check bool) "finished" true (receive finished) ; + let elapsed_ms = elapsed_ms cnt in + Alcotest.check is_less "small time" 100 elapsed_ms + let tests = [ ("test_single", `Quick, test_single) ; ("test_remove_self", `Quick, test_remove_self) + ; ("test_empty", `Quick, test_empty) ] let () = Alcotest.run "Scheduler" [("generic", tests)] From 88dd4d9f5f2969532c43fce16177b21d9d7ac6e8 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Mon, 9 Dec 2024 14:50:27 +0000 Subject: [PATCH 09/73] Add a test to check the loop is woken up adding a new event Similar to test_empty test however the state of the loop should be different. Signed-off-by: Frediano Ziglio --- .../lib/xapi-stdext-threads/scheduler_test.ml | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml index 2828b3a10a3..0a4a847403f 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler_test.ml @@ -73,11 +73,31 @@ let test_empty () = let elapsed_ms = elapsed_ms cnt in Alcotest.check is_less "small time" 100 elapsed_ms +let test_wakeup () = + let which = Event.new_channel () in + (* schedule a long event *) + Scheduler.add_to_queue "long" Scheduler.OneShot 2.0 (fun () -> + send which "long" + ) ; + start_schedule () ; + (* wait loop to go to wait with no work to do *) + Thread.delay 0.1 ; + let cnt = Mtime_clock.counter () in + (* schedule a quick event, should wake up the loop *) + Scheduler.add_to_queue "quick" Scheduler.OneShot 0.1 (fun () -> + send which "quick" + ) ; + Alcotest.(check string) "same event name" "quick" (receive which) ; + Scheduler.remove_from_queue "long" ; + let elapsed_ms = elapsed_ms cnt in + Alcotest.check is_less "small time" 150 elapsed_ms + let tests = [ ("test_single", `Quick, test_single) ; ("test_remove_self", `Quick, test_remove_self) ; ("test_empty", `Quick, test_empty) + ; ("test_wakeup", `Quick, test_wakeup) ] let () = Alcotest.run "Scheduler" [("generic", tests)] From 3e70a6d5b31024f3894577e674b5c79d73c1069c Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Tue, 10 Dec 2024 14:19:00 +0000 Subject: [PATCH 10/73] Improve the scan comparison logic For the scan retry, previously we were comparing the entire vdi data structure from the database using the (<>) operator. This is a bit wasteful and not very stable. Instead let us just compare the vdi refs, since the race here comes from `VDI.db_{introduce,forget}`, which would only add/remove vdis from the db, but not change its actual data structure. Also add a bit more logging when retrying, since this should not happen very often. Signed-off-by: Vincent Liu --- ocaml/xapi/xapi_sr.ml | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/xapi_sr.ml b/ocaml/xapi/xapi_sr.ml index 12ab2bef924..a40a644ba04 100644 --- a/ocaml/xapi/xapi_sr.ml +++ b/ocaml/xapi/xapi_sr.ml @@ -778,15 +778,34 @@ let scan ~__context ~sr = Db.VDI.get_records_where ~__context ~expr:(Eq (Field "SR", Literal sr')) in + (* It is sufficient to just compare the refs in two db_vdis, as this + is what update_vdis uses to determine what to delete *) + let vdis_ref_equal db_vdi1 db_vdi2 = + Listext.List.set_difference (List.map fst db_vdi1) + (List.map fst db_vdi2) + = [] + in let db_vdis_before = find_vdis () in let vs, sr_info = C.SR.scan2 (Ref.string_of task) (Storage_interface.Sr.of_string sr_uuid) in let db_vdis_after = find_vdis () in - if limit > 0 && db_vdis_after <> db_vdis_before then + if limit > 0 && not (vdis_ref_equal db_vdis_before db_vdis_after) + then ( + debug + "%s detected db change while scanning, before scan vdis %s, \ + after scan vdis %s, retry limit left %d" + __FUNCTION__ + (List.map (fun (_, v) -> v.vDI_uuid) db_vdis_before + |> String.concat "," + ) + (List.map (fun (_, v) -> v.vDI_uuid) db_vdis_after + |> String.concat "," + ) + limit ; (scan_rec [@tailcall]) (limit - 1) - else if limit = 0 then + ) else if limit = 0 then raise (Api_errors.Server_error (Api_errors.internal_error, ["SR.scan retry limit exceeded"]) From 9ad46260077d799bb43d7debfb8d123cb99b7aa4 Mon Sep 17 00:00:00 2001 From: Changlei Li Date: Tue, 10 Dec 2024 14:18:03 +0800 Subject: [PATCH 11/73] CA-402901: Update leaked dp to Sr When add leaked datapath: 1. add leaked datapath to Sr.vdis 2. write to db file 3. log enhance If there are storage exceptions raised when destroying datapath, the procedure fails and the state of VDI becomes incorrect, which leads to various abnormalresults in subsequent operations. To handle this, the leaked datapath is designed to redestroy the datapath and refresh the state before next storage operation via function remove_datapaths_andthen_nolock. But this mechanism doesn't take effect in current code. This commit is to fix this bug. Leaked datapath should be added to Sr.vdis to make the leaked datapath really work. And write to db file to avoid losing the leaked datapath if xapi restarts. Signed-off-by: Changlei Li --- ocaml/xapi/storage_smapiv1_wrapper.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index ae1f21f72f3..55067efd9de 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -453,6 +453,9 @@ functor List.fold_left perform_one vdi_t ops let perform_nolock context ~dbg ~dp ~sr ~vdi ~vm this_op = + debug "%s dp=%s, sr=%s, vdi=%s, vm=%s, op=%s" __FUNCTION__ dp + (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) + (Vdi_automaton.string_of_op this_op) ; match Host.find sr !Host.host with | None -> raise (Storage_error (Sr_not_attached (s_of_sr sr))) @@ -473,6 +476,15 @@ functor superstate to superstate'. These may fail: if so we revert the datapath+VDI state to the most appropriate value. *) let ops = Vdi_automaton.( - ) superstate superstate' in + debug "%s %s -> %s: %s" __FUNCTION__ + (Vdi_automaton.string_of_state superstate) + (Vdi_automaton.string_of_state superstate') + (String.concat ", " + (List.map + (fun (op, _) -> Vdi_automaton.string_of_op op) + ops + ) + ) ; side_effects context dbg dp sr sr_t vdi vdi_t vm ops with e -> let e = @@ -529,7 +541,8 @@ functor ) with e -> if not allow_leak then ( - ignore (Vdi.add_leaked dp vdi_t) ; + Sr.add_or_replace vdi (Vdi.add_leaked dp vdi_t) sr_t ; + Everything.to_file !host_state_path (Everything.make ()) ; raise e ) else ( (* allow_leak means we can forget this dp *) From 017027bac62eb14824607c1e99f9a2f2582a9258 Mon Sep 17 00:00:00 2001 From: Konstantina Chremmou Date: Fri, 29 Nov 2024 17:11:45 +0000 Subject: [PATCH 12/73] Added manually messages that are not autogenerated. Signed-off-by: Konstantina Chremmou --- ocaml/sdk-gen/csharp/templates/Message2.mustache | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ocaml/sdk-gen/csharp/templates/Message2.mustache b/ocaml/sdk-gen/csharp/templates/Message2.mustache index 3dfe4f4503e..b6aa46d5f3e 100644 --- a/ocaml/sdk-gen/csharp/templates/Message2.mustache +++ b/ocaml/sdk-gen/csharp/templates/Message2.mustache @@ -43,6 +43,9 @@ namespace XenAPI LEAF_COALESCE_COMPLETED, LEAF_COALESCE_FAILED, POST_ATTACH_SCAN_FAILED, + WLB_HOST_POWER_OFF, + WLB_HOST_POWER_ON, + WLB_SERVER_TIME_DISCREPANCY, WLB_VM_RELOCATION, {{#message_types}} {{{message_type}}}, @@ -74,6 +77,12 @@ namespace XenAPI return MessageType.LEAF_COALESCE_FAILED; case "POST_ATTACH_SCAN_FAILED": return MessageType.POST_ATTACH_SCAN_FAILED; + case "WLB_HOST_POWER_OFF": + return MessageType.WLB_HOST_POWER_OFF; + case "WLB_HOST_POWER_ON": + return MessageType.WLB_HOST_POWER_ON; + case "WLB_SERVER_TIME_DISCREPANCY": + return MessageType.WLB_SERVER_TIME_DISCREPANCY; case "WLB_VM_RELOCATION": return MessageType.WLB_VM_RELOCATION; {{#message_types}} From 039f61fdf3965fa8123328273fd7d9dd40326fc5 Mon Sep 17 00:00:00 2001 From: Konstantina Chremmou Date: Fri, 29 Nov 2024 17:12:07 +0000 Subject: [PATCH 13/73] Docs tidy up: - Moved notes on error structure to the Wire protocol. - Moved duplicate file basics.md and wire-protocol.md from ocaml/doc to doc/content/xen-api. - Moved notes on VM boot parameters to doc/content/xen-api/topics/vm-lifecycle.md and removed ocaml/doc/vm-lifecycle.md. Signed-off-by: Konstantina Chremmou --- doc/content/xen-api/basics.md | 148 ++-- doc/content/xen-api/topics/vm-lifecycle.md | 48 +- doc/content/xen-api/wire-protocol.md | 942 ++++++++++++++++----- ocaml/doc/basics.md | 119 --- ocaml/doc/dune | 10 + ocaml/doc/vm-lifecycle.md | 50 -- ocaml/doc/wire-protocol.md | 664 --------------- ocaml/idl/templates/api_errors.mustache | 132 +-- ocaml/idl/templates/toc.mustache | 2 +- 9 files changed, 856 insertions(+), 1259 deletions(-) delete mode 100644 ocaml/doc/basics.md delete mode 100644 ocaml/doc/vm-lifecycle.md delete mode 100644 ocaml/doc/wire-protocol.md diff --git a/doc/content/xen-api/basics.md b/doc/content/xen-api/basics.md index ce4394c6afa..5288090aa34 100644 --- a/doc/content/xen-api/basics.md +++ b/doc/content/xen-api/basics.md @@ -3,14 +3,16 @@ title = "XenAPI Basics" weight = 10 +++ -This document contains a description of the Xen Management API – an interface for +This document contains a description of the Xen Management API - an interface for remotely configuring and controlling virtualised guests running on a Xen-enabled host. -The XenAPI is presented here as a set of Remote Procedure Calls, with a wire -format based upon [XML-RPC](http://xmlrpc.scripting.com). -No specific language bindings are prescribed, -although examples will be given in the python programming language. +The API is presented here as a set of Remote Procedure Calls (RPCs). +There are two supported wire formats, one based upon +[XML-RPC](http://xmlrpc.scripting.com/spec.html) +and one based upon [JSON-RPC](http://www.jsonrpc.org) (v1.0 and v2.0 are both +recognized). No specific language bindings are prescribed, although examples +are given in the Python programming language. Although we adopt some terminology from object-oriented programming, future client language bindings may or may not be object oriented. @@ -21,98 +23,102 @@ specific values. Objects are persistent and exist on the server-side. Clients may obtain opaque references to these server-side objects and then access their fields via get/set RPCs. -For each class we specify a list of fields along with their _types_ and _qualifiers_. A -qualifier is one of: +For each class we specify a list of fields along with their _types_ and +_qualifiers_. A qualifier is one of: -- _RO/runtime_: the field is Read -Only. Furthermore, its value is automatically computed at runtime. -For example: current CPU load and disk IO throughput. -- _RO/constructor_: the field must be manually set -when a new object is created, but is then Read Only for -the duration of the object's life. -For example, the maximum memory addressable by a guest is set -before the guest boots. -- _RW_: the field is Read/Write. For example, the name of a VM. +- _RO/runtime_: the field is Read Only. Furthermore, its value is + automatically computed at runtime. For example, current CPU load and disk IO + throughput. -Types ------ +- _RO/constructor_: the field must be manually set when a new object is + created, but is then Read Only for the duration of the object's life. + For example, the maximum memory addressable by a guest is set + before the guest boots. + +- _RW_: the field is Read/Write. For example, the name of a VM. + +## Types The following types are used to specify methods and fields in the API Reference: -- `string`: Text strings. -- `int`: 64-bit integers. -- `float`: IEEE double-precision floating-point numbers. -- `bool`: Boolean. -- `datetime`: Date and timestamp. -- `c ref`: Reference to an object of class `c`. -- `t set`: Arbitrary-length set of values of type `t`. -- `(k → v) map`: Mapping from values of type `k` to values of type `v`. -- `e enum`: Enumeration type with name `e`. Enums are defined in the API Reference together with classes that use them. - -Note that there are a number of cases where `ref`s are _doubly -linked_ – e.g. a VM has a field called `VIFs` of type -`VIF ref set`; this field lists -the network interfaces attached to a particular VM. Similarly, the VIF -class has a field called `VM` of type `VM ref` which references the VM to which the interface is connected. +- `string`: Text strings. +- `int`: 64-bit integers. +- `float`: IEEE double-precision floating-point numbers. +- `bool`: Boolean. +- `datetime`: Date and timestamp. +- `c ref`: Reference to an object of class `c`. +- `t set`: Arbitrary-length set of values of type `t`. +- `(k -> v) map`: Mapping from values of type `k` to values of type `v`. +- `e enum`: Enumeration type with name `e`. Enums are defined in the API + reference together with classes that use them. + +Note that there are a number of cases where `ref`s are _doubly linked_. +For example, a `VM` has a field called `VIFs` of type `VIF ref set`; +this field lists the network interfaces attached to a particular VM. +Similarly, the `VIF` class has a field called `VM` of type `VM ref` +which references the VM to which the interface is connected. These two fields are _bound together_, in the sense that creating a new VIF causes the `VIFs` field of the corresponding VM object to be updated automatically. -The API reference explicitly lists the fields that are +The API reference lists explicitly the fields that are bound together in this way. It also contains a diagram that shows relationships between classes. In this diagram an edge signifies the -existance of a pair of fields that are bound together, using standard +existence of a pair of fields that are bound together, using standard crows-foot notation to signify the type of relationship (e.g. one-many, many-many). -RPCs associated with fields ---------------------------- +## RPCs associated with fields + +Each field, `f`, has an RPC accessor associated with it that returns `f`'s value: + +- `get_f (r)`: takes a `ref`, `r` that refers to an object and returns the value + of `f`. + +Each field, `f`, with qualifier _RW_ and whose outermost type is `set` has the +following additional RPCs associated with it: -Each field, `f`, has an RPC accessor associated with it -that returns `f`'s value: +- `add_f(r, v)`: adds a new element `v` to the set. + Note that sets cannot contain duplicate values, hence this operation has + no action in the case that `v` is already in the set. -- `get_f (r)`: Takes a `ref`, `r`, that refers to an object and returns the value of `f`. +- `remove_f(r, v)`: removes element `v` from the set. -Each field, `f`, with attribute `RW` and whose outermost type is `set` has the following -additional RPCs associated with it: +Each field, `f`, with qualifier _RW_ and whose outermost type is `map` has the +following additional RPCs associated with it: -- `add_f (r, v)`: Adds a new element `v` to the set. Since sets cannot contain duplicate values this operation has no action in the case -that `v` was already in the set. +- `add_to_f(r, k, v)`: adds new pair `k -> v` to the mapping stored in `f` in + object `r`. Attempting to add a new pair for duplicate key, `k`, fails with a + `MAP_DUPLICATE_KEY` error. -- `remove_f (r, v)`: Removes element `v` from the set. +- `remove_from_f(r, k)`: removes the pair with key `k` + from the mapping stored in `f` in object `r`. -Each field, `f`, with attribute RW and whose outermost type is `map` has the following -additional RPCs associated with it: +Each field whose outermost type is neither `set` nor `map`, but whose +qualifier is _RW_ has an RPC accessor associated with it that sets its value: -- `add_to_f (r, k, v)`: Adds new pair `(k → v)` to the mapping stored in `f` in object `r`. Attempting to add a new pair for duplicate -key, `k`, fails with an `MAP_DUPLICATE_KEY` error. -- `remove_from_f (r, k)`: Removes the pair with key `k` from the mapping stored in `f` in object `r`. +- `set_f(r, v)`: sets the field `f` on object `r` to value `v`. -Each field whose outermost type is neither `set` nor `map`, -but whose attribute is RW has an RPC accessor associated with it -that sets its value: +## RPCs associated with classes -- `set_f (r, v)`: Sets field `f` on object `r` to value `v`. +- Most classes have a _constructor_ RPC named `create` that + takes as parameters all fields marked _RW_ and _RO/constructor_. The result + of this RPC is that a new _persistent_ object is created on the server-side + with the specified field values. -RPCs associated with classes ----------------------------- +- Each class has a `get_by_uuid(uuid)` RPC that returns the object + of that class that has the specified `uuid`. -- Most classes have a _constructor_ RPC named `create` that -takes as parameters all fields marked RW and -RO/constructor. The result of this RPC is that a new _persistent_ object is -created on the server-side with the specified field values. -- Each class has a `get_by_uuid (uuid)` RPC that returns the object -of that class that has the specified UUID. -- Each class that has a `name_label` field has a `get_by_name_label (name_label)` RPC that returns a set of objects of that -class that have the specified `name_label`. -- Most classes have a `destroy (r)` RPC that explicitly deletes the persistent object specified by `r` from the system. This is a -non-cascading delete – if the object being removed is referenced by another -object then the `destroy` call will fail. +- Each class that has a `name_label` field has a + `get_by_name_label(name_label)` RPC that returns a set of objects of that + class that have the specified `name_label`. -Additional RPCs ---------------- +- Most classes have a `destroy(r)` RPC that explicitly deletes + the persistent object specified by `r` from the system. This is a + non-cascading delete - if the object being removed is referenced by another + object then the `destroy` call will fail. -As well as the RPCs enumerated above, most classes have additional RPCs -associated with them. For example, the VM class has RPCs for cloning, +Apart from the RPCs enumerated above, most classes have additional RPCs +associated with them. For example, the `VM` class has RPCs for cloning, suspending, starting etc. Such additional RPCs are described explicitly in the API reference. diff --git a/doc/content/xen-api/topics/vm-lifecycle.md b/doc/content/xen-api/topics/vm-lifecycle.md index 4531acd07f7..7390dc61e80 100644 --- a/doc/content/xen-api/topics/vm-lifecycle.md +++ b/doc/content/xen-api/topics/vm-lifecycle.md @@ -2,6 +2,9 @@ title = "VM Lifecycle" +++ +The following figure shows the states that a VM can be in and the +API calls that can be used to move the VM between these states. + ```mermaid graph halted-- start(paused) -->paused @@ -17,7 +20,48 @@ graph halted-- destroy -->destroyed ``` -The figure above shows the states that a VM can be in and the -API calls that can be used to move the VM between these states. +## VM boot parameters + +The `VM` class contains a number of fields that control the way in which the VM +is booted. With reference to the fields defined in the VM class (see later in +this document), this section outlines the boot options available and the +mechanisms provided for controlling them. + +VM booting is controlled by setting one of the two mutually exclusive groups: +"PV" and "HVM". If `HVM.boot_policy` is an empty string, then paravirtual +domain building and booting will be used; otherwise the VM will be loaded as a +HVM domain, and booted using an emulated BIOS. + +When paravirtual booting is in use, the `PV_bootloader` field indicates the +bootloader to use. It may be "pygrub", in which case the platform's default +installation of pygrub will be used, or a full path within the control domain to +some other bootloader. The other fields, `PV_kernel`, `PV_ramdisk`, `PV_args`, +and `PV_bootloader_args` will be passed to the bootloader unmodified, and +interpretation of those fields is then specific to the bootloader itself, +including the possibility that the bootloader will ignore some or all of +those given values. Finally the paths of all bootable disks are added to the +bootloader commandline (a disk is bootable if its VBD has the bootable flag set). +There may be zero, one, or many bootable disks; the bootloader decides which +disk (if any) to boot from. + +If the bootloader is pygrub, then the menu.lst is parsed, if present in the +guest's filesystem, otherwise the specified kernel and ramdisk are used, or an +autodetected kernel is used if nothing is specified and autodetection is +possible. `PV_args` is appended to the kernel command line, no matter which +mechanism is used for finding the kernel. + +If `PV_bootloader` is empty but `PV_kernel` is specified, then the kernel and +ramdisk values will be treated as paths within the control domain. If both +`PV_bootloader` and `PV_kernel` are empty, then the behaviour is as if +`PV_bootloader` were specified as "pygrub". + +When using HVM booting, `HVM_boot_policy` and `HVM_boot_params` specify the boot +handling. Only one policy is currently defined, "BIOS order". In this case, +`HVM_boot_params` should contain one key-value pair "order" = "N" where N is the +string that will be passed to QEMU. +Optionally `HVM_boot_params` can contain another key-value pair "firmware" +with values "bios" or "uefi" (default is "bios" if absent). +By default Secure Boot is not enabled, it can be enabled when "uefi" is enabled +by setting `VM.platform["secureboot"]` to true. {{% children %}} diff --git a/doc/content/xen-api/wire-protocol.md b/doc/content/xen-api/wire-protocol.md index 689819a88a9..8a4fe9f5012 100644 --- a/doc/content/xen-api/wire-protocol.md +++ b/doc/content/xen-api/wire-protocol.md @@ -3,136 +3,106 @@ title = "Wire Protocol" weight = 20 +++ -API calls are sent over a network to a Xen-enabled host using the -[XML-RPC](http://xmlrpc.scripting.com/spec.html) protocol. On this page, we describe how the higher-level types -used in our API Reference are mapped to primitive XML-RPC types. +API calls are sent over a network to a Xen-enabled host using an RPC protocol. +Here we describe how the higher-level types used in our API Reference are mapped +to primitive RPC types, covering the two supported wire formats +[XML-RPC](http://xmlrpc.scripting.com/spec.html) and [JSON-RPC](http://www.jsonrpc.org). -We specify the signatures of API functions in the following style: - - (VM ref set) VM.get_all () - -This specifies that the function with name `VM.get_all` -takes no parameters and returns a `set` of `VM ref`s. These -types are mapped onto XML-RPC types in a straight-forward manner: - -- `float`s, `bool`s, `datetime`s and `string`s map directly to the XML-RPC - ``, ``, ``, and `` elements. - -- all `ref` types are opaque references, encoded as the - XML-RPC’s `` type. Users of the API should not make - assumptions about the concrete form of these strings and should not - expect them to remain valid after the client’s session with the - server has terminated. - -- fields named `uuid` of type `string` are - mapped to the XML-RPC `` type. The string itself is - the OSF DCE UUID presentation format (as output by - `uuidgen`, etc). - -- `int`s are all assumed to be 64-bit in our API and are encoded as a - string of decimal digits (rather than using XML-RPC’s built-in - 32-bit `` type). - -- values of `enum` types are encoded as strings. For example, a value of - `destroy` of type `enum on_normal_exit`, would be - conveyed as: - - destroy - -- for all our types, `t`, our type `t set` - simply maps to XML-RPC’s `` type, so for example a - value of type `string set` would be transmitted like - this: - - - - - CX8 - PSE36 - FPU - - - +## XML-RPC Protocol -- for types `k` and `v`, our type `(k → v) map` maps onto an XML-RPC ``, with the key as the name of - the struct. Note that the `(k → v) map` type is only valid - when `k` is a `string`, `ref`, or `int`, and in each case the keys of the maps are - stringified as above. For example, the `(string → double) map` containing a the mappings `"Mike" → 2.3` and - `"John" → 1.2` would be represented as: - - - - - Mike - 2.3 - - - John - 1.2 - - - - - -- our `void` type is transmitted as an empty string. - -Note on References vs UUIDs ---------------------------- - -References are opaque types — encoded as XML-RPC strings on the wire — -understood only by the particular server which generated them. Servers -are free to choose any concrete representation they find convenient; -clients should not make any assumptions or attempt to parse the string -contents. References are not guaranteed to be permanent identifiers for -objects; clients should not assume that references generated during one -session are valid for any future session. References do not allow -objects to be compared for equality. Two references to the same object -are not guaranteed to be textually identical. - -UUIDs are intended to be permanent names for objects. They are -guaranteed to be in the OSF DCE UUID presentation format (as output by -`uuidgen`. Clients may store UUIDs on disk and use them to -lookup objects in subsequent sessions with the server. Clients may also -test equality on objects by comparing UUID strings. - -The API provides mechanisms for translating between UUIDs and opaque -references. Each class that contains a UUID field provides: - -- A `get_by_uuid` method that takes a UUID, and - returns an opaque reference to the server-side object that has that - UUID; - -- A `get_uuid` function (a regular “field getter” RPC) - that takes an opaque reference and returns the UUID of the - server-side object that is referenced by it. +We specify the signatures of API functions in the following style: -Return Values/Status Codes --------------------------- +```python +(VM ref set) VM.get_all() +``` + +This specifies that the function with name `VM.get_all` takes +no parameters and returns a `set` of `VM ref`. +These types are mapped onto XML-RPC types in a straight-forward manner: + +- the types `float`, `bool`, `datetime`, and `string` map directly to the XML-RPC + ``, ``, ``, and `` elements. + +- all `ref` types are opaque references, encoded as the + XML-RPC's `` type. Users of the API should not make assumptions + about the concrete form of these strings and should not expect them to + remain valid after the client's session with the server has terminated. + +- fields named `uuid` of type `string` are mapped to + the XML-RPC `` type. The string itself is the OSF + DCE UUID presentation format (as output by `uuidgen`). + +- `int` is assumed to be 64-bit in our API and is encoded as a string + of decimal digits (rather than using XML-RPC's built-in 32-bit `` type). + +- values of `enum` types are encoded as strings. For example, the value + `destroy` of `enum on_normal_exit`, would be conveyed as: + +```xml + destroy +``` + +- for all our types, `t`, our type `t set` simply maps to XML-RPC's `` + type, so, for example, a value of type `string set` would be transmitted like + this: + +```xml + + + CX8 + PSE36 + FPU + + +``` + +- for types `k` and `v`, our type `(k -> v) map` maps onto an + XML-RPC ``, with the key as the name of the struct. Note that the + `(k -> v) map` type is only valid when `k` is a `string`, `ref`, or + `int`, and in each case the keys of the maps are stringified as + above. For example, the `(string -> float) map` containing the mappings + _Mike -> 2.3_ and _John -> 1.2_ would be represented as: + +```xml + + + + Mike + 2.3 + + + John + 1.2 + + + +``` + +- our `void` type is transmitted as an empty string. + +### XML-RPC Return Values and Status Codes The return value of an RPC call is an XML-RPC ``. -- The first element of the struct is named `"Status"`; it - contains a string value indicating whether the result of the call - was a `"Success"` or a `"Failure"`. +- The first element of the struct is named `Status`; it contains a string value + indicating whether the result of the call was a `Success` or a `Failure`. -If `"Status"` was set to `"Success"` then the Struct -contains a second element named `"Value"`: +If the `Status` is `Success` then the struct contains a second element named +`Value`: -- The element of the struct named `"Value"` contains the - function’s return value. +- The element of the struct named `Value` contains the function's return value. -In the case where `"Status"` is set to `"Failure"` -then the struct contains a second element named -`"ErrorDescription"`: +If the `Status` is `Failure` then the struct contains a second element named +`ErrorDescription`: -- The element of the struct named `"ErrorDescription"` - contains an array of string values. The first element of the array - is an error code; the remainder of the array are strings - representing error parameters relating to that code. +- The element of the struct named `ErrorDescription` contains an array of string + values. The first element of the array is an error code; the rest of the + elements are strings representing error parameters relating to that code. -For example, an XML-RPC return value from the -`host.get_resident_VMs` function above may look like this: +For example, an XML-RPC return value from the `host.get_resident_VMs` function +may look like this: +```xml Status @@ -151,149 +121,675 @@ For example, an XML-RPC return value from the +``` + +## JSON-RPC Protocol -Making XML-RPC Calls -==================== +We specify the signatures of API functions in the following style: -Transport Layer ---------------- +```python +(VM ref set) VM.get_all() +``` -The following transport layers are currently supported: +This specifies that the function with name `VM.get_all` takes no parameters and +returns a `set` of `VM ref`. These types are mapped onto JSON-RPC types in the +following manner: -- HTTPS for remote administration +- the types `float` and `bool` map directly to the JSON types `number` and + `boolean`, while `datetime` and `string` are represented as the JSON `string` + type. -- HTTP over Unix domain sockets for local administration +- all `ref` types are opaque references, encoded as the JSON `string` type. + Users of the API should not make assumptions about the concrete form of these + strings and should not expect them to remain valid after the client's session + with the server has terminated. -Session Layer -------------- +- fields named `uuid` of type `string` are mapped to the JSON `string` type. The + string itself is the OSF DCE UUID presentation format (as output by `uuidgen`). -The XML-RPC interface is session-based; before you can make arbitrary -RPC calls you must login and initiate a session. For example: +- `int` is assumed to be 64-bit in our API and is encoded as a JSON `number` + without decimal point or exponent, preserved as a string. - (session ref) session.login_with_password(string uname, string pwd, string version, string originator) +- values of `enum` types are encoded as the JSON `string` type. For example, the + value `destroy` of `enum on_normal_exit`, would be conveyed as: -Where `uname` and `password` refer to your -username and password respectively, as defined by the Xen administrator. -The `session ref` returned by `session.login_with_password` is passed to subequent RPC -calls as an authentication token. +```xml + "destroy" +``` -A session can be terminated with the `session.logout` function: +- for all our types, `t`, our type `t set` simply maps to the JSON `array` + type, so, for example, a value of type `string set` would be transmitted like + this: + +```json + [ "CX8", "PSE36", "FPU" ] +``` - (void) session.logout (session ref) +- for types `k` and `v`, our type `(k -> v) map` maps onto a JSON object which + contains members with name `k` and value `v`. Note that the + `(k -> v) map` type is only valid when `k` is a `string`, `ref`, or + `int`, and in each case the keys of the maps are stringified as + above. For example, the `(string -> float) map` containing the mappings + _Mike -> 2.3_ and _John -> 1.2_ would be represented as: -Synchronous and Asynchronous invocation ---------------------------------------- +```json + { + "Mike": 2.3, + "John": 1.2 + } +``` -Each method call (apart from methods on `session` and `task` objects and -“getters” and “setters” derived from fields) can be made either -synchronously or asynchronously. A synchronous RPC call blocks until the -return value is received; the return value of a synchronous RPC call is -exactly as specified above. +- our `void` type is transmitted as an empty string. -Only synchronous API calls are listed explicitly in this document. All -asynchronous versions are in the special `Async` namespace. -For example, synchronous call `VM.clone (...)` has an asynchronous counterpart, -`Async.VM.clone (...)`, that is non-blocking. +Both versions 1.0 and 2.0 of the JSON-RPC wire format are recognised and, +depending on your client library, you can use either of them. -Instead of returning its result directly, an asynchronous RPC call -returns a task ID (of type `task ref`); this identifier is subsequently used to -track the status of a running asynchronous RPC. Note that an asychronous -call may fail immediately, before a task has even been -created. To represent this eventuality, the returned `task ref` -is wrapped in an XML-RPC struct with a `Status`, -`ErrorDescription` and `Value` fields, exactly as -specified above. +### JSON-RPC v1.0 -The `task ref` is provided in the `Value` field if -`Status` is set to `Success`. +#### JSON-RPC v1.0 Requests -The RPC call +An API call is represented by sending a single JSON object to the server, which +contains the members `method`, `params`, and `id`. - (task ref set) task.get_all (session ref) +- `method`: A JSON `string` containing the name of the function to be invoked. -returns a set of all task IDs known to the system. The status (including -any returned result and error codes) of these tasks can then be queried -by accessing the fields of the Task object in the usual way. Note that, -in order to get a consistent snapshot of a task’s state, it is advisable -to call the `get_record` function. +- `params`: A JSON `array` of values, which represents the parameters of the + function to be invoked. + +- `id`: A JSON `string` or `integer` representing the call id. Note that, + diverging from the JSON-RPC v1.0 specification the API does not accept + _notification_ requests (requests without responses), i.e. the id cannot be + `null`. + +For example, the body of a JSON-RPC v1.0 request to retrieve the resident VMs of +a host may look like this: -Example interactive session -=========================== +```json + { + "method": "host.get_resident_VMs", + "params": [ + "OpaqueRef:74f1a19cd-b660-41e3-a163-10f03e0eae67", + "OpaqueRef:08c34fc9-f418-4f09-8274-b9cb25cd8550" + ], + "id": "xyz" + } +``` -This section describes how an interactive session might look, using the -python XML-RPC client library. +In the above example, the first element of the `params` array is the reference +of the open session to the host, while the second is the host reference. -First, initialise python and import the library `xmlrpc.client`: +#### JSON-RPC v1.0 Return Values - $ python - ... - >>> import xmlrpc.client +The return value of a JSON-RPC v1.0 call is a single JSON object containing +the members `result`, `error`, and `id`. -Create a python object referencing the remote server: +- `result`: If the call is successful, it is a JSON value (`string`, `array` + etc.) representing the return value of the invoked function. If an error has + occurred, it is `null`. - >>> xen = xmlrpc.client.Server("https://localhost:443") +- `error`: If the call is successful, it is `null`. If the call has failed, it + a JSON `array` of `string` values. The first element of the array is an error + code; the remainder of the array are strings representing error parameters + relating to that code. -Acquire a session reference by logging in with a username and password -(error-handling ommitted for brevity; the session reference is returned -under the key `'Value'` in the resulting dictionary) +- `id`: The call id. It is a JSON `string` or `integer` and it is the same id + as the request it is responding to. - >>> session = xen.session.login_with_password("user", "passwd")['Value'] +For example, a JSON-RPC v1.0 return value from the `host.get_resident_VMs` +function may look like this: -When serialised, this call looks like the following: +```json + { + "result": [ + "OpaqueRef:604f51e7-630f-4412-83fa-b11c6cf008ab", + "OpaqueRef:670d08f5-cbeb-4336-8420-ccd56390a65f" + ], + "error": null, + "id": "xyz" + } +``` - - - session.login_with_password - - - user - - - passwd - - - +while the return value of the same call made on a logged out session may look +like this: + +```json + { + "result": null, + "error": [ + "SESSION_INVALID", + "OpaqueRef:93f1a23cd-a640-41e3-b163-10f86e0eae67" + ], + "id": "xyz" + } +``` + +### JSON-RPC v2.0 + +#### JSON-RPC v2.0 Requests + +An API call is represented by sending a single JSON object to the server, which +contains the members `jsonrpc`, `method`, `params`, and `id`. + +- `jsonrpc`: A JSON `string` specifying the version of the JSON-RPC protocol. It + is exactly "2.0". + +- `method`: A JSON `string` containing the name of the function to be invoked. + +- `params`: A JSON `array` of values, which represents the parameters of the + function to be invoked. Although the JSON-RPC v2.0 specification allows this + member to be ommitted, in practice all API calls accept at least one parameter. + +- `id`: A JSON `string` or `integer` representing the call id. Note that, + diverging from the JSON-RPC v2.0 specification it cannot be null. Neither can + it be ommitted because the API does not accept _notification_ requests + (requests without responses). + +For example, the body of a JSON-RPC v2.0 request to retrieve the VMs resident on +a host may may look like this: + +```json + { + "jsonrpc": "2.0", + "method": "host.get_resident_VMs", + "params": [ + "OpaqueRef:c90cd28f-37ec-4dbf-88e6-f697ccb28b39", + "OpaqueRef:08c34fc9-f418-4f09-8274-b9cb25cd8550" + ], + "id": 3 + } +``` + +As before, the first element of the `parameter` array is the reference +of the open session to the host, while the second is the host reference. + +#### JSON-RPC v2.0 Return Values + +The return value of a JSON-RPC v2.0 call is a single JSON object containing the +members `jsonrpc`, either `result` or `error` depending on the outcome of the +call, and `id`. + +- `jsonrpc`: A JSON `string` specifying the version of the JSON-RPC protocol. It + is exactly "2.0". + +- `result`: If the call is successful, it is a JSON value (`string`, `array` etc.) + representing the return value of the invoked function. If an error has + occurred, it does not exist. + +- `error`: If the call is successful, it does not exist. If the call has failed, + it is a single structured JSON object (see below). + +- `id`: The call id. It is a JSON `string` or `integer` and it is the same id + as the request it is responding to. + +The `error` object contains the members `code`, `message`, and `data`. + +- `code`: The API does not make use of this member and only retains it for + compliance with the JSON-RPC v2.0 specification. It is a JSON `integer` + which has a non-zero value. + +- `message`: A JSON `string` representing an API error code. + +- `data`: A JSON array of `string` values representing error parameters + relating to the aforementioned API error code. + +For example, a JSON-RPC v2.0 return value from the `host.get_resident_VMs` +function may look like this: + +```json + { + "jsonrpc": "2.0", + "result": [ + "OpaqueRef:604f51e7-630f-4412-83fa-b11c6cf008ab", + "OpaqueRef:670d08f5-cbeb-4336-8420-ccd56390a65f" + ], + "id": 3 + } +``` + +while the return value of the same call made on a logged out session may look +like this: + +```json + { + "jsonrpc": "2.0", + "error": { + "code": 1, + "message": "SESSION_INVALID", + "data": [ + "OpaqueRef:c90cd28f-37ec-4dbf-88e6-f697ccb28b39" + ] + }, + "id": 3 + } +``` + +## Errors + +When a low-level transport error occurs, or a request is malformed at the HTTP +or RPC level, the server may send an HTTP 500 error response, or the client +may simulate the same. The client must be prepared to handle these errors, +though they may be treated as fatal. + +For example, the following malformed request when using the XML-RPC protocol: + +```sh +$curl -D - -X POST https://server -H 'Content-Type: application/xml' \ + -d ' + + session.logout + ' +``` + +results to the following response: + +```sh +HTTP/1.1 500 Internal Error +content-length: 297 +content-type:text/html +connection:close +cache-control:no-cache, no-store + +

HTTP 500 internal server error

An unexpected error occurred; + please wait a while and try again. If the problem persists, please contact your + support representative.

Additional information

Xmlrpc.Parse_error(&quo +t;close_tag", "open_tag", _) +``` + +When using the JSON-RPC protocol: + +```sh +$curl -D - -X POST https://server/jsonrpc -H 'Content-Type: application/json' \ + -d '{ + "jsonrpc": "2.0", + "method": "session.login_with_password", + "id": 0 + }' +``` + +the response is: + +```sh +HTTP/1.1 500 Internal Error +content-length: 308 +content-type:text/html +connection:close +cache-control:no-cache, no-store + +

HTTP 500 internal server error

An unexpected error occurred; + please wait a while and try again. If the problem persists, please contact your + support representative.

Additional information

Jsonrpc.Malformed_metho +d_request("{jsonrpc=...,method=...,id=...}") +``` + +All other failures are reported with a more structured error response, to +allow better automatic response to failures, proper internationalization of +any error message, and easier debugging. + +On the wire, these are transmitted like this when using the XML-RPC protocol: + +```xml + + + Status + Failure + + + ErrorDescription + + + + MAP_DUPLICATE_KEY + Customer + eSpiel Inc. + eSpiel Incorporated + + + + + +``` + +Note that `ErrorDescription` value is an array of string values. The +first element of the array is an error code; the remainder of the array are +strings representing error parameters relating to that code. In this case, +the client has attempted to add the mapping _Customer -> +eSpiel Incorporated_ to a Map, but it already contains the mapping +_Customer -> eSpiel Inc._, hence the request has failed. + +When using the JSON-RPC protocol v2.0, the above error is transmitted as: + +```json +{ + "jsonrpc": "2.0", + "error": { + "code": 1, + "message": "MAP_DUPLICATE_KEY", + "data": [ + "Customer", + "eSpiel Inc.", + "eSpiel Incorporated" + ] + }, + "id": 3 +} +``` + +Finally, when using the JSON-RPC protocol v1.0: + +```json +{ + "result": null, + "error": [ + "MAP_DUPLICATE_KEY", + "Customer", + "eSpiel Inc.", + "eSpiel Incorporated" + ], + "id": "xyz" +} +``` + +Each possible error code is documented in the last section of the API reference. + +## Note on References vs UUIDs + +References are opaque types - encoded as XML-RPC and JSON-RPC strings on the +wire - understood only by the particular server which generated them. Servers +are free to choose any concrete representation they find convenient; clients +should not make any assumptions or attempt to parse the string contents. +References are not guaranteed to be permanent identifiers for objects; clients +should not assume that references generated during one session are valid for any +future session. References do not allow objects to be compared for equality. Two +references to the same object are not guaranteed to be textually identical. + +UUIDs are intended to be permanent identifiers for objects. They are +guaranteed to be in the OSF DCE UUID presentation format (as output by `uuidgen`). +Clients may store UUIDs on disk and use them to look up objects in subsequent sessions +with the server. Clients may also test equality on objects by comparing UUID strings. + +The API provides mechanisms for translating between UUIDs and opaque references. +Each class that contains a UUID field provides: + +- A `get_by_uuid` method that takes a UUID and returns an opaque reference + to the server-side object that has that UUID; + +- A `get_uuid` function (a regular "field getter" RPC) that takes an opaque reference + and returns the UUID of the server-side object that is referenced by it. + +## Making RPC Calls + +### Transport Layer -Next, the user may acquire a list of all the VMs known to the system: -(Note the call takes the session reference as the only parameter) +The following transport layers are currently supported: - >>> all_vms = xen.VM.get_all(session)['Value'] - >>> all_vms - ['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4'] +- HTTP/HTTPS for remote administration +- HTTP over Unix domain sockets for local administration -The VM references here have the form `OpaqueRef:X`, though -they may not be that simple in the future, and you should treat them as -opaque strings. _Templates_ are VMs with the -`is_a_template` field set to `true`. We can find the subset -of template VMs using a command like the following: +### Session Layer - >>> all_templates = filter(lambda x: xen.VM.get_is_a_template(session, x)['Value'], all_vms) +The RPC interface is session-based; before you can make arbitrary RPC calls +you must login and initiate a session. For example: -Once a reference to a VM has been acquired a lifecycle operation may be -invoked: +```python + (session ref) session.login_with_password(string uname, string pwd, + string version, string originator) +``` - >>> xen.VM.start(session, all_templates[0], False, False) - {'Status': 'Failure', 'ErrorDescription': ['VM_IS_TEMPLATE', 'OpaqueRef:X']} +where `uname` and `password` refer to your username and password, as defined by +the Xen administrator, while `version` and `originator` are optional. The +`session ref` returned by `session.login_with_password` is passed +to subequent RPC calls as an authentication token. Note that a session +reference obtained by a login request to the XML-RPC backend can be used in +subsequent requests to the JSON-RPC backend, and vice-versa. -In this case the `start` message has been rejected, because -the VM is a template, and so an error response has been returned. These -high-level errors are returned as structured data (rather than as -XML-RPC faults), allowing them to be internationalised. +A session can be terminated with the `session.logout` function: -Rather than querying fields individually, whole _records_ -may be returned at once. To retrieve the record of a single object as a -python dictionary: +```python + void session.logout(session ref session_id) +``` + +### Synchronous and Asynchronous Invocation + +Each method call (apart from methods on the `Session` and `Task` objects and +"getters" and "setters" derived from fields) can be made either synchronously or +asynchronously. A synchronous RPC call blocks until the +return value is received; the return value of a synchronous RPC call is +exactly as specified above. + +Only synchronous API calls are listed explicitly in this document. +All their asynchronous counterparts are in the special `Async` namespace. +For example, the synchronous call `VM.clone(...)` has an asynchronous +counterpart, `Async.VM.clone(...)`, that is non-blocking. + +Instead of returning its result directly, an asynchronous RPC call +returns an identifier of type `task ref` which is subsequently used +to track the status of a running asynchronous RPC. + +Note that an asychronous call may fail immediately, before a task has even been +created. When using the XML-RPC wire protocol, this eventuality is represented +by wrapping the returned `task ref` in an XML-RPC struct with a `Status`, +`ErrorDescription`, and `Value` fields, exactly as specified above; the +`task ref` is provided in the `Value` field if `Status` is set to `Success`. +When using the JSON-RPC protocol, the `task ref` is wrapped in a response JSON +object as specified above and it is provided by the value of the `result` member +of a successful call. + +The RPC call + +```python + (task ref set) Task.get_all(session ref session_id) +``` + +returns a set of all task identifiers known to the system. The status (including any +returned result and error codes) of these can then be queried by accessing the +fields of the `Task` object in the usual way. Note that, in order to get a +consistent snapshot of a task's state, it is advisable to call the `get_record` +function. + +## Example interactive session + +This section describes how an interactive session might look, using python +XML-RPC and JSON-RPC client libraries. + +First, initialise python: + +```bash +$ python3 +>>> +``` + +### Using the XML-RPC Protocol + +Import the library `xmlrpc.client` and create a +python object referencing the remote server as shown below: + +```python +>>> import xmlrpc.client +>>> xen = xmlrpc.client.ServerProxy("https://localhost:443") +``` + +Note that you may need to disable SSL certificate validation to establish the +connection, this can be done as follows: + +```python +>>> import ssl +>>> ctx = ssl._create_unverified_context() +>>> xen = xmlrpc.client.ServerProxy("https://localhost:443", context=ctx) +``` + +Acquire a session reference by logging in with a username and password; the +session reference is returned under the key `Value` in the resulting dictionary +(error-handling ommitted for brevity): + +```python +>>> session = xen.session.login_with_password("user", "passwd", +... "version", "originator")['Value'] +``` + +This is what the call looks like when serialized + +```xml + + + session.login_with_password + + user + passwd + version + originator + + +``` + +Next, the user may acquire a list of all the VMs known to the system (note the +call takes the session reference as the only parameter): + +```python +>>> all_vms = xen.VM.get_all(session)['Value'] +>>> all_vms +['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] +``` + +The VM references here have the form `OpaqueRef:X` (though they may not be +that simple in reality) and you should treat them as opaque strings. +_Templates_ are VMs with the `is_a_template` field set to `true`. We can +find the subset of template VMs using a command like the following: + +```python +>>> all_templates = filter(lambda x: xen.VM.get_is_a_template(session, x)['Value'], + all_vms) +``` + +Once a reference to a VM has been acquired, a lifecycle operation may be invoked: + +```python +>>> xen.VM.start(session, all_templates[0], False, False) +{'Status': 'Failure', 'ErrorDescription': ['VM_IS_TEMPLATE', 'OpaqueRef:X']} +``` + +In this case the `start` message has been rejected, because the VM is +a template, and so an error response has been returned. These high-level +errors are returned as structured data (rather than as XML-RPC faults), +allowing them to be internationalized. + +Rather than querying fields individually, whole _records_ may be returned at once. +To retrieve the record of a single object as a python dictionary: + +```python +>>> record = xen.VM.get_record(session, all_templates[0])['Value'] +>>> record['power_state'] +'Halted' +>>> record['name_label'] +'Windows 10 (64-bit)' +``` + +To retrieve all the VM records in a single call: - >>> record = xen.VM.get_record(session, all_templates[0])['Value'] - >>> record['power_state'] - 'Halted' - >>> record['name_label'] - 'XenSource P2V Server' +```python +>>> records = xen.VM.get_all_records(session)['Value'] +>>> list(records.keys()) +['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] +>>> records['OpaqueRef:1']['name_label'] +'Red Hat Enterprise Linux 7' +``` + +### Using the JSON-RPC Protocol + +For this example we are making use of the package `jsonrpcclient` and the +`requests` library due to their simplicity, although other packages can also be +used. + +First, import the `requests` and `jsonrpcclient` libraries: + +```python +>>> import requests +>>> import jsonrpcclient +``` + +Now we construct a utility method to make using these libraries easier: + +```python +>>> def jsonrpccall(method, params): +... r = requests.post("https://localhost:443/jsonrpc", +... json=jsonrpcclient.request(method, params=params), +... verify=False) +... p = jsonrpcclient.parse(r.json()) +... if isinstance(p, jsonrpcclient.Ok): +... return p.result +... raise Exception(p.message, p.data) +``` + +Acquire a session reference by logging in with a username and password: + +```python +>>> session = jsonrpccall("session.login_with_password", +... ("user", "password", "version", "originator")) +``` + +`jsonrpcclient` uses the JSON-RPC protocol v2.0, so this is what the serialized +request looks like: + +```json + { + "jsonrpc": "2.0", + "method": "session.login_with_password", + "params": ["user", "passwd", "version", "originator"], + "id": 0 + } +``` + +Next, the user may acquire a list of all the VMs known to the system (note the +call takes the session reference as the only parameter): + +```python +>>> all_vms = jsonrpccall("VM.get_all", (session,)) +>>> all_vms +['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] +``` + +The VM references here have the form `OpaqueRef:X` (though they may not be +that simple in reality) and you should treat them as opaque strings. +_Templates_ are VMs with the `is_a_template` field set to `true`. We can +find the subset of template VMs using a command like the following: + +```python +>>> all_templates = filter( +... lambda x: jsonrpccall("VM.get_is_a_template", (session, x)), +... all_vms) +``` + +Once a reference to a VM has been acquired, a lifecycle operation may be invoked: + +```python +>>> try: +... jsonrpccall("VM.start", (session, next(all_templates), False, False)) +... except Exception as e: +... e +... +Exception('VM_IS_TEMPLATE', ['OpaqueRef:1', 'start']) +``` + +In this case the `start` message has been rejected because the VM is +a template, hence an error response has been returned. These high-level +errors are returned as structured data, allowing them to be internationalized. + +Rather than querying fields individually, whole _records_ may be returned at once. +To retrieve the record of a single object as a python dictionary: + +```python +>>> record = jsonrpccall("VM.get_record", (session, next(all_templates))) +>>> record['power_state'] +'Halted' +>>> record['name_label'] +'Windows 10 (64-bit)' +``` To retrieve all the VM records in a single call: - >>> records = xen.VM.get_all_records(session)['Value'] - >>> records.keys() - ['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] - >>> records['OpaqueRef:1']['name_label'] - 'RHEL 4.1 Autoinstall Template' +```python +>>> records = jsonrpccall("VM.get_all_records", (session,)) +>>> records.keys() +['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] +>>> records['OpaqueRef:1']['name_label'] +'Red Hat Enterprise Linux 7' +``` diff --git a/ocaml/doc/basics.md b/ocaml/doc/basics.md deleted file mode 100644 index 783797051f0..00000000000 --- a/ocaml/doc/basics.md +++ /dev/null @@ -1,119 +0,0 @@ -# API Basics - -This document defines the XenServer Management API - an interface for remotely -configuring and controlling virtualized guests running on a Xen-enabled host. - -The API is presented here as a set of Remote Procedure Calls (RPCs). There are -two supported wire formats, one based upon [XML-RPC](http://xmlrpc.scripting.com/spec.html) -and one based upon [JSON-RPC](http://www.jsonrpc.org) (v1.0 and v2.0 are both -recognized). No specific language bindings are prescribed, although examples -will be given in the python programming language. - -Although we adopt some terminology from object-oriented programming, -future client language bindings may or may not be object oriented. -The API reference uses the terminology _classes_ and _objects_. -For our purposes a _class_ is simply a hierarchical namespace; -an _object_ is an instance of a class with its fields set to -specific values. Objects are persistent and exist on the server-side. -Clients may obtain opaque references to these server-side objects and then -access their fields via get/set RPCs. - -For each class we specify a list of fields along with their _types_ and -_qualifiers_. A qualifier is one of: - -* `RO/runtime`: the field is Read Only. Furthermore, its value is - automatically computed at runtime. For example, current CPU load and disk IO - throughput. - -* `RO/constructor`: the field must be manually set when a new object is - created, but is then Read Only for the duration of the object's life. - For example, the maximum memory addressable by a guest is set - before the guest boots. - -* `RW`: the field is Read/Write. For example, the name of a VM. - -## Types - -The following types are used to specify methods and fields in the API Reference: - -* `string`: Text strings. -* `int`: 64-bit integers. -* `float`: IEEE double-precision floating-point numbers. -* `bool`: Boolean. -* `datetime`: Date and timestamp. -* `c ref`: Reference to an object of class `c`. -* `t set`: Arbitrary-length set of values of type `t`. -* `(k -> v) map`: Mapping from values of type `k` to values of type `v`. -* `e enum`: Enumeration type with name `e`. Enums are defined in the - API reference together with classes that use them. - -Note that there are a number of cases where `ref`s are _doubly linked_. -For example, a `VM` has a field called `VIFs` of type `VIF ref set`; -this field lists the network interfaces attached to a particular VM. -Similarly, the `VIF` class has a field called `VM` of type `VM ref` -which references the VM to which the interface is connected. -These two fields are _bound together_, in the sense that -creating a new VIF causes the `VIFs` field of the corresponding -VM object to be updated automatically. - -The API reference lists explicitly the fields that are -bound together in this way. It also contains a diagram that shows -relationships between classes. In this diagram an edge signifies the -existence of a pair of fields that are bound together, using standard -crows-foot notation to signify the type of relationship (e.g. -one-many, many-many). - -## RPCs associated with fields - -Each field, `f`, has an RPC accessor associated with it that returns `f`'s value: - -* `get_f (r)`: takes a `ref`, `r` that refers to an object and returns the value - of `f`. - -Each field, `f`, with qualifier `RW` and whose outermost type is `set` has the -following additional RPCs associated with it: - -* `add_f(r, v)`: adds a new element `v` to the set. - Note that sets cannot contain duplicate values, hence this operation has - no action in the case that `v` is already in the set. - -* `remove_f(r, v)`: removes element `v` from the set. - -Each field, `f`, with qualifier `RW` and whose outermost type is `map` has the -following additional RPCs associated with it: - -* `add_to_f(r, k, v)`: adds new pair `k -> v` to the mapping stored in `f` in - object`r`. Attempting to add a new pair for duplicate key, `k`, fails with a - `MAP_DUPLICATE_KEY` error. - -* `remove_from_f(r, k)`: removes the pair with key `k` - from the mapping stored in `f` in object `r`. - -Each field whose outermost type is neither `set` nor `map`, but whose -qualifier is `RW` has an RPC accessor associated with it that sets its value: - -* `set_f(r, v)`: sets the field `f` on object `r` to value `v`. - -## RPCs associated with classes - -* Most classes have a _constructor_ RPC named `create` that - takes as parameters all fields marked `RW` and `RO/constructor`. The result - of this RPC is that a new _persistent_ object is created on the server-side - with the specified field values. - -* Each class has a `get_by_uuid(uuid)` RPC that returns the object - of that class that has the specified `uuid`. - -* Each class that has a `name_label` field has a - `get_by_name_label(name_label)` RPC that returns a set of objects of that - class that have the specified `name_label`. - -* Most classes have a `destroy(r)` RPC that explicitly deletes - the persistent object specified by `r` from the system. This is a - non-cascading delete - if the object being removed is referenced by another - object then the `destroy` call will fail. - -Apart from the RPCs enumerated above, some classes have additional RPCs -associated with them. For example, the `VM` class has RPCs for cloning, -suspending, starting etc. Such additional RPCs are described explicitly -in the API reference. diff --git a/ocaml/doc/dune b/ocaml/doc/dune index aa5077ef404..9c4bb6cd474 100644 --- a/ocaml/doc/dune +++ b/ocaml/doc/dune @@ -60,3 +60,13 @@ doc-convert.sh ) ) + +(install + (package xapi) + (section share_root) + (files + (glob_files (../../doc/content/xen-api/basics.md with_prefix markdown)) + (glob_files (../../doc/content/xen-api/wire-protocol.md with_prefix markdown)) + (glob_files (../../doc/content/xen-api/topics/vm-lifecycle.md with_prefix markdown)) + ) +) diff --git a/ocaml/doc/vm-lifecycle.md b/ocaml/doc/vm-lifecycle.md deleted file mode 100644 index 31f31889f36..00000000000 --- a/ocaml/doc/vm-lifecycle.md +++ /dev/null @@ -1,50 +0,0 @@ -# VM Lifecycle - -The following diagram shows the states that a VM can be in -and the API calls that can be used to move the VM between these states. - -![VM lifecycle](vm-lifecycle.png "VM Lifecycle") - -## VM boot parameters - -The `VM` class contains a number of fields that control the way in which the VM -is booted. With reference to the fields defined in the VM class (see later in -this document), this section outlines the boot options available and the -mechanisms provided for controlling them. - -VM booting is controlled by setting one of the two mutually exclusive groups: -"PV" and "HVM". If `HVM.boot_policy` is an empty string, then paravirtual -domain building and booting will be used; otherwise the VM will be loaded as a -HVM domain, and booted using an emulated BIOS. - -When paravirtual booting is in use, the `PV_bootloader` field indicates the -bootloader to use. It may be "pygrub", in which case the platform's default -installation of pygrub will be used, or a full path within the control domain to -some other bootloader. The other fields, `PV_kernel`, `PV_ramdisk`, `PV_args`, -and `PV_bootloader_args` will be passed to the bootloader unmodified, and -interpretation of those fields is then specific to the bootloader itself, -including the possibility that the bootloader will ignore some or all of -those given values. Finally the paths of all bootable disks are added to the -bootloader commandline (a disk is bootable if its VBD has the bootable flag set). -There may be zero, one, or many bootable disks; the bootloader decides which -disk (if any) to boot from. - -If the bootloader is pygrub, then the menu.lst is parsed, if present in the -guest's filesystem, otherwise the specified kernel and ramdisk are used, or an -autodetected kernel is used if nothing is specified and autodetection is -possible. `PV_args` is appended to the kernel command line, no matter which -mechanism is used for finding the kernel. - -If `PV_bootloader` is empty but `PV_kernel` is specified, then the kernel and -ramdisk values will be treated as paths within the control domain. If both -`PV_bootloader` and `PV_kernel` are empty, then the behaviour is as if -`PV_bootloader` were specified as "pygrub". - -When using HVM booting, `HVM_boot_policy` and `HVM_boot_params` specify the boot -handling. Only one policy is currently defined, "BIOS order". In this case, -`HVM_boot_params` should contain one key-value pair "order" = "N" where N is the -string that will be passed to QEMU. -Optionally `HVM_boot_params` can contain another key-value pair "firmware" -with values "bios" or "uefi" (default is "bios" if absent). -By default Secure Boot is not enabled, it can be enabled when "uefi" is enabled by setting -`VM.platform["secureboot"]` to true. diff --git a/ocaml/doc/wire-protocol.md b/ocaml/doc/wire-protocol.md deleted file mode 100644 index 26b911bd2c7..00000000000 --- a/ocaml/doc/wire-protocol.md +++ /dev/null @@ -1,664 +0,0 @@ -# Wire Protocol for Remote API Calls - -API calls are sent over a network to a Xen-enabled host using an RPC protocol. -Here we describe how the higher-level types used in our API Reference are mapped -to primitive RPC types, covering the two supported wire formats -[XML-RPC](http://xmlrpc.scripting.com/spec.html) and [JSON-RPC](http://www.jsonrpc.org). - -## XML-RPC Protocol - -We specify the signatures of API functions in the following style: - -```python -(VM ref set) VM.get_all() -``` - -This specifies that the function with name `VM.get_all` takes -no parameters and returns a `set` of `VM ref`. -These types are mapped onto XML-RPC types in a straight-forward manner: - -* the types `float`, `bool`, `datetime`, and `string` map directly to the XML-RPC - ``, ``, ``, and `` elements. - -* all `ref` types are opaque references, encoded as the - XML-RPC's `` type. Users of the API should not make assumptions - about the concrete form of these strings and should not expect them to - remain valid after the client's session with the server has terminated. - -* fields named `uuid` of type `string` are mapped to - the XML-RPC `` type. The string itself is the OSF - DCE UUID presentation format (as output by `uuidgen`). - -* `int` is assumed to be 64-bit in our API and is encoded as a string - of decimal digits (rather than using XML-RPC's built-in 32-bit `` type). - -* values of `enum` types are encoded as strings. For example, the value - `destroy` of `enum on_normal_exit`, would be conveyed as: - -```xml - destroy -``` - -* for all our types, `t`, our type `t set` simply maps to XML-RPC's `` - type, so, for example, a value of type `string set` would be transmitted like - this: - -```xml - - - CX8 - PSE36 - FPU - - -``` - -* for types `k` and `v`, our type `(k -> v) map` maps onto an - XML-RPC ``, with the key as the name of the struct. Note that the - `(k -> v) map` type is only valid when `k` is a `string`, `ref`, or - `int`, and in each case the keys of the maps are stringified as - above. For example, the `(string -> float) map` containing the mappings - _Mike -> 2.3_ and _John -> 1.2_ would be represented as: - -```xml - - - - Mike - 2.3 - - - John - 1.2 - - - -``` - -* our `void` type is transmitted as an empty string. - -### XML-RPC Return Values and Status Codes - -The return value of an RPC call is an XML-RPC ``. - -* The first element of the struct is named `Status`; it contains a string value - indicating whether the result of the call was a `Success` or a `Failure`. - -If the `Status` is `Success` then the struct contains a second element named -`Value`: - -* The element of the struct named `Value` contains the function's return value. - -If the `Status` is `Failure` then the struct contains a second element named -`ErrorDescription`: - -* The element of the struct named `ErrorDescription` contains an array of string - values. The first element of the array is an error code; the rest of the - elements are strings representing error parameters relating to that code. - -For example, an XML-RPC return value from the `host.get_resident_VMs` function -may look like this: - -```xml - - - Status - Success - - - Value - - - - 81547a35-205c-a551-c577-00b982c5fe00 - 61c85a22-05da-b8a2-2e55-06b0847da503 - 1d401ec4-3c17-35a6-fc79-cee6bd9811fe - - - - - -``` - -## JSON-RPC Protocol - -We specify the signatures of API functions in the following style: - -```python -(VM ref set) VM.get_all() -``` - -This specifies that the function with name `VM.get_all` takes no parameters and -returns a `set` of `VM ref`. These types are mapped onto JSON-RPC types in the -following manner: - -* the types `float` and `bool` map directly to the JSON types `number` and - `boolean`, while `datetime` and `string` are represented as the JSON `string` - type. - -* all `ref` types are opaque references, encoded as the JSON `string` type. - Users of the API should not make assumptions about the concrete form of these - strings and should not expect them to remain valid after the client's session - with the server has terminated. - -* fields named `uuid` of type `string` are mapped to the JSON `string` type. The - string itself is the OSF DCE UUID presentation format (as output by `uuidgen`). - -* `int` is assumed to be 64-bit in our API and is encoded as a JSON `number` - without decimal point or exponent, preserved as a string. - -* values of `enum` types are encoded as the JSON `string` type. For example, the - value `destroy` of `enum on_normal_exit`, would be conveyed as: - -```xml - "destroy" -``` - -* for all our types, `t`, our type `t set` simply maps to the JSON `array` - type, so, for example, a value of type `string set` would be transmitted like - this: - -```json - [ "CX8", "PSE36", "FPU" ] -``` - -* for types `k` and `v`, our type `(k -> v) map` maps onto a JSON object which - contains members with name `k` and value `v`. Note that the - `(k -> v) map` type is only valid when `k` is a `string`, `ref`, or - `int`, and in each case the keys of the maps are stringified as - above. For example, the `(string -> float) map` containing the mappings - _Mike -> 2.3_ and _John -> 1.2_ would be represented as: - -```json - { - "Mike": 2.3, - "John": 1.2 - } -``` - -* our `void` type is transmitted as an empty string. - -Both versions 1.0 and 2.0 of the JSON-RPC wire format are recognized and, -depending on your client library, you can use either of them. - -### JSON-RPC v1.0 - -#### JSON-RPC v1.0 Requests - -An API call is represented by sending a single JSON object to the server, which -contains the members `method`, `params`, and `id`. - -* `method`: A JSON `string` containing the name of the function to be invoked. - -* `params`: A JSON `array` of values, which represents the parameters of the - function to be invoked. - -* `id`: A JSON `string` or `integer` representing the call id. Note that, - diverging from the JSON-RPC v1.0 specification the API does not accept - _notification_ requests (requests without responses), i.e. the id cannot be - `null`. - -For example, a JSON-RPC v1.0 request to retrieve the resident VMs of a host may -look like this: - -```json - { - "method": "host.get_resident_VMs", - "params": [ - "OpaqueRef:74f1a19cd-b660-41e3-a163-10f03e0eae67", - "OpaqueRef:08c34fc9-f418-4f09-8274-b9cb25cd8550" - ], - "id": "xyz" - } -``` - -In the above example, the first element of the `params` array is the reference -of the open session to the host, while the second is the host reference. - -#### JSON-RPC v1.0 Return Values - -The return value of a JSON-RPC v1.0 call is a single JSON object containing -the members `result`, `error`, and `id`. - -* `result`: If the call is successful, it is a JSON value (`string`, `array` - etc.) representing the return value of the invoked function. If an error has - occurred, it is `null`. - -* `error`: If the call is successful, it is `null`. If the call has failed, it - a JSON `array` of `string` values. The first element of the array is an error - code; the remainder of the array are strings representing error parameters - relating to that code. - -* `id`: The call id. It is a JSON `string` or `integer` and it is the same id - as the request it is responding to. - -For example, a JSON-RPC v1.0 return value from the `host.get_resident_VMs` -function may look like this: - -```json - { - "result": [ - "OpaqueRef:604f51e7-630f-4412-83fa-b11c6cf008ab", - "OpaqueRef:670d08f5-cbeb-4336-8420-ccd56390a65f" - ], - "error": null, - "id": "xyz" - } -``` - -while the return value of the same call made on a logged out session may look -like this: - -```json - { - "result": null, - "error": [ - "SESSION_INVALID", - "OpaqueRef:93f1a23cd-a640-41e3-b163-10f86e0eae67" - ], - "id": "xyz" - } -``` - -### JSON-RPC v2.0 - -#### JSON-RPC v2.0 Requests - -An API call is represented by sending a single JSON object to the server, which -contains the members `jsonrpc`, `method`, `params`, and `id`. - -* `jsonrpc`: A JSON `string` specifying the version of the JSON-RPC protocol. It - is exactly "2.0". - -* `method`: A JSON `string` containing the name of the function to be invoked. - -* `params`: A JSON `array` of values, which represents the parameters of the - function to be invoked. Although the JSON-RPC v2.0 specification allows this - member to be ommitted, in practice all API calls accept at least one parameter. - -* `id`: A JSON `string` or `integer` representing the call id. Note that, - diverging from the JSON-RPC v2.0 specification it cannot be null. Neither can - it be ommitted because the API does not accept _notification_ requests - (requests without responses). - -For example, a JSON-RPC v2.0 request to retrieve the VMs resident on a host may -may look like this: - -```json - { - "jsonrpc": "2.0", - "method": "host.get_resident_VMs", - "params": [ - "OpaqueRef:c90cd28f-37ec-4dbf-88e6-f697ccb28b39", - "OpaqueRef:08c34fc9-f418-4f09-8274-b9cb25cd8550" - ], - "id": 3 - } -``` - -As before, the first element of the `parameter` array is the reference -of the open session to the host, while the second is the host reference. - -#### JSON-RPC v2.0 Return Values - -The return value of a JSON-RPC v2.0 call is a single JSON object containing the -members `jsonrpc`, either `result` or `error` depending on the outcome of the -call, and `id`. - -* `jsonrpc`: A JSON `string` specifying the version of the JSON-RPC protocol. It - is exactly "2.0". - -* `result`: If the call is successful, it is a JSON value (`string`, `array` etc.) - representing the return value of the invoked function. If an error has - occurred, it does not exist. - -* `error`: If the call is successful, it does not exist. If the call has failed, - it is a single structured JSON object (see below). - -* `id`: The call id. It is a JSON `string` or `integer` and it is the same id - as the request it is responding to. - -The `error` object contains the members `code`, `message`, and `data`. - -* `code`: The API does not make use of this member and only retains it for - compliance with the JSON-RPC v2.0 specification. It is a JSON `integer` - which has a non-zero value. - -* `message`: A JSON `string` representing an API error code. - -* `data`: A JSON array of `string` values representing error parameters - relating to the aforementioned API error code. - -For example, a JSON-RPC v2.0 return value from the `host.get_resident_VMs` -function may look like this: - -```json - { - "jsonrpc": "2.0", - "result": [ - "OpaqueRef:604f51e7-630f-4412-83fa-b11c6cf008ab", - "OpaqueRef:670d08f5-cbeb-4336-8420-ccd56390a65f" - ], - "id": 3 - } -``` - -while the return value of the same call made on a logged out session may look -like this: - -```json - { - "jsonrpc": "2.0", - "error": { - "code": 1, - "message": "SESSION_INVALID", - "data": [ - "OpaqueRef:c90cd28f-37ec-4dbf-88e6-f697ccb28b39" - ] - }, - "id": 3 - } -``` - -## Note on References vs UUIDs - -References are opaque types - encoded as XML-RPC and JSON-RPC strings on the -wire - understood only by the particular server which generated them. Servers -are free to choose any concrete representation they find convenient; clients -should not make any assumptions or attempt to parse the string contents. -References are not guaranteed to be permanent identifiers for objects; clients -should not assume that references generated during one session are valid for any -future session. References do not allow objects to be compared for equality. Two -references to the same object are not guaranteed to be textually identical. - -UUIDs are intended to be permanent identifiers for objects. They are -guaranteed to be in the OSF DCE UUID presentation format (as output by `uuidgen`). -Clients may store UUIDs on disk and use them to look up objects in subsequent sessions -with the server. Clients may also test equality on objects by comparing UUID strings. - -The API provides mechanisms for translating between UUIDs and opaque references. -Each class that contains a UUID field provides: - -* A `get_by_uuid` method that takes a UUID and returns an opaque reference - to the server-side object that has that UUID; - -* A `get_uuid` function (a regular "field getter" RPC) that takes an opaque reference - and returns the UUID of the server-side object that is referenced by it. - -## Making RPC Calls - -### Transport Layer - -The following transport layers are currently supported: - -* HTTP/HTTPS for remote administration -* HTTP over Unix domain sockets for local administration - -### Session Layer - -The RPC interface is session-based; before you can make arbitrary RPC calls -you must login and initiate a session. For example: - -```python - (session ref) session.login_with_password(string uname, string pwd, - string version, string originator) -``` - -where `uname` and `password` refer to your username and password, as defined by -the Xen administrator, while `version` and `originator` are optional. The -`session ref` returned by `session.login_with_password` is passed -to subequent RPC calls as an authentication token. Note that a session -reference obtained by a login request to the XML-RPC backend can be used in -subsequent requests to the JSON-RPC backend, and vice-versa. - -A session can be terminated with the `session.logout` function: - -```python - void session.logout(session ref session_id) -``` - -### Synchronous and Asynchronous Invocation - -Each method call (apart from methods on the `Session` and `Task` objects and -"getters" and "setters" derived from fields) can be made either synchronously or -asynchronously. A synchronous RPC call blocks until the -return value is received; the return value of a synchronous RPC call is -exactly as specified above. - -Only synchronous API calls are listed explicitly in this document. -All their asynchronous counterparts are in the special `Async` namespace. -For example, the synchronous call `VM.clone(...)` has an asynchronous -counterpart, `Async.VM.clone(...)`, that is non-blocking. - -Instead of returning its result directly, an asynchronous RPC call -returns an identifier of type `task ref` which is subsequently used -to track the status of a running asynchronous RPC. - -Note that an asychronous call may fail immediately, before a task has even been -created. When using the XML-RPC wire protocol, this eventuality is represented -by wrapping the returned `task ref` in an XML-RPC struct with a `Status`, -`ErrorDescription`, and `Value` fields, exactly as specified above; the -`task ref` is provided in the `Value` field if `Status` is set to `Success`. -When using the JSON-RPC protocol, the `task ref` is wrapped in a response JSON -object as specified above and it is provided by the value of the `result` member -of a successful call. - -The RPC call - -```python - (task ref set) Task.get_all(session ref session_id) -``` - -returns a set of all task identifiers known to the system. The status (including any -returned result and error codes) of these can then be queried by accessing the -fields of the `Task` object in the usual way. Note that, in order to get a -consistent snapshot of a task's state, it is advisable to call the `get_record` -function. - -## Example interactive session - -This section describes how an interactive session might look, using python -XML-RPC and JSON-RPC client libraries. - -First, initialise python: - -```bash -$ python3 ->>> -``` - -### Using the XML-RPC Protocol - -Import the library `xmlrpc.client` and create a -python object referencing the remote server as shown below: - -```python ->>> import xmlrpc.client ->>> xen = xmlrpc.client.ServerProxy("https://localhost:443") -``` - -Note that you may need to disable SSL certificate validation to establish the -connection, this can be done as follows: - -```python ->>> import ssl ->>> ctx = ssl._create_unverified_context() ->>> xen = xmlrpc.client.ServerProxy("https://localhost:443", context=ctx) -``` - -Acquire a session reference by logging in with a username and password; the -session reference is returned under the key `Value` in the resulting dictionary -(error-handling ommitted for brevity): - -```python ->>> session = xen.session.login_with_password("user", "passwd", -... "version", "originator")['Value'] -``` - -This is what the call looks like when serialized - -```xml - - - session.login_with_password - - user - passwd - version - originator - - -``` - -Next, the user may acquire a list of all the VMs known to the system (note the -call takes the session reference as the only parameter): - -```python ->>> all_vms = xen.VM.get_all(session)['Value'] ->>> all_vms -['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] -``` - -The VM references here have the form `OpaqueRef:X` (though they may not be -that simple in reality) and you should treat them as opaque strings. -_Templates_ are VMs with the `is_a_template` field set to `true`. We can -find the subset of template VMs using a command like the following: - -```python ->>> all_templates = filter(lambda x: xen.VM.get_is_a_template(session, x)['Value'], - all_vms) -``` - -Once a reference to a VM has been acquired, a lifecycle operation may be invoked: - -```python ->>> xen.VM.start(session, all_templates[0], False, False) -{'Status': 'Failure', 'ErrorDescription': ['VM_IS_TEMPLATE', 'OpaqueRef:X']} -``` - -In this case the `start` message has been rejected, because the VM is -a template, and so an error response has been returned. These high-level -errors are returned as structured data (rather than as XML-RPC faults), -allowing them to be internationalized. - -Rather than querying fields individually, whole _records_ may be returned at once. -To retrieve the record of a single object as a python dictionary: - -```python ->>> record = xen.VM.get_record(session, all_templates[0])['Value'] ->>> record['power_state'] -'Halted' ->>> record['name_label'] -'Windows 10 (64-bit)' -``` - -To retrieve all the VM records in a single call: - -```python ->>> records = xen.VM.get_all_records(session)['Value'] ->>> list(records.keys()) -['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] ->>> records['OpaqueRef:1']['name_label'] -'Red Hat Enterprise Linux 7' -``` - -### Using the JSON-RPC Protocol - -For this example we are making use of the package `jsonrpcclient` and the -`requests` library due to their simplicity, although other packages can also be -used. - -First, import the `requests` and `jsonrpcclient` libraries: - -```python ->>> import requests ->>> import jsonrpcclient -``` - -Now we construct a utility method to make using these libraries easier: - -```python ->>> def jsonrpccall(method, params): -... r = requests.post("https://localhost:443/jsonrpc", -... json=jsonrpcclient.request(method, params=params), -... verify=False) -... p = jsonrpcclient.parse(r.json()) -... if isinstance(p, jsonrpcclient.Ok): -... return p.result -... raise Exception(p.message, p.data) -``` - -Acquire a session reference by logging in with a username and password: - -```python ->>> session = jsonrpccall("session.login_with_password", -... ("user", "password", "version", "originator")) -``` - -`jsonrpcclient` uses the JSON-RPC protocol v2.0, so this is what the serialized -request looks like: - -```json - { - "jsonrpc": "2.0", - "method": "session.login_with_password", - "params": ["user", "passwd", "version", "originator"], - "id": 0 - } -``` - -Next, the user may acquire a list of all the VMs known to the system (note the -call takes the session reference as the only parameter): - -```python ->>> all_vms = jsonrpccall("VM.get_all", (session,)) ->>> all_vms -['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] -``` - -The VM references here have the form `OpaqueRef:X` (though they may not be -that simple in reality) and you should treat them as opaque strings. -_Templates_ are VMs with the `is_a_template` field set to `true`. We can -find the subset of template VMs using a command like the following: - -```python ->>> all_templates = filter( -... lambda x: jsonrpccall("VM.get_is_a_template", (session, x)), -... all_vms) -``` - -Once a reference to a VM has been acquired, a lifecycle operation may be invoked: - -```python ->>> try: -... jsonrpccall("VM.start", (session, next(all_templates), False, False)) -... except Exception as e: -... e -... -Exception('VM_IS_TEMPLATE', ['OpaqueRef:1', 'start']) -``` - -In this case the `start` message has been rejected because the VM is -a template, hence an error response has been returned. These high-level -errors are returned as structured data, allowing them to be internationalized. - -Rather than querying fields individually, whole _records_ may be returned at once. -To retrieve the record of a single object as a python dictionary: - -```python ->>> record = jsonrpccall("VM.get_record", (session, next(all_templates))) ->>> record['power_state'] -'Halted' ->>> record['name_label'] -'Windows 10 (64-bit)' -``` - -To retrieve all the VM records in a single call: - -```python ->>> records = jsonrpccall("VM.get_all_records", (session,)) ->>> records.keys() -['OpaqueRef:1', 'OpaqueRef:2', 'OpaqueRef:3', 'OpaqueRef:4' ] ->>> records['OpaqueRef:1']['name_label'] -'Red Hat Enterprise Linux 7' -``` diff --git a/ocaml/idl/templates/api_errors.mustache b/ocaml/idl/templates/api_errors.mustache index 384a737d9a2..3bc2cd44a00 100644 --- a/ocaml/idl/templates/api_errors.mustache +++ b/ocaml/idl/templates/api_errors.mustache @@ -1,135 +1,9 @@ -# Error Handling +# Error Codes -When a low-level transport error occurs, or a request is malformed at the HTTP -or RPC level, the server may send an HTTP 500 error response, or the client -may simulate the same. The client must be prepared to handle these errors, -though they may be treated as fatal. - -For example, the following malformed request when using the XML-RPC protocol: - -```sh -$curl -D - -X POST https://server -H 'Content-Type: application/xml' \ -> -d ' -> -> session.logout -> ' -``` - -results to the following response: - -```sh -HTTP/1.1 500 Internal Error -content-length: 297 -content-type:text/html -connection:close -cache-control:no-cache, no-store - -

HTTP 500 internal server error

An unexpected error occurred; - please wait a while and try again. If the problem persists, please contact your - support representative.

Additional information

Xmlrpc.Parse_error(&quo -t;close_tag", "open_tag", _) -``` - -When using the JSON-RPC protocol: - -```sh -$curl -D - -X POST https://server/jsonrpc -H 'Content-Type: application/json' \ -> -d '{ -> "jsonrpc": "2.0", -> "method": "session.login_with_password", -> "id": 0 -> }' -``` - -the response is: - -```sh -HTTP/1.1 500 Internal Error -content-length: 308 -content-type:text/html -connection:close -cache-control:no-cache, no-store - -

HTTP 500 internal server error

An unexpected error occurred; - please wait a while and try again. If the problem persists, please contact your - support representative.

Additional information

Jsonrpc.Malformed_metho -d_request("{jsonrpc=...,method=...,id=...}") -``` - -All other failures are reported with a more structured error response, to -allow better automatic response to failures, proper internationalization of -any error message, and easier debugging. - -On the wire, these are transmitted like this when using the XML-RPC protocol: - -```xml - - - Status - Failure - - - ErrorDescription - - - - MAP_DUPLICATE_KEY - Customer - eSpiel Inc. - eSpiel Incorporated - - - - - -``` - -Note that `ErrorDescription` value is an array of string values. The -first element of the array is an error code; the remainder of the array are -strings representing error parameters relating to that code. In this case, -the client has attempted to add the mapping _Customer -> -eSpiel Incorporated_ to a Map, but it already contains the mapping -_Customer -> eSpiel Inc._, hence the request has failed. - -When using the JSON-RPC protocol v2.0, the above error is transmitted as: - -```json -{ - "jsonrpc": "2.0", - "error": { - "code": 1, - "message": "MAP_DUPLICATE_KEY", - "data": [ - "Customer", - "eSpiel Inc.", - "eSpiel Incorporated" - ] - }, - "id": 3 -} -``` - -Finally, when using the JSON-RPC protocol v1.0: - -```json -{ - "result": null, - "error": [ - "MAP_DUPLICATE_KEY", - "Customer", - "eSpiel Inc.", - "eSpiel Incorporated" - ], - "id": "xyz" -} -``` - -Each possible error code is documented in the following section. - -## Error Codes +The following is a list of all possible errors that can be issued by API calls. {{#errors}} -### {{{error_code}}} +## {{{error_code}}} {{{error_description}}} diff --git a/ocaml/idl/templates/toc.mustache b/ocaml/idl/templates/toc.mustache index 126bf2922e6..eca5b54db8b 100644 --- a/ocaml/idl/templates/toc.mustache +++ b/ocaml/idl/templates/toc.mustache @@ -11,5 +11,5 @@ - title: "Class: {{{name}}}" url: @root@management-api/class-{{{name_lower}}}.html {{/classes}} - - title: Error Handling + - title: Error Codes url: @root@management-api/api-errors.html From 785f1b9aa2e21af8ae980048a1edfff14a2b6e20 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 7 Jul 2023 14:57:50 +0000 Subject: [PATCH 14/73] Add VM_metrics to metadata export This includes the current_domain_type field, which is important for live imports, including those during a cross-pool live migration. Signed-off-by: Rob Hoes --- ocaml/xapi/export.ml | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index a81ec647225..f14b7551885 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -140,7 +140,8 @@ let rec update_table ~__context ~include_snapshots ~preserve_power_state && Db.is_valid_ref __context vdi then add_vdi vdi ; - (* Add also the guest metrics *) + (* Add also the metrics and guest metrics *) + add vm.API.vM_metrics ; add vm.API.vM_guest_metrics ; (* Add the hosts links *) add vm.API.vM_resident_on ; @@ -264,7 +265,7 @@ let make_vm ?(with_snapshot_metadata = false) ~preserve_power_state table ; API.vM_resident_on= lookup table (Ref.string_of vm.API.vM_resident_on) ; API.vM_affinity= lookup table (Ref.string_of vm.API.vM_affinity) ; API.vM_consoles= [] - ; API.vM_metrics= Ref.null + ; API.vM_metrics= lookup table (Ref.string_of vm.API.vM_metrics) ; API.vM_guest_metrics= lookup table (Ref.string_of vm.API.vM_guest_metrics) ; API.vM_protection_policy= Ref.null ; API.vM_bios_strings= vm.API.vM_bios_strings @@ -277,6 +278,15 @@ let make_vm ?(with_snapshot_metadata = false) ~preserve_power_state table ; snapshot= API.rpc_of_vM_t vm } +(** Convert a VM metrics reference to an obj *) +let make_vmm table __context self = + let vmm = Db.VM_metrics.get_record ~__context ~self in + { + cls= Datamodel_common._vm_metrics + ; id= Ref.string_of (lookup table (Ref.string_of self)) + ; snapshot= API.rpc_of_vM_metrics_t vmm + } + (** Convert a guest-metrics reference to an obj *) let make_gm table __context self = let gm = Db.VM_guest_metrics.get_record ~__context ~self in @@ -506,6 +516,10 @@ let make_all ~with_snapshot_metadata ~preserve_power_state table __context = (make_vm ~with_snapshot_metadata ~preserve_power_state table __context) (filter table (Db.VM.get_all ~__context)) in + let vmms = + List.map (make_vmm table __context) + (filter table (Db.VM_metrics.get_all ~__context)) + in let gms = List.map (make_gm table __context) (filter table (Db.VM_guest_metrics.get_all ~__context)) @@ -566,6 +580,7 @@ let make_all ~with_snapshot_metadata ~preserve_power_state table __context = [ hosts ; vms + ; vmms ; gms ; vbds ; vifs From 077e8d11e3c000530c4c97a9f25aedd1463d3c8a Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 13 Jul 2023 15:46:19 +0000 Subject: [PATCH 15/73] Add VM_metrics to metadata import Signed-off-by: Rob Hoes --- ocaml/xapi/import.ml | 45 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index a1aaa306f53..edc39a7673c 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -730,6 +730,15 @@ module VM : HandlerTools = struct then Db.VM.set_suspend_SR ~__context ~self:vm ~value:Ref.null ; Db.VM.set_parent ~__context ~self:vm ~value:vm_record.API.vM_parent ; + ( try + let vmm = lookup vm_record.API.vM_metrics state.table in + (* We have VM_metrics in the imported metadata, so use it, and destroy + the record created by VM.create_from_record above. *) + let replaced_vmm = Db.VM.get_metrics ~__context ~self:vm in + Db.VM.set_metrics ~__context ~self:vm ~value:vmm ; + Db.VM_metrics.destroy ~__context ~self:replaced_vmm + with _ -> () + ) ; ( try let gm = lookup vm_record.API.vM_guest_metrics state.table in Db.VM.set_guest_metrics ~__context ~self:vm ~value:gm @@ -805,6 +814,40 @@ module GuestMetrics : HandlerTools = struct state.table <- (x.cls, x.id, Ref.string_of gm) :: state.table end +(** Create the VM metrics *) +module Metrics : HandlerTools = struct + type precheck_t = OK + + let precheck __context _config _rpc _session_id _state _x = OK + + let handle_dry_run __context _config _rpc _session_id state x _precheck_result + = + let dummy_gm = Ref.make () in + state.table <- (x.cls, x.id, Ref.string_of dummy_gm) :: state.table + + let handle __context _config _rpc _session_id state x _precheck_result = + let vmm_record = API.vM_metrics_t_of_rpc x.snapshot in + let vmm = Ref.make () in + Db.VM_metrics.create ~__context ~ref:vmm + ~uuid:(Uuidx.to_string (Uuidx.make ())) + ~memory_actual:vmm_record.API.vM_metrics_memory_actual + ~vCPUs_number:vmm_record.API.vM_metrics_VCPUs_number + ~vCPUs_utilisation:vmm_record.API.vM_metrics_VCPUs_utilisation + ~vCPUs_CPU:vmm_record.API.vM_metrics_VCPUs_CPU + ~vCPUs_params:vmm_record.API.vM_metrics_VCPUs_params + ~vCPUs_flags:vmm_record.API.vM_metrics_VCPUs_flags + ~state:vmm_record.API.vM_metrics_state + ~start_time:vmm_record.API.vM_metrics_start_time + ~install_time:vmm_record.API.vM_metrics_install_time + ~last_updated:vmm_record.API.vM_metrics_last_updated + ~other_config:vmm_record.API.vM_metrics_other_config + ~hvm:vmm_record.API.vM_metrics_hvm + ~nested_virt:vmm_record.API.vM_metrics_nested_virt + ~nomigrate:vmm_record.API.vM_metrics_nomigrate + ~current_domain_type:vmm_record.API.vM_metrics_current_domain_type ; + state.table <- (x.cls, x.id, Ref.string_of vmm) :: state.table +end + (** If we're restoring VM metadata only then lookup the SR by uuid. If we can't find the SR then we will still try to match VDIs later (except CDROMs) *) module SR : HandlerTools = struct @@ -1910,6 +1953,7 @@ module HostHandler = MakeHandler (Host) module SRHandler = MakeHandler (SR) module VDIHandler = MakeHandler (VDI) module GuestMetricsHandler = MakeHandler (GuestMetrics) +module MetricsHandler = MakeHandler (Metrics) module VMHandler = MakeHandler (VM) module NetworkHandler = MakeHandler (Net) module GPUGroupHandler = MakeHandler (GPUGroup) @@ -1928,6 +1972,7 @@ let handlers = ; (Datamodel_common._sr, SRHandler.handle) ; (Datamodel_common._vdi, VDIHandler.handle) ; (Datamodel_common._vm_guest_metrics, GuestMetricsHandler.handle) + ; (Datamodel_common._vm_metrics, MetricsHandler.handle) ; (Datamodel_common._vm, VMHandler.handle) ; (Datamodel_common._network, NetworkHandler.handle) ; (Datamodel_common._gpu_group, GPUGroupHandler.handle) From 33b6315fa885f070409258ef83da8e4ae182903e Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 7 Jul 2023 14:24:15 +0000 Subject: [PATCH 16/73] Cross-pool live migration: move CPU check to the target host The target host of a live migration is running by definition the same or a newer version of the software compared to the source host. As CPU checks are often extended or even changed in software updates, it is best to perform such checks on the target host. However, currently it is the source host that does these checks. This patch moves the check to the target host. A cross-pool live migration always begins with a dry-run VM-metadata import on the target host. This is where checks for free memory and GPU capacity are already carried out. The metadata import handler is extended to accept a `check_cpu` query parameter to signal that a CPU check is needed. This is included in the import call done in `assert_can_migrate` on the source host, and the old CPU check in there is dropped. Source hosts without this patch will still perform the CPU checks themselves, so we do not compromise safety. NOTE: This is a rebase of the initial work from 07a2a71b6b40 that had to be reverted with Ming's suggestion to skip CPUID check on 'unspecified' snapshots implemented. Signed-off-by: Rob Hoes --- ocaml/xapi/cpuid_helpers.ml | 38 ++++++++++++++++++++--------- ocaml/xapi/cpuid_helpers.mli | 8 +++---- ocaml/xapi/import.ml | 41 ++++++++++++++++++++++++++++---- ocaml/xapi/importexport.ml | 4 +++- ocaml/xapi/message_forwarding.ml | 2 +- ocaml/xapi/xapi_dr.ml | 1 + ocaml/xapi/xapi_vm.ml | 2 +- ocaml/xapi/xapi_vm_helpers.ml | 4 ++-- ocaml/xapi/xapi_vm_migrate.ml | 15 ++++++------ 9 files changed, 82 insertions(+), 33 deletions(-) diff --git a/ocaml/xapi/cpuid_helpers.ml b/ocaml/xapi/cpuid_helpers.ml index 571a7f073b6..1bf6731efad 100644 --- a/ocaml/xapi/cpuid_helpers.ml +++ b/ocaml/xapi/cpuid_helpers.ml @@ -47,9 +47,9 @@ let threads_per_core = Map_check.(field "threads_per_core" int) let vendor = Map_check.(field "vendor" string) -let get_flags_for_vm ~__context vm cpu_info = +let get_flags_for_vm ~__context domain_type cpu_info = let features_field = - match Helpers.domain_type ~__context ~self:vm with + match domain_type with | `hvm | `pv_in_pvh | `pvh -> features_hvm | `pv -> @@ -79,36 +79,51 @@ let next_boot_cpu_features ~__context ~vm = Map_check.getf features_field_boot pool_cpu_info |> Xenops_interface.CPU_policy.to_string -let get_host_cpu_info ~__context ~vm:_ ~host ?remote () = +let get_host_cpu_info ~__context ~host ?remote () = match remote with | None -> Db.Host.get_cpu_info ~__context ~self:host | Some (rpc, session_id) -> Client.Client.Host.get_cpu_info ~rpc ~session_id ~self:host -let get_host_compatibility_info ~__context ~vm ~host ?remote () = - get_host_cpu_info ~__context ~vm ~host ?remote () - |> get_flags_for_vm ~__context vm +let get_host_compatibility_info ~__context ~domain_type ~host ?remote () = + get_host_cpu_info ~__context ~host ?remote () + |> get_flags_for_vm ~__context domain_type (* Compare the CPU on which the given VM was last booted to the CPU of the given host. *) -let assert_vm_is_compatible ~__context ~vm ~host ?remote () = +let assert_vm_is_compatible ~__context ~vm ~host = + let vm_ref, vm_rec, domain_type = + match vm with + | `db self -> + ( self + , Db.VM.get_record ~__context ~self + , Helpers.domain_type ~__context ~self + ) + | `import (vm_rec, dt) -> + (* Ref.null, because the VM to be imported does not yet have a ref *) + (Ref.null, vm_rec, Helpers.check_domain_type dt) + in let fail msg = raise (Api_errors.Server_error ( Api_errors.vm_incompatible_with_this_host - , [Ref.string_of vm; Ref.string_of host; msg] + , [Ref.string_of vm_ref; Ref.string_of host; msg] ) ) in - if Db.VM.get_power_state ~__context ~self:vm <> `Halted then + if vm_rec.API.vM_power_state <> `Halted then ( + let host_uuid = Db.Host.get_uuid ~__context ~self:host in + debug "Checking CPU compatibility of %s VM %s with host %s" + (Record_util.domain_type_to_string domain_type) + vm_rec.API.vM_uuid host_uuid ; let open Xapi_xenops_queue in let module Xenopsd = (val make_client (default_xenopsd ()) : XENOPS) in let dbg = Context.string_of_task __context in try let host_cpu_vendor, host_cpu_features = - get_host_compatibility_info ~__context ~vm ~host ?remote () + get_host_compatibility_info ~__context ~domain_type ~host () in - let vm_cpu_info = Db.VM.get_last_boot_CPU_flags ~__context ~self:vm in + let vm_cpu_info = vm_rec.API.vM_last_boot_CPU_flags in if List.mem_assoc cpu_info_vendor_key vm_cpu_info then ( (* Check the VM was last booted on a CPU with the same vendor as this host's CPU. *) let vm_cpu_vendor = List.assoc cpu_info_vendor_key vm_cpu_info in @@ -141,3 +156,4 @@ let assert_vm_is_compatible ~__context ~vm ~host ?remote () = fail "Host does not have new leveling feature keys - not comparing VM's \ flags" + ) diff --git a/ocaml/xapi/cpuid_helpers.mli b/ocaml/xapi/cpuid_helpers.mli index 4d5f091d7f6..ff672b884a2 100644 --- a/ocaml/xapi/cpuid_helpers.mli +++ b/ocaml/xapi/cpuid_helpers.mli @@ -16,11 +16,12 @@ val next_boot_cpu_features : __context:Context.t -> vm:[`VM] API.Ref.t -> string val assert_vm_is_compatible : __context:Context.t - -> vm:[`VM] API.Ref.t + -> vm:[`db of [`VM] API.Ref.t | `import of API.vM_t * API.domain_type] -> host:[`host] API.Ref.t - -> ?remote:(Rpc.call -> Rpc.response Client.Id.t) * [< `session] Ref.t - -> unit -> unit +(** Checks whether the CPU vendor and features used by the VM are compatible + with the given host. The VM can be one that is currently in the DB, or a record + coming from a metadata import as used for cross-pool migration. *) val vendor : string Map_check.field @@ -42,7 +43,6 @@ val features_hvm_host : [`host] Xenops_interface.CPU_policy.t Map_check.field val get_host_cpu_info : __context:Context.t - -> vm:[`VM] API.Ref.t -> host:[`host] API.Ref.t -> ?remote:(Rpc.call -> Rpc.response Client.Id.t) * [< `session] Ref.t -> unit diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index edc39a7673c..2a9d37b7972 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -50,6 +50,7 @@ type metadata_options = { * - If the migration is for real, we will expect the VM export code on the source host to have mapped the VDI locations onto their * mirrored counterparts which are present on this host. *) live: bool + ; check_cpu: bool ; (* An optional src VDI -> destination VDI rewrite list *) vdi_map: (string * string) list } @@ -75,6 +76,13 @@ type config = { let is_live config = match config.import_type with Metadata_import {live; _} -> live | _ -> false +let needs_cpu_check config = + match config.import_type with + | Metadata_import {check_cpu; _} -> + check_cpu + | _ -> + false + (** List of (datamodel classname * Reference in export * Reference in database) *) type table = (string * string * string) list @@ -253,8 +261,8 @@ let assert_can_restore_backup ~__context rpc session_id (x : header) = import_vms let assert_can_live_import __context vm_record = + let host = Helpers.get_localhost ~__context in let assert_memory_available () = - let host = Helpers.get_localhost ~__context in let host_mem_available = Memory_check.host_compute_free_memory_with_maximum_compression ~__context ~host None @@ -416,7 +424,7 @@ module VM : HandlerTools = struct | Skip | Clean_import of API.vM_t - let precheck __context config _rpc _session_id _state x = + let precheck __context config _rpc _session_id state x = let vm_record = get_vm_record x.snapshot in let is_default_template = vm_record.API.vM_is_default_template @@ -511,6 +519,28 @@ module VM : HandlerTools = struct | Replace (_, vm_record) | Clean_import vm_record -> if is_live config then assert_can_live_import __context vm_record ; + ( if needs_cpu_check config then + let vmm_record = + find_in_export + (Ref.string_of vm_record.API.vM_metrics) + state.export + |> API.vM_metrics_t_of_rpc + in + let host = Helpers.get_localhost ~__context in + (* Don't check CPUID on 'unspecified' snapshots *) + match + ( vm_record.API.vM_is_a_snapshot + , vmm_record.API.vM_metrics_current_domain_type + ) + with + | true, `unspecified -> + (* A snapshot which was taken from a shutdown VM. *) + () + | _, dt -> + Cpuid_helpers.assert_vm_is_compatible ~__context + ~vm:(`import (vm_record, dt)) + ~host + ) ; import_action | _ -> import_action @@ -2310,13 +2340,14 @@ let metadata_handler (req : Request.t) s _ = let force = find_query_flag req.Request.query "force" in let dry_run = find_query_flag req.Request.query "dry_run" in let live = find_query_flag req.Request.query "live" in + let check_cpu = find_query_flag req.Request.query "check_cpu" in let vdi_map = read_map_params "vdi" req.Request.query in info "VM.import_metadata: force = %b; full_restore = %b dry_run = %b; \ - live = %b; vdi_map = [ %s ]" - force full_restore dry_run live + live = %b; check_cpu = %b; vdi_map = [ %s ]" + force full_restore dry_run live check_cpu (String.concat "; " (List.map (fun (a, b) -> a ^ "=" ^ b) vdi_map)) ; - let metadata_options = {dry_run; live; vdi_map} in + let metadata_options = {dry_run; live; vdi_map; check_cpu} in let config = {import_type= Metadata_import metadata_options; full_restore; force} in diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index b6f784dc55c..a210bda04d6 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -249,6 +249,7 @@ type vm_export_import = { ; dry_run: bool ; live: bool ; send_snapshots: bool + ; check_cpu: bool } (* Copy VM metadata to a remote pool *) @@ -269,11 +270,12 @@ let remote_metadata_export_import ~__context ~rpc ~session_id ~remote_address match which with | `All -> [] - | `Only {live; dry_run; send_snapshots; _} -> + | `Only {live; dry_run; send_snapshots; check_cpu; _} -> [ Printf.sprintf "live=%b" live ; Printf.sprintf "dry_run=%b" dry_run ; Printf.sprintf "export_snapshots=%b" send_snapshots + ; Printf.sprintf "check_cpu=%b" check_cpu ] in let params = Printf.sprintf "restore=%b" restore :: params in diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 6423e8d7be3..63b27076a1a 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -2473,7 +2473,7 @@ functor try bool_of_string (List.assoc "force" options) with _ -> false in if not force then - Cpuid_helpers.assert_vm_is_compatible ~__context ~vm ~host () ; + Cpuid_helpers.assert_vm_is_compatible ~__context ~vm:(`db vm) ~host ; let source_host = Db.VM.get_resident_on ~__context ~self:vm in with_vm_operation ~__context ~self:vm ~doc:"VM.pool_migrate" ~op:`pool_migrate ~strict:(not force) (fun () -> diff --git a/ocaml/xapi/xapi_dr.ml b/ocaml/xapi/xapi_dr.ml index dfe563ec204..3c87d848263 100644 --- a/ocaml/xapi/xapi_dr.ml +++ b/ocaml/xapi/xapi_dr.ml @@ -279,6 +279,7 @@ let recover_vms ~__context ~vms ~session_to ~force = { Import.dry_run= false ; Import.live= false + ; check_cpu= false ; vdi_map= [] (* we expect the VDI metadata to be present *) } in diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 3acd99a763e..d45afa4282c 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -566,7 +566,7 @@ let resume ~__context ~vm ~start_paused ~force = ) ; let host = Helpers.get_localhost ~__context in if not force then - Cpuid_helpers.assert_vm_is_compatible ~__context ~vm ~host () ; + Cpuid_helpers.assert_vm_is_compatible ~__context ~vm:(`db vm) ~host ; (* Update CPU feature set, which will be passed to xenopsd *) Xapi_xenops.resume ~__context ~self:vm ~start_paused ~force diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index b7596bfbc67..d7f36c8f4de 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -628,7 +628,7 @@ let assert_matches_control_domain_affinity ~__context ~self ~host = let assert_enough_pcpus ~__context ~self ~host ?remote () = let vcpus = Db.VM.get_VCPUs_max ~__context ~self in let pcpus = - Cpuid_helpers.get_host_cpu_info ~__context ~vm:self ~host ?remote () + Cpuid_helpers.get_host_cpu_info ~__context ~host ?remote () |> Map_check.getf Cpuid_helpers.cpu_count |> Int64.of_int in @@ -699,7 +699,7 @@ let assert_can_boot_here ~__context ~self ~host ~snapshot ~do_cpuid_check assert_hardware_platform_support ~__context ~vm:self ~host:(Helpers.LocalObject host) ; if do_cpuid_check then - Cpuid_helpers.assert_vm_is_compatible ~__context ~vm:self ~host () ; + Cpuid_helpers.assert_vm_is_compatible ~__context ~vm:(`db self) ~host ; if do_sr_check then assert_can_see_SRs ~__context ~self ~host ; assert_can_see_networks ~__context ~self ~host ; diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 4ac14efa270..397243a54e5 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -581,7 +581,7 @@ let intra_pool_vdi_remap ~__context vm vdi_map = vdis_and_callbacks let inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map - ~vgpu_map ~dry_run ~live ~copy = + ~vgpu_map ~dry_run ~live ~copy ~check_cpu = List.iter (fun vdi_record -> let vdi = vdi_record.local_vdi_reference in @@ -617,7 +617,7 @@ let inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map ) vgpu_map ; let vm_export_import = - {Importexport.vm; dry_run; live; send_snapshots= not copy} + {Importexport.vm; dry_run; live; send_snapshots= not copy; check_cpu} in finally (fun () -> @@ -1176,6 +1176,9 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map let remote = remote_of_dest ~__context dest in (* Copy mode means we don't destroy the VM on the source host. We also don't copy over the RRDs/messages *) + let force = + try bool_of_string (List.assoc "force" options) with _ -> false + in let copy = try bool_of_string (List.assoc "copy" options) with _ -> false in let compress = use_compression ~__context options localhost remote.dest_host @@ -1463,6 +1466,7 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map in inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map ~vgpu_map ~dry_run:false ~live:true ~copy + ~check_cpu:(not force) in let vm = List.hd vms in let () = @@ -1818,12 +1822,6 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options (Api_errors.Server_error (Api_errors.host_disabled, [Ref.string_of remote.dest_host]) ) ; - (* Check that the VM's required CPU features are available on the host *) - if not force then - Cpuid_helpers.assert_vm_is_compatible ~__context ~vm - ~host:remote.dest_host - ~remote:(remote.rpc, remote.session) - () ; (* Check that the destination has enough pCPUs *) Xapi_vm_helpers.assert_enough_pcpus ~__context ~self:vm ~host:remote.dest_host @@ -1865,6 +1863,7 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options not (inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map ~vgpu_map ~dry_run:true ~live:true ~copy + ~check_cpu:(not force) = [] ) then From b0f93fc3e3045d2c2f7acce5904dbe95145b99cc Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Thu, 27 Jul 2023 11:19:03 +0000 Subject: [PATCH 17/73] CA-380580: cross-pool migration: no CPU checks for halted VMs CPU checks are needed only for running VMs that are being migrated, to check for compatibility with the remote-host's CPUs. NOTE: This is the rebase of the initial work from 3d039f3259a3 that had to be reverted with the fix from df7cbfddffe4 incorporated. Signed-off-by: Rob Hoes --- ocaml/xapi/xapi_vm_migrate.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 397243a54e5..3b561e370ab 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -1194,6 +1194,7 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map We look at the VDIs of the VM, the VDIs of all of the snapshots, and any suspend-image VDIs. *) let vm_uuid = Db.VM.get_uuid ~__context ~self:vm in + let power_state = Db.VM.get_power_state ~__context ~self:vm in let vbds = Db.VM.get_VBDs ~__context ~self:vm in let vifs = Db.VM.get_VIFs ~__context ~self:vm in let snapshots = Db.VM.get_snapshots ~__context ~self:vm in @@ -1249,9 +1250,10 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map in let suspends_vdis = List.fold_left - (fun acc vm -> - if Db.VM.get_power_state ~__context ~self:vm = `Suspended then - let vdi = Db.VM.get_suspend_VDI ~__context ~self:vm in + (fun acc vm_or_snapshot -> + if Db.VM.get_power_state ~__context ~self:vm_or_snapshot = `Suspended + then + let vdi = Db.VM.get_suspend_VDI ~__context ~self:vm_or_snapshot in let sr = Db.VDI.get_SR ~__context ~self:vdi in if is_intra_pool @@ -1259,7 +1261,7 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map then acc else - get_vdi_mirror __context vm vdi false :: acc + get_vdi_mirror __context vm_or_snapshot vdi false :: acc else acc ) @@ -1466,7 +1468,7 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map in inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map ~vgpu_map ~dry_run:false ~live:true ~copy - ~check_cpu:(not force) + ~check_cpu:((not force) && power_state <> `Halted) in let vm = List.hd vms in let () = @@ -1863,7 +1865,7 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options not (inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map ~vgpu_map ~dry_run:true ~live:true ~copy - ~check_cpu:(not force) + ~check_cpu:((not force) && power_state <> `Halted) = [] ) then From a540ac83579381583438df85d6c54ee38b866de8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 12 Dec 2024 10:29:21 +0000 Subject: [PATCH 18/73] CA-403633: Keep vPCI devices in the same order QEMU orders devices by the time of plugging. Parallelizing them introduces randomness, which breaks the assumption that devices are ordered in a deterministic way. Serialize all PCI and VUSB plugs to restore behaviour. Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/lib/xenops_server.ml | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index e5d8016bedb..f4c784faa11 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -1630,12 +1630,11 @@ let rec atomics_of_operation = function ] ; [VM_create_device_model (id, false)] (* PCI and USB devices are hot-plugged into HVM guests via QEMU, so the - following operations occur after creating the device models *) - ; parallel_concat "Devices.plug (qemu)" ~id - [ - List.map (fun pci -> PCI_plug (pci.Pci.id, true)) pcis_other - ; List.map (fun vusb -> VUSB_plug vusb.Vusb.id) vusbs - ] + following operations occur after creating the device models. + The order of PCI devices depends on the order they are plugged, they + must be kept serialized. *) + ; List.map (fun pci -> PCI_plug (pci.Pci.id, true)) pcis_other + ; List.map (fun vusb -> VUSB_plug vusb.Vusb.id) vusbs (* At this point the domain is considered survivable. *) ; [VM_set_domain_action_request (id, None)] ] @@ -1698,10 +1697,10 @@ let rec atomics_of_operation = function ) ; [VM_create_device_model (id, true)] (* PCI and USB devices are hot-plugged into HVM guests via QEMU, so - the following operations occur after creating the device models *) - ; parallel_map "PCIs.plug" ~id pcis_other (fun pci -> - [PCI_plug (pci.Pci.id, true)] - ) + the following operations occur after creating the device models. + The order of PCI devices depends on the order they are plugged, they + must be kept serialized. *) + ; List.map (fun pci -> PCI_plug (pci.Pci.id, true)) pcis_other ] |> List.concat | VM_poweroff (id, timeout) -> From 6f6cd81bf8b7508162de6e641e72737126020873 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Mon, 16 Dec 2024 16:46:35 +0800 Subject: [PATCH 19/73] CA-403767: verifyPeer can't use root CA for appliance cert check It is expected to use root CA certficate to verify an appliance's server certificate for a xapi outgoing TLS connection. Prior to this change, the related stunnel configurations are: "verifyPeer=yes", and "checkHost=". The 'verifyPeer' option of stunnel doesn't treat the CA bundle as root CA certificates. The 'checkHost' option of stunnel only checks the host name against the one in server certificate. In other words, the issue is that the root CA based checking doesn't work for appliance. This change adds 'verifyChain' for the appliance to ensure the outgoing TLS connection from xapi will verify the appliance's server certificates by real root CA certificate. Signed-off-by: Ming Lu --- ocaml/libs/stunnel/stunnel.ml | 40 +++++++++++++++++------------------ 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 8d319b4b80d..6b7d42608e7 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -218,29 +218,29 @@ let config_file ?(accept = None) config host port = | None -> [] | Some {sni; verify; cert_bundle_path} -> - [ - "" - ; "# use SNI to request a specific cert. CAfile contains" - ; "# public certs of all hosts in the pool and must contain" - ; "# the cert of the server we connect to" - ; (match sni with None -> "" | Some s -> sprintf "sni = %s" s) - ; ( match verify with + List.rev_append + ( match verify with | VerifyPeer -> - "" + ["verifyPeer=yes"] | CheckHost -> - sprintf "checkHost=%s" host - ) - ; "verifyPeer=yes" - ; sprintf "CAfile=%s" cert_bundle_path - ; ( match Sys.readdir crl_path with - | [||] -> - "" - | _ -> - sprintf "CRLpath=%s" crl_path - | exception _ -> - "" + [sprintf "checkHost=%s" host; "verifyChain=yes"] ) - ] + [ + "" + ; "# use SNI to request a specific cert. CAfile contains" + ; "# public certs of all hosts in the pool and must contain" + ; "# the cert of the server we connect to" + ; (match sni with None -> "" | Some s -> sprintf "sni = %s" s) + ; sprintf "CAfile=%s" cert_bundle_path + ; ( match Sys.readdir crl_path with + | [||] -> + "" + | _ -> + sprintf "CRLpath=%s" crl_path + | exception _ -> + "" + ) + ] ) ; [""] ] From 36b9e1a72499d40223cbff746e2867ef57d0fff1 Mon Sep 17 00:00:00 2001 From: Colin James Date: Mon, 16 Dec 2024 10:30:55 +0000 Subject: [PATCH 20/73] Simplify event generation predicate in Xapi_event Precompute a table of object names for which events should be propagated. This avoids the list querying done every time the database queues an event. Signed-off-by: Colin James --- ocaml/xapi/xapi_event.ml | 35 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 600d2859dd3..cdc82ca20d8 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -757,28 +757,27 @@ let inject ~__context ~_class ~_ref = (* Internal interface ****************************************************) -let event_add ?snapshot ty op reference = - let objs = - List.filter - (fun x -> x.Datamodel_types.gen_events) - (Dm_api.objects_of_api Datamodel.all_api) +let generate_events_for = + let table = Hashtbl.create 64 in + let add_object ({name; gen_events; _} : Datamodel_types.obj) = + (* Record only the names of objects that should generate events. *) + if gen_events then + Hashtbl.replace table name () in - let objs = List.map (fun x -> x.Datamodel_types.name) objs in - if List.mem ty objs then ( + Dm_api.objects_of_api Datamodel.all_api |> List.iter add_object ; + Hashtbl.mem table + +let event_add ?snapshot ty op reference = + let add () = + let id = Int64.to_string !Next.id in let ts = string_of_float (Unix.time ()) in + let ty = String.lowercase_ascii ty in let op = op_of_string op in - let ev = - { - id= Int64.to_string !Next.id - ; ts - ; ty= String.lowercase_ascii ty - ; op - ; reference - ; snapshot - } - in + let ev = {id; ts; ty; op; reference; snapshot} in From.add ev ; Next.add ev - ) + in + if generate_events_for ty then + add () let register_hooks () = Xapi_database.Db_action_helper.events_register event_add From ea6f35529e55e4a017d6f9047cc1697a667667a5 Mon Sep 17 00:00:00 2001 From: Colin James Date: Mon, 16 Dec 2024 12:25:44 +0000 Subject: [PATCH 21/73] Update comment to include implicit invariant Signed-off-by: Colin James --- ocaml/idl/datamodel.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index 83d5d1740c3..33eb339dfa1 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -10448,7 +10448,18 @@ let all_system = * updated must come first. The second field will be automatically * kept * up-to-date. *) -(** These are the pairs of (object, field) which are bound together in the database schema *) +(** + These are the pairs of (object, field) which are bound together in + the database schema. + + It is assumed that, for any entry (p, p'), neither p nor p' + appears in any other entry. It may be the case that p = p', which + is the only instance where some object-field pair may appear more + than once. + + This is implicitly assumed by other code which treats this list - + and its symmetric closure - as an association list + without duplicate keys. *) let all_relations = [ (* snapshots *) From a4e55f52d859be2a6935752980fe25c82d83ef7f Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Fri, 13 Dec 2024 12:03:58 +0000 Subject: [PATCH 22/73] IH-747 - xapi/import: Don't lie in VDI import logs Instead of logging errors like this and then immediately handling them: ``` [error|1141 |VM metadata import |import] Found no VDI with location = dedeeb44-62b3-460e-b55c-6de45ba10cc0: treating as fatal and abandoning import [debug|1141 |VM metadata import |import] Ignoring missing disk Ref:4 - this will be mirrored during a real live migration. ``` Log once in the handler: ``` [ warn|VM metadata import |import] Ignoring missing disk Ref:16 - this will be mirrored during a real live migration. (Suppressed error: 'Found no VDI with location = c208b47c-cf87-495f-bd3c-a4bc8167ef83') ``` Signed-off-by: Andrii Sultanov --- ocaml/xapi/import.ml | 50 +++++++++++++++++++++++++------------------- 1 file changed, 28 insertions(+), 22 deletions(-) diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index 2a9d37b7972..39e069b2768 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -939,7 +939,7 @@ module VDI : HandlerTools = struct | Found_iso of API.ref_VDI | Found_no_iso | Found_disk of API.ref_VDI - | Found_no_disk of exn + | Found_no_disk of string * exn | Skip | Create of API.vDI_t @@ -1090,27 +1090,31 @@ module VDI : HandlerTools = struct | Some vdi -> Found_disk vdi | None -> - error "Found no VDI with location = %s: %s" - vdi_record.API.vDI_location - ( if config.force then - "ignoring error because '--force' is set" - else - "treating as fatal and abandoning import" - ) ; - if config.force then - Skip - else if exists vdi_record.API.vDI_SR state.table then + let error_string = + Printf.sprintf "Found no VDI with location = %s%s" + vdi_record.API.vDI_location + ( if config.force then + ": ignoring error because '--force' is set" + else + "" + ) + in + if config.force then ( + warn "%s" error_string ; Skip + ) else if exists vdi_record.API.vDI_SR state.table then let sr = lookup vdi_record.API.vDI_SR state.table in Found_no_disk - (Api_errors.Server_error - ( Api_errors.vdi_location_missing - , [Ref.string_of sr; vdi_record.API.vDI_location] - ) + ( error_string + , Api_errors.Server_error + ( Api_errors.vdi_location_missing + , [Ref.string_of sr; vdi_record.API.vDI_location] + ) ) else Found_no_disk - (Api_errors.Server_error - (Api_errors.vdi_content_id_missing, []) + ( error_string + , Api_errors.Server_error + (Api_errors.vdi_content_id_missing, []) ) ) ) @@ -1123,18 +1127,19 @@ module VDI : HandlerTools = struct state.table <- (x.cls, x.id, Ref.string_of vdi) :: state.table | Found_no_iso -> () (* VDI will be ejected. *) - | Found_no_disk e -> ( + | Found_no_disk (error_string, e) -> ( match config.import_type with | Metadata_import {live= true; _} -> (* We expect the disk to be missing during a live migration dry run. *) - debug + info "Ignoring missing disk %s - this will be mirrored during a real \ - live migration." - x.id ; + live migration. (Suppressed error: '%s')" + x.id error_string ; (* Create a dummy disk in the state table so the VBD import has a disk to look up. *) let dummy_vdi = Ref.make () in state.table <- (x.cls, x.id, Ref.string_of dummy_vdi) :: state.table | _ -> + error "%s - treating as fatal and abandoning import" error_string ; raise e ) | Skip -> @@ -1161,7 +1166,8 @@ module VDI : HandlerTools = struct with Not_found -> () ) Xapi_globs.vdi_other_config_sync_keys - | Found_no_disk e -> + | Found_no_disk (error_string, e) -> + error "%s - treating as fatal and abandoning import" error_string ; raise e | Create vdi_record -> (* Make a new VDI for streaming data into; adding task-id to sm-config on VDI.create so SM backend can see this is an import *) From cfc6594e1d2a70660a7800882b07892af63a3577 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Fri, 13 Dec 2024 15:41:53 +0000 Subject: [PATCH 23/73] IH-747 - database: Add an internal get_by_uuid_opt method Instead of raising an exception in case of an error like get_by_uuid, return None to be handled gracefully later. Do not expose it in the datamodel. This will later be used when an object is checked to exist before its creation (during migration, for example), and so its absence is expected - no need to raise a backtrace and pollute the logs with errors. Signed-off-by: Andrii Sultanov --- ocaml/database/db_cache_impl.ml | 15 +++++++++ ocaml/database/db_interface.ml | 5 +++ ocaml/database/db_rpc_client_v1.ml | 4 +++ ocaml/database/db_rpc_client_v2.ml | 7 +++++ ocaml/database/db_rpc_common_v1.ml | 2 ++ ocaml/database/db_rpc_common_v2.ml | 1 + ocaml/idl/ocaml_backend/gen_db_actions.ml | 37 ++++++++++++++++++++++- 7 files changed, 70 insertions(+), 1 deletion(-) diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index b4f23b0af00..4c4f33b728a 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -240,6 +240,21 @@ let db_get_by_uuid t tbl uuid_val = | _ -> raise (Too_many_values (tbl, "", uuid_val)) +let db_get_by_uuid_opt t tbl uuid_val = + match + read_field_where t + { + table= tbl + ; return= Db_names.ref + ; where_field= Db_names.uuid + ; where_value= uuid_val + } + with + | [r] -> + Some r + | _ -> + None + (** Return reference fields from tbl that matches specified name_label field *) let db_get_by_name_label t tbl label = read_field_where t diff --git a/ocaml/database/db_interface.ml b/ocaml/database/db_interface.ml index 834c12cd8a1..081abc687bd 100644 --- a/ocaml/database/db_interface.ml +++ b/ocaml/database/db_interface.ml @@ -56,6 +56,11 @@ module type DB_ACCESS = sig (** [db_get_by_uuid tbl uuid] returns the single object reference associated with [uuid] *) + val db_get_by_uuid_opt : Db_ref.t -> string -> string -> string option + (** [db_get_by_uuid_opt tbl uuid] returns [Some obj] with the single object + reference associated with [uuid] if one exists and [None] otherwise, + instead of raising an exception like [get_by_uuid] *) + val db_get_by_name_label : Db_ref.t -> string -> string -> string list (** [db_get_by_name_label tbl label] returns the list of object references associated with [label] *) diff --git a/ocaml/database/db_rpc_client_v1.ml b/ocaml/database/db_rpc_client_v1.ml index ecde5c4060b..7adbcd6bbed 100644 --- a/ocaml/database/db_rpc_client_v1.ml +++ b/ocaml/database/db_rpc_client_v1.ml @@ -88,6 +88,10 @@ functor do_remote_call marshall_db_get_by_uuid_args unmarshall_db_get_by_uuid_response "db_get_by_uuid" (t, u) + let db_get_by_uuid_opt _ t u = + do_remote_call marshall_db_get_by_uuid_args + unmarshall_db_get_by_uuid_opt_response "db_get_by_uuid_opt" (t, u) + let db_get_by_name_label _ t l = do_remote_call marshall_db_get_by_name_label_args unmarshall_db_get_by_name_label_response "db_get_by_name_label" (t, l) diff --git a/ocaml/database/db_rpc_client_v2.ml b/ocaml/database/db_rpc_client_v2.ml index 3c85dd82fcf..3a32b3149e9 100644 --- a/ocaml/database/db_rpc_client_v2.ml +++ b/ocaml/database/db_rpc_client_v2.ml @@ -77,6 +77,13 @@ functor | _ -> raise Remote_db_server_returned_bad_message + let db_get_by_uuid_opt _ t u = + match process (Request.Db_get_by_uuid (t, u)) with + | Response.Db_get_by_uuid_opt y -> + y + | _ -> + raise Remote_db_server_returned_bad_message + let db_get_by_name_label _ t l = match process (Request.Db_get_by_name_label (t, l)) with | Response.Db_get_by_name_label y -> diff --git a/ocaml/database/db_rpc_common_v1.ml b/ocaml/database/db_rpc_common_v1.ml index 1966595938f..cced73dd9ca 100644 --- a/ocaml/database/db_rpc_common_v1.ml +++ b/ocaml/database/db_rpc_common_v1.ml @@ -194,6 +194,8 @@ let marshall_db_get_by_uuid_response s = XMLRPC.To.string s let unmarshall_db_get_by_uuid_response xml = XMLRPC.From.string xml +let unmarshall_db_get_by_uuid_opt_response xml = unmarshall_stringopt xml + (* db_get_by_name_label *) let marshall_db_get_by_name_label_args (s1, s2) = marshall_2strings (s1, s2) diff --git a/ocaml/database/db_rpc_common_v2.ml b/ocaml/database/db_rpc_common_v2.ml index 5ecf1b3e797..4cd9d7541ab 100644 --- a/ocaml/database/db_rpc_common_v2.ml +++ b/ocaml/database/db_rpc_common_v2.ml @@ -59,6 +59,7 @@ module Response = struct | Find_refs_with_filter of string list | Read_field_where of string list | Db_get_by_uuid of string + | Db_get_by_uuid_opt of string option | Db_get_by_name_label of string list | Create_row of unit | Delete_row of unit diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index 06f54f228ba..86e9f426883 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -93,6 +93,9 @@ let dm_to_string tys : O.Module.t = "fun x -> x |> SecretString.rpc_of_t |> Rpc.string_of_rpc" | DT.Record _ -> failwith "record types never stored in the database" + | DT.Option (DT.Ref _ as ty) -> + String.concat "" + ["fun s -> set "; OU.alias_of_ty ty; "(Option.to_list s)"] | DT.Option _ -> failwith "option types never stored in the database" in @@ -148,6 +151,13 @@ let string_to_dm tys : O.Module.t = "SecretString.of_string" | DT.Record _ -> failwith "record types never stored in the database" + | DT.Option (DT.Ref _ as ty) -> + String.concat "" + [ + "fun s -> match set " + ; OU.alias_of_ty ty + ; " s with [] -> None | x::_ -> Some x" + ] | DT.Option _ -> failwith "option types never stored in the database" in @@ -515,7 +525,32 @@ let db_action api : O.Module.t = (Escaping.escape_obj obj.DT.name) (OU.escape name) in - _string_to_dm ^ "." ^ OU.alias_of_ty result_ty ^ " (" ^ query ^ ")" + let func = + _string_to_dm + ^ "." + ^ OU.alias_of_ty result_ty + ^ " (" + ^ query + ^ ")" + in + let query_opt = + Printf.sprintf "DB.db_get_by_uuid_opt __t \"%s\" %s" + (Escaping.escape_obj obj.DT.name) + (OU.escape name) + in + String.concat "\n\t\t" + ([func] + @ [ + String.concat "\n\t\t " + (["and get_by_uuid_opt ~__context ~uuid ="] + @ open_db_module + @ [ + Printf.sprintf "Option.map %s.%s (%s)" _string_to_dm + (OU.alias_of_ty result_ty) query_opt + ] + ) + ] + ) | _ -> failwith "GetByUuid call should have only one parameter and a result!" From 81c2a6af0b4965e50ebb0e34850b402a7ed4c487 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Fri, 13 Dec 2024 12:06:40 +0000 Subject: [PATCH 24/73] IH-747 - xapi/import: Use get_by_uuid_opt to not log backtraces when failure is expected Migration logs are always full of exceptions that are expected and immediately handled: ``` [error|backtrace] SR.get_by_uuid D:8651cc0c9fb6 failed with exception Db_exn.Read_missing_uuid("SR", "", "a94bf103-0169-6d70-8874-334261f5098e") [error|backtrace] Raised Db_exn.Read_missing_uuid("SR", "", "a94bf103-0169-6d70-8874-334261f5098e") [error|backtrace] 1/9 xapi Raised at file ocaml/database/db_cache_impl.ml, line 237 [error|backtrace] 2/9 xapi Called from file ocaml/xapi/db_actions.ml, line 13309 [error|backtrace] 3/9 xapi Called from file ocaml/xapi/rbac.ml, line 188 [error|backtrace] 4/9 xapi Called from file ocaml/xapi/rbac.ml, line 197 [error|backtrace] 5/9 xapi Called from file ocaml/xapi/server_helpers.ml, line 74 [error|backtrace] 6/9 xapi Called from file ocaml/xapi/server_helpers.ml, line 96 [error|backtrace] 7/9 xapi Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 24 [error|backtrace] 8/9 xapi Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 39 [error|backtrace] 9/9 xapi Called from file ocaml/libs/log/debug.ml, line 250 [ warn|import] Failed to find SR with UUID: a94bf103-0169-6d70-8874-334261f5098e content-type: user - will still try to find individual VDIs [....] [debug|import] Importing 1 VM_guest_metrics(s) [debug|import] Importing 1 VM_metrics(s) [debug|import] Importing 1 VM(s) [debug|import] Importing 1 network(s) [debug|import] Importing 0 GPU_group(s) [debug|import] Importing 1 VBD(s) [error|backtrace] VBD.get_by_uuid D:3a12311e8be4 failed with exception Db_exn.Read_missing_uuid("VBD", "", "026d61e9-ed8a-fc72-7fd3-77422585baff") [error|backtrace] Raised Db_exn.Read_missing_uuid("VBD", "", "026d61e9-ed8a-fc72-7fd3-77422585baff") [error|backtrace] 1/9 xapi Raised at file ocaml/database/db_cache_impl.ml, line 237 [error|backtrace] 2/9 xapi Called from file ocaml/xapi/db_actions.ml, line 14485 [error|backtrace] 3/9 xapi Called from file ocaml/xapi/rbac.ml, line 188 [error|backtrace] 4/9 xapi Called from file ocaml/xapi/rbac.ml, line 197 [error|backtrace] 5/9 xapi Called from file ocaml/xapi/server_helpers.ml, line 74 [error|backtrace] 6/9 xapi Called from file ocaml/xapi/server_helpers.ml, line 96 [error|backtrace] 7/9 xapi Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 24 [error|backtrace] 8/9 xapi Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 39 [error|backtrace] 9/9 xapi Called from file ocaml/libs/log/debug.ml, line 250 [debug|import] Importing 1 VIF(s) [error|backtrace] VIF.get_by_uuid D:2bc78449e0bc failed with exception Db_exn.Read_missing_uuid("VIF", "", "7d14aee4-47a4-e271-4f64-fe9f9ef6d50b") [error|backtrace] Raised Db_exn.Read_missing_uuid("VIF", "", "7d14aee4-47a4-e271-4f64-fe9f9ef6d50b") [error|backtrace] 1/9 xapi Raised at file ocaml/database/db_cache_impl.ml, line 237 [error|backtrace] 2/9 xapi Called from file ocaml/xapi/db_actions.ml, line 10813 [error|backtrace] 3/9 xapi Called from file ocaml/xapi/rbac.ml, line 188 [error|backtrace] 4/9 xapi Called from file ocaml/xapi/rbac.ml, line 197 [error|backtrace] 5/9 xapi Called from file ocaml/xapi/server_helpers.ml, line 74 [error|backtrace] 6/9 xapi Called from file ocaml/xapi/server_helpers.ml, line 96 [error|backtrace] 7/9 xapi Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 24 [error|backtrace] 8/9 xapi Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 39 [error|backtrace] 9/9 xapi Called from file ocaml/libs/log/debug.ml, line 250 ``` Use an internal get_by_uuid_opt call and match on the Option instead, with the logs looking much clearer: ``` [debug|import] Importing 1 host(s) [debug|import] Importing 2 SR(s) [ warn|import] Failed to find SR with UUID: 8568e308-c61c-3b10-3953-45606cfecede content-type: - will still try to find individual VDIs [ warn|import] Failed to find SR with UUID: 40e9e252-46ac-ed3d-7a4c-6db175212195 content-type: user - will still try to find individual VDIs [...] [debug|import] Importing 2 VM_guest_metrics(s) [debug|import] Importing 2 VM(s) [debug|import] Importing 1 network(s) [debug|import] Importing 1 GPU_group(s) [debug|import] Importing 4 VBD(s) [ info|import] Did not find an already existing VBD with the same uuid=569d0e60-6a89-d1fa-2ed6-38b8eebe9065, try to create a new one [ info|import] Did not find an already existing VBD with the same uuid=533306da-cff1-7ada-71f7-2c4de8a0065b, try to create a new one [ info|import] Did not find an already existing VBD with the same uuid=f9dec620-0180-f67f-6711-7f9e5222a682, try to create a new one [ info|import] Did not find an already existing VBD with the same uuid=05e55076-b559-9b49-c247-e7850984ddae, try to create a new one [debug|import] Importing 2 VIF(s) [ info|import] Did not find an already existing VIF with the same uuid=a5a731d5-622c-5ca5-5b2a-a0053a11ef07, try to create a new one [ info|import] Did not find an already existing VIF with the same uuid=1738bf20-8d16-0d69-48cd-8f3d9e7ea791, try to create a new one ``` Signed-off-by: Andrii Sultanov --- ocaml/xapi/import.ml | 481 +++++++++++++++++++++++-------------------- 1 file changed, 262 insertions(+), 219 deletions(-) diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index 39e069b2768..3dd311d72e9 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -887,27 +887,31 @@ module SR : HandlerTools = struct | Will_use_SR of API.ref_SR | SR_not_needed - let precheck __context config rpc session_id _state x = + let precheck __context config _rpc _session_id _state x = let sr_record = API.sR_t_of_rpc x.snapshot in match config.import_type with | Metadata_import _ -> ( - try + match (* Look up the existing SR record *) - let sr = - Client.SR.get_by_uuid ~rpc ~session_id ~uuid:sr_record.API.sR_uuid - in - Found_SR sr - with _ -> - let msg = - match sr_record.API.sR_content_type with - | "iso" -> - "- will eject disk" (* Will be handled specially in handle_vdi *) - | _ -> - "- will still try to find individual VDIs" - in - warn "Failed to find SR with UUID: %s content-type: %s %s" - sr_record.API.sR_uuid sr_record.API.sR_content_type msg ; - Found_no_SR + (* Use an internal DB call - this avoids raising an exception and logging + the backtrace internally in case of a (reasonably expected) absence of + the object with this UUID *) + Db.SR.get_by_uuid_opt ~__context ~uuid:sr_record.API.sR_uuid + with + | Some sr -> + Found_SR sr + | None -> + let msg = + match sr_record.API.sR_content_type with + | "iso" -> + "- will eject disk" + (* Will be handled specially in handle_vdi *) + | _ -> + "- will still try to find individual VDIs" + in + warn "Failed to find SR with UUID: %s content-type: %s %s" + sr_record.API.sR_uuid sr_record.API.sR_content_type msg ; + Found_no_SR ) | Full_import sr -> if sr_record.API.sR_content_type = "iso" then @@ -1365,80 +1369,94 @@ end module VBD : HandlerTools = struct type precheck_t = Found_VBD of API.ref_VBD | Skip | Create of API.vBD_t - let precheck __context config rpc session_id state x = + let precheck __context config _rpc _session_id state x = let vbd_record = API.vBD_t_of_rpc x.snapshot in let get_vbd () = - Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:vbd_record.API.vBD_uuid + (* Use an internal DB call - this avoids raising an exception and logging + the backtrace internally in case of a (reasonably expected) absence of + the object with this UUID *) + Db.VBD.get_by_uuid_opt ~__context ~uuid:vbd_record.API.vBD_uuid in - let vbd_exists () = - try - ignore (get_vbd ()) ; - true - with _ -> false + let vbd_opt = + (* If there's already a VBD with the same UUID and we're preserving UUIDs, use that one. *) + if config.full_restore then ( + match get_vbd () with + | Some x -> + Some x + | None -> + info + "Did not find an already existing VBD with the same uuid=%s, try \ + to create a new one" + vbd_record.API.vBD_uuid ; + None + ) else + None in - if config.full_restore && vbd_exists () then - let vbd = get_vbd () in - Found_VBD vbd - else - let vm = - log_reraise - ("Failed to find VBD's VM: " ^ Ref.string_of vbd_record.API.vBD_VM) - (lookup vbd_record.API.vBD_VM) - state.table - in - (* If the VBD is supposed to be attached to a PV guest (which doesn't support - currently_attached empty drives) then throw a fatal error. *) - let original_vm = - get_vm_record - (find_in_export (Ref.string_of vbd_record.API.vBD_VM) state.export) - in - (* Note: the following is potentially inaccurate: the find out whether a running or - * suspended VM has booted HVM, we must consult the VM metrics, but those aren't - * available in the exported metadata. *) - let has_qemu = Helpers.will_have_qemu_from_record original_vm in - (* In the case of dry_run live migration, don't check for - missing disks as CDs will be ejected before the real migration. *) - let dry_run, live = - match config.import_type with - | Metadata_import {dry_run; live; _} -> - (dry_run, live) - | _ -> - (false, false) - in - ( if - vbd_record.API.vBD_currently_attached - && not (exists vbd_record.API.vBD_VDI state.table) - then - (* It's only ok if it's a CDROM attached to an HVM guest, or it's part of SXM and we know the sender would eject it. *) - let will_eject = - dry_run && live && original_vm.API.vM_power_state <> `Suspended - in - if not (vbd_record.API.vBD_type = `CD && (has_qemu || will_eject)) + match vbd_opt with + | Some vbd -> + Found_VBD vbd + | None -> ( + let vm = + log_reraise + ("Failed to find VBD's VM: " ^ Ref.string_of vbd_record.API.vBD_VM) + (lookup vbd_record.API.vBD_VM) + state.table + in + (* If the VBD is supposed to be attached to a PV guest (which doesn't support + currently_attached empty drives) then throw a fatal error. *) + let original_vm = + get_vm_record + (find_in_export (Ref.string_of vbd_record.API.vBD_VM) state.export) + in + (* Note: the following is potentially inaccurate: the find out whether a running or + * suspended VM has booted HVM, we must consult the VM metrics, but those aren't + * available in the exported metadata. *) + let has_qemu = Helpers.will_have_qemu_from_record original_vm in + (* In the case of dry_run live migration, don't check for + missing disks as CDs will be ejected before the real migration. *) + let dry_run, live = + match config.import_type with + | Metadata_import {dry_run; live; _} -> + (dry_run, live) + | _ -> + (false, false) + in + ( if + vbd_record.API.vBD_currently_attached + && not (exists vbd_record.API.vBD_VDI state.table) then - raise (IFailure Attached_disks_not_found) - ) ; - let vbd_record = {vbd_record with API.vBD_VM= vm} in - match - (vbd_record.API.vBD_type, exists vbd_record.API.vBD_VDI state.table) - with - | `CD, false | `Floppy, false -> - if has_qemu || original_vm.API.vM_power_state <> `Suspended then - Create {vbd_record with API.vBD_VDI= Ref.null; API.vBD_empty= true} - (* eject *) - else - Create vbd_record - | `Disk, false -> - (* omit: cannot have empty disks *) - warn - "Cannot import VM's disk: was it an .iso attached as a disk rather \ - than CD?" ; - Skip - | _, true -> - Create - { - vbd_record with - API.vBD_VDI= lookup vbd_record.API.vBD_VDI state.table - } + (* It's only ok if it's a CDROM attached to an HVM guest, or it's part of SXM and we know the sender would eject it. *) + let will_eject = + dry_run && live && original_vm.API.vM_power_state <> `Suspended + in + if not (vbd_record.API.vBD_type = `CD && (has_qemu || will_eject)) + then + raise (IFailure Attached_disks_not_found) + ) ; + let vbd_record = {vbd_record with API.vBD_VM= vm} in + match + (vbd_record.API.vBD_type, exists vbd_record.API.vBD_VDI state.table) + with + | `CD, false | `Floppy, false -> + if has_qemu || original_vm.API.vM_power_state <> `Suspended then + Create + {vbd_record with API.vBD_VDI= Ref.null; API.vBD_empty= true} + (* eject *) + else + Create vbd_record + | `Disk, false -> + (* omit: cannot have empty disks *) + warn + "Cannot import VM's disk: was it an .iso attached as a disk \ + rather than CD?" ; + Skip + | _, true -> + Create + { + vbd_record with + API.vBD_VDI= lookup vbd_record.API.vBD_VDI state.table + } + ) let handle_dry_run __context _config _rpc _session_id state x precheck_result = @@ -1493,88 +1511,99 @@ end module VIF : HandlerTools = struct type precheck_t = Found_VIF of API.ref_VIF | Create of API.vIF_t - let precheck __context config rpc session_id state x = + let precheck __context config _rpc _session_id state x = let vif_record = API.vIF_t_of_rpc x.snapshot in let get_vif () = - Client.VIF.get_by_uuid ~rpc ~session_id ~uuid:vif_record.API.vIF_uuid + (* Use an internal DB call - this avoids raising an exception and logging + the backtrace internally in case of a (reasonably expected) absence of + the object with this UUID *) + Db.VIF.get_by_uuid_opt ~__context ~uuid:vif_record.API.vIF_uuid in - let vif_exists () = - try - ignore (get_vif ()) ; - true - with _ -> false + let vif_opt = + if config.full_restore then ( + (* If there's already a VIF with the same UUID and we're preserving UUIDs, use that one. *) + match get_vif () with + | Some x -> + Some x + | None -> + info + "Did not find an already existing VIF with the same uuid=%s, try \ + to create a new one" + vif_record.API.vIF_uuid ; + None + ) else + None in - if config.full_restore && vif_exists () then - (* If there's already a VIF with the same UUID and we're preserving UUIDs, use that one. *) - let vif = get_vif () in - Found_VIF vif - else - (* If not restoring a full backup then blank the MAC so it is regenerated *) - let vif_record = - { - vif_record with - API.vIF_MAC= - (if config.full_restore then vif_record.API.vIF_MAC else "") - } - in - (* Determine the VM to which we're going to attach this VIF. *) - let vm = - log_reraise - ("Failed to find VIF's VM: " ^ Ref.string_of vif_record.API.vIF_VM) - (lookup vif_record.API.vIF_VM) - state.table - in - (* Determine the network to which we're going to attach this VIF. *) - let net = - (* If we find the cross-pool migration key, attach the VIF to that network... *) - if - List.mem_assoc Constants.storage_migrate_vif_map_key - vif_record.API.vIF_other_config - then - Ref.of_string - (List.assoc Constants.storage_migrate_vif_map_key - vif_record.API.vIF_other_config - ) - else - (* ...otherwise fall back to looking up the network from the state table. *) + match vif_opt with + | Some vif -> + Found_VIF vif + | None -> + (* If not restoring a full backup then blank the MAC so it is regenerated *) + let vif_record = + { + vif_record with + API.vIF_MAC= + (if config.full_restore then vif_record.API.vIF_MAC else "") + } + in + (* Determine the VM to which we're going to attach this VIF. *) + let vm = log_reraise - ("Failed to find VIF's Network: " - ^ Ref.string_of vif_record.API.vIF_network - ) - (lookup vif_record.API.vIF_network) + ("Failed to find VIF's VM: " ^ Ref.string_of vif_record.API.vIF_VM) + (lookup vif_record.API.vIF_VM) state.table - in - (* Make sure we remove the cross-pool migration VIF mapping key from the other_config - * before creating a VIF - otherwise we'll risk sending this key on to another pool - * during a future cross-pool migration and it won't make sense. *) - let other_config = - List.filter - (fun (k, _) -> k <> Constants.storage_migrate_vif_map_key) - vif_record.API.vIF_other_config - in - (* Construct the VIF record we're going to try to create locally. *) - let vif_record = - if Pool_features.is_enabled ~__context Features.VIF_locking then - vif_record - else if vif_record.API.vIF_locking_mode = `locked then + in + (* Determine the network to which we're going to attach this VIF. *) + let net = + (* If we find the cross-pool migration key, attach the VIF to that network... *) + if + List.mem_assoc Constants.storage_migrate_vif_map_key + vif_record.API.vIF_other_config + then + Ref.of_string + (List.assoc Constants.storage_migrate_vif_map_key + vif_record.API.vIF_other_config + ) + else + (* ...otherwise fall back to looking up the network from the state table. *) + log_reraise + ("Failed to find VIF's Network: " + ^ Ref.string_of vif_record.API.vIF_network + ) + (lookup vif_record.API.vIF_network) + state.table + in + (* Make sure we remove the cross-pool migration VIF mapping key from the other_config + * before creating a VIF - otherwise we'll risk sending this key on to another pool + * during a future cross-pool migration and it won't make sense. *) + let other_config = + List.filter + (fun (k, _) -> k <> Constants.storage_migrate_vif_map_key) + vif_record.API.vIF_other_config + in + (* Construct the VIF record we're going to try to create locally. *) + let vif_record = + if Pool_features.is_enabled ~__context Features.VIF_locking then + vif_record + else if vif_record.API.vIF_locking_mode = `locked then + { + vif_record with + API.vIF_locking_mode= `network_default + ; API.vIF_ipv4_allowed= [] + ; API.vIF_ipv6_allowed= [] + } + else + {vif_record with API.vIF_ipv4_allowed= []; API.vIF_ipv6_allowed= []} + in + let vif_record = { vif_record with - API.vIF_locking_mode= `network_default - ; API.vIF_ipv4_allowed= [] - ; API.vIF_ipv6_allowed= [] + API.vIF_VM= vm + ; API.vIF_network= net + ; API.vIF_other_config= other_config } - else - {vif_record with API.vIF_ipv4_allowed= []; API.vIF_ipv6_allowed= []} - in - let vif_record = - { - vif_record with - API.vIF_VM= vm - ; API.vIF_network= net - ; API.vIF_other_config= other_config - } - in - Create vif_record + in + Create vif_record let handle_dry_run __context _config _rpc _session_id state x precheck_result = @@ -1710,74 +1739,88 @@ end module VGPU : HandlerTools = struct type precheck_t = Found_VGPU of API.ref_VGPU | Create of API.vGPU_t - let precheck __context config rpc session_id state x = + let precheck __context config _rpc _session_id state x = let vgpu_record = API.vGPU_t_of_rpc x.snapshot in let get_vgpu () = - Client.VGPU.get_by_uuid ~rpc ~session_id ~uuid:vgpu_record.API.vGPU_uuid + (* Use an internal DB call - this avoids raising an exception and logging + the backtrace internally in case of a (reasonably expected) absence of + the object with this UUID *) + Db.VGPU.get_by_uuid_opt ~__context ~uuid:vgpu_record.API.vGPU_uuid in - let vgpu_exists () = - try - ignore (get_vgpu ()) ; - true - with _ -> false + let vgpu_opt = + if config.full_restore then ( + (* If there's already a VGPU with the same UUID and we're preserving UUIDs, use that one. *) + match get_vgpu () with + | Some x -> + Some x + | None -> + info + "Did not find an already existing VGPU with the same uuid=%s, \ + try to create a new one" + vgpu_record.API.vGPU_uuid ; + None + ) else + None in - if config.full_restore && vgpu_exists () then - let vgpu = get_vgpu () in - Found_VGPU vgpu - else - let vm = - log_reraise - ("Failed to find VGPU's VM: " ^ Ref.string_of vgpu_record.API.vGPU_VM) - (lookup vgpu_record.API.vGPU_VM) - state.table - in - let group = - (* If we find the cross-pool migration key, attach the vgpu to the provided gpu_group... *) - if - List.mem_assoc Constants.storage_migrate_vgpu_map_key - vgpu_record.API.vGPU_other_config - then - Ref.of_string - (List.assoc Constants.storage_migrate_vgpu_map_key - vgpu_record.API.vGPU_other_config + match vgpu_opt with + | Some vgpu -> + Found_VGPU vgpu + | None -> + let vm = + log_reraise + ("Failed to find VGPU's VM: " + ^ Ref.string_of vgpu_record.API.vGPU_VM ) - else - (* ...otherwise fall back to looking up the vgpu from the state table. *) + (lookup vgpu_record.API.vGPU_VM) + state.table + in + let group = + (* If we find the cross-pool migration key, attach the vgpu to the provided gpu_group... *) + if + List.mem_assoc Constants.storage_migrate_vgpu_map_key + vgpu_record.API.vGPU_other_config + then + Ref.of_string + (List.assoc Constants.storage_migrate_vgpu_map_key + vgpu_record.API.vGPU_other_config + ) + else + (* ...otherwise fall back to looking up the vgpu from the state table. *) + log_reraise + ("Failed to find VGPU's GPU group: " + ^ Ref.string_of vgpu_record.API.vGPU_GPU_group + ) + (lookup vgpu_record.API.vGPU_GPU_group) + state.table + in + let _type = log_reraise - ("Failed to find VGPU's GPU group: " - ^ Ref.string_of vgpu_record.API.vGPU_GPU_group + ("Failed to find VGPU's type: " + ^ Ref.string_of vgpu_record.API.vGPU_type ) - (lookup vgpu_record.API.vGPU_GPU_group) + (lookup vgpu_record.API.vGPU_type) state.table - in - let _type = - log_reraise - ("Failed to find VGPU's type: " - ^ Ref.string_of vgpu_record.API.vGPU_type - ) - (lookup vgpu_record.API.vGPU_type) - state.table - in - (* Make sure we remove the cross-pool migration VGPU mapping key from the other_config - * before creating a VGPU - otherwise we'll risk sending this key on to another pool - * during a future cross-pool migration and it won't make sense. *) - let other_config = - List.filter - (fun (k, _) -> k <> Constants.storage_migrate_vgpu_map_key) - vgpu_record.API.vGPU_other_config - in - let vgpu_record = - { - vgpu_record with - API.vGPU_VM= vm - ; API.vGPU_GPU_group= group - ; API.vGPU_type= _type - ; API.vGPU_other_config= other_config - } - in - if is_live config then - assert_can_live_import_vgpu ~__context vgpu_record ; - Create vgpu_record + in + (* Make sure we remove the cross-pool migration VGPU mapping key from the other_config + * before creating a VGPU - otherwise we'll risk sending this key on to another pool + * during a future cross-pool migration and it won't make sense. *) + let other_config = + List.filter + (fun (k, _) -> k <> Constants.storage_migrate_vgpu_map_key) + vgpu_record.API.vGPU_other_config + in + let vgpu_record = + { + vgpu_record with + API.vGPU_VM= vm + ; API.vGPU_GPU_group= group + ; API.vGPU_type= _type + ; API.vGPU_other_config= other_config + } + in + if is_live config then + assert_can_live_import_vgpu ~__context vgpu_record ; + Create vgpu_record let handle_dry_run __context _config _rpc _session_id state x precheck_result = From c8af62d8e675d4471b1b7983925088fe8d768de0 Mon Sep 17 00:00:00 2001 From: Colin James Date: Mon, 16 Dec 2024 14:30:03 +0000 Subject: [PATCH 25/73] Simplify Eventgen Signed-off-by: Colin James --- ocaml/xapi/eventgen.ml | 380 ++++++++++++++++++----------------------- 1 file changed, 166 insertions(+), 214 deletions(-) diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index 46ffd833866..b19be7b33e1 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -11,248 +11,200 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) -module D = Debug.Make (struct let name = "sql" end) +open Debug.Make (struct let name = "sql" end) -open D - -type getrecord = unit -> Rpc.t +type get_record = unit -> Rpc.t let get_record_table : - (string, __context:Context.t -> self:string -> getrecord) Hashtbl.t = - Hashtbl.create 20 + (string, __context:Context.t -> self:string -> get_record) Hashtbl.t = + Hashtbl.create 64 -let find_get_record x ~__context ~self () : Rpc.t option = +let find_get_record obj_name ~__context ~self () : Rpc.t option = Option.map - (fun x -> x ~__context ~self ()) - (Hashtbl.find_opt get_record_table x) + (fun f -> f ~__context ~self ()) + (Hashtbl.find_opt get_record_table obj_name) + +(* If a record is modified, events must be emitted for related objects' records. + We collect a list of related objects by querying the (Ref _)-typed + fields of the input object against the relations encoded by the datamodel. -(* If a record is created or destroyed, then - for any (Ref _) field which is one end of a relationship, need to send - modified events for all those other objects. *) -(* we build a hashtable of these references and then look them up by object on each db write: *) + The result of this function is a list of pairs [(object, field);, ...]. + Note that the field component refers to a field in the input object, + not the related object. *) let compute_object_references_to_follow (obj_name : string) = + let module DT = Datamodel_types in let api = Datamodel.all_api in - let objs = Dm_api.objects_of_api api in - let obj = List.find (fun obj -> obj.Datamodel_types.name = obj_name) objs in - let relations = Dm_api.relations_of_api api in - let symmetric = List.concat_map (fun (a, b) -> [(a, b); (b, a)]) relations in - let set = Xapi_stdext_std.Listext.List.setify symmetric in - List.concat_map - (function - | { - Datamodel_types.ty= Datamodel_types.Ref _ - ; Datamodel_types.field_name - ; _ - } -> - let this_end = (obj.Datamodel_types.name, field_name) in - if List.mem_assoc this_end set then - let other_end = List.assoc this_end set in - let other_obj = fst other_end in - [(other_obj, field_name)] - else - [] - | _ -> - [] - ) - (Datamodel_utils.fields_of_obj obj) + let obj = Dm_api.get_obj_by_name api ~objname:obj_name in + let symmetric = + (* Symmetric closure of the field relation set. *) + Dm_api.relations_of_api api + |> List.concat_map (fun (a, b) -> [(a, b); (b, a)]) + in + (* Find an object related to the input field using the datamodel. *) + let find_related_object = function + | DT.{field_name; ty= Ref _; _} -> + let this_end = (obj_name, field_name) in + List.assoc_opt this_end symmetric + |> Option.map (fun (other_object, _) -> (other_object, field_name)) + | _ -> + None + in + let fields = Datamodel_utils.fields_of_obj obj in + List.filter_map find_related_object fields -let obj_references_table : (string, (string * string) list) Hashtbl.t = - Hashtbl.create 30 +(* For each object, precompute a list of related objects [(object, + field); ...] and store it in a hash table. -(* populate obj references table *) -let _ = - List.iter - (fun obj -> - let obj_name = obj.Datamodel_types.name in - Hashtbl.replace obj_references_table obj_name - (compute_object_references_to_follow obj_name) - ) - (Dm_api.objects_of_api Datamodel.all_api) + If looking up an entry for some object, "foo", yields a list + containing ("bar", "baz"), then it must be the case that "foo"'s + field "baz" (which is necessarily of type Ref _) is related to some + field within "bar". In which case, the database will have already + updated the related field(s) and we must emit events for those fields. *) +let obj_references_table : (string, (string * string) list) Hashtbl.t = + let table = Hashtbl.create 64 in + let populate_follows (obj : Datamodel_types.obj) = + let follows = compute_object_references_to_follow obj.name in + Hashtbl.replace table obj.name follows + in + Dm_api.objects_of_api Datamodel.all_api |> List.iter populate_follows ; + table let follow_references (obj_name : string) = Hashtbl.find obj_references_table obj_name -(** Compute a set of modify events but skip any for objects which were missing - (must have been dangling references) *) -let events_of_other_tbl_refs other_tbl_refs = - List.concat_map - (fun (tbl, fld, x) -> - try [(tbl, fld, x ())] - with _ -> - (* Probably means the reference was dangling *) - warn "skipping event for dangling reference %s: %s" tbl fld ; - [] - ) - other_tbl_refs +(* Compute a modify event's snapshot by attemping to invoke its + getter. If the record cannot be found, the event is dropped (as the + reference is probably dangling). *) +let snapshots_of_other_tbl_refs other_tbl_refs = + let try_get_records (table, field, getter) = + try Some (table, field, getter ()) + with _ -> + (* Probably means the reference was dangling *) + warn "%s: skipping event for dangling reference %s: %s" __FUNCTION__ table + field ; + None + in + List.filter_map try_get_records other_tbl_refs open Xapi_database.Db_cache_types open Xapi_database.Db_action_helper -let database_callback_inner event db context = +let is_valid_ref db = function + | Schema.Value.String r -> ( + try + ignore (Database.table_of_ref r db) ; + true + with _ -> false + ) + | _ -> + false + +type event_kind = Modify | Delete | Add + +let strings_of_event_kind = function + | Modify -> + ("mod", "MOD") + | Delete -> + ("del", "DEL") + | Add -> + ("add", "ADD") + +let emit_events ~kind events = + let kind, upper = strings_of_event_kind kind in + let emit = function + | tbl, ref, None -> + error "%s: Failed to generate %s event on %s %s" __FUNCTION__ upper tbl + ref + | tbl, ref, Some snapshot -> + events_notify ~snapshot tbl kind ref + in + List.iter emit events + +let database_callback_inner event db ~__context = let other_tbl_refs tblname = follow_references tblname in let other_tbl_refs_for_this_field tblname fldname = List.filter (fun (_, fld) -> fld = fldname) (other_tbl_refs tblname) in - let is_valid_ref = function - | Schema.Value.String r -> ( - try - ignore (Database.table_of_ref r db) ; - true - with _ -> false - ) - | _ -> - false + let compute_other_table_events table kvs = + (* Given a table and a deleted/new row's key-values, compute event + snapshots for all objects potentially referenced by values in the + row. *) + let get_potential_event (other_tbl, field) = + (* If a deleted/new field could refer to a row within + other_tbl, collect a potential event for it. *) + let field_value = List.assoc field kvs in + if is_valid_ref db field_value then + let self = Schema.Value.Unsafe_cast.string field_value in + let getter = find_get_record other_tbl ~__context ~self in + Some (other_tbl, self, getter) + else + None + in + follow_references table + |> List.filter_map get_potential_event + |> snapshots_of_other_tbl_refs in match event with - | RefreshRow (tblname, objref) -> ( - (* Generate event *) - let snapshot = find_get_record tblname ~__context:context ~self:objref in - let record = snapshot () in - match record with - | None -> - error "Failed to send MOD event for %s %s" tblname objref ; - Printf.printf "Failed to send MOD event for %s %s\n%!" tblname objref - | Some record -> - events_notify ~snapshot:record tblname "mod" objref - ) + | RefreshRow (tblname, objref) -> + (* To refresh a row, emit a modify event with the current record's + snapshot. *) + let getter = find_get_record tblname ~__context ~self:objref in + let snapshot = getter () in + emit_events ~kind:Modify [(tblname, objref, snapshot)] | WriteField (tblname, objref, fldname, oldval, newval) -> - let events_old_val = - if is_valid_ref oldval then - let oldval = Schema.Value.Unsafe_cast.string oldval in - events_of_other_tbl_refs - (List.map - (fun (tbl, _) -> - ( tbl - , oldval - , find_get_record tbl ~__context:context ~self:oldval - ) - ) - (other_tbl_refs_for_this_field tblname fldname) - ) - else - [] - in - let events_new_val = - if is_valid_ref newval then - let newval = Schema.Value.Unsafe_cast.string newval in - events_of_other_tbl_refs - (List.map - (fun (tbl, _) -> - ( tbl - , newval - , find_get_record tbl ~__context:context ~self:newval - ) - ) - (other_tbl_refs_for_this_field tblname fldname) - ) + (* When a field is written, both the new and old values of the + field may be references to other objects, which have already + been rewritten by the database layer. To follow up, we must + emit events for the previously referenced object, the current + row, and the newly referenced object.*) + let other_tbl_refs = other_tbl_refs_for_this_field tblname fldname in + (* Compute list of potential events. Some snapshots may fail to + be reified because the reference is no longer valid (i.e. it's + dangling). *) + let get_other_ref_events maybe_ref = + if is_valid_ref db maybe_ref then + let self = Schema.Value.Unsafe_cast.string maybe_ref in + let go (other_tbl, _) = + let get_record = find_get_record other_tbl ~__context ~self in + (other_tbl, self, get_record) + in + List.map go other_tbl_refs |> snapshots_of_other_tbl_refs else [] in - (* Generate event *) - let snapshot = find_get_record tblname ~__context:context ~self:objref in - let record = snapshot () in - List.iter - (function - | tbl, ref, None -> - error "Failed to send MOD event for %s %s" tbl ref ; - Printf.printf "Failed to send MOD event for %s %s\n%!" tbl ref - | tbl, ref, Some s -> - events_notify ~snapshot:s tbl "mod" ref - ) - events_old_val ; - ( match record with - | None -> - error "Failed to send MOD event for %s %s" tblname objref ; - Printf.printf "Failed to send MOD event for %s %s\n%!" tblname objref - | Some record -> - events_notify ~snapshot:record tblname "mod" objref - ) ; - List.iter - (function - | tbl, ref, None -> - error "Failed to send MOD event for %s %s" tbl ref ; - Printf.printf "Failed to send MOD event for %s %s\n%!" tbl ref - | tbl, ref, Some s -> - events_notify ~snapshot:s tbl "mod" ref - ) - events_new_val - | PreDelete (tblname, objref) -> ( - match find_get_record tblname ~__context:context ~self:objref () with - | None -> - error "Failed to generate DEL event for %s %s" tblname objref - (* Printf.printf "Failed to generate DEL event for %s %s\n%!" tblname objref; *) - | Some snapshot -> - events_notify ~snapshot tblname "del" objref - ) - | Delete (tblname, _objref, kv) -> - let other_tbl_refs = follow_references tblname in - let other_tbl_refs = - List.fold_left - (fun accu (remote_tbl, fld) -> - let fld_value = List.assoc fld kv in - if is_valid_ref fld_value then - let fld_value = Schema.Value.Unsafe_cast.string fld_value in - ( remote_tbl - , fld_value - , find_get_record remote_tbl ~__context:context ~self:fld_value - ) - :: accu - else - accu - ) - [] other_tbl_refs - in - let other_tbl_ref_events = events_of_other_tbl_refs other_tbl_refs in - List.iter - (function - | tbl, ref, None -> - error "Failed to generate MOD event on %s %s" tbl ref - (* Printf.printf "Failed to generate MOD event on %s %s\n%!" tbl ref; *) - | tbl, ref, Some s -> - events_notify ~snapshot:s tbl "mod" ref - ) - other_tbl_ref_events - | Create (tblname, new_objref, kv) -> - let snapshot = - find_get_record tblname ~__context:context ~self:new_objref - in - let other_tbl_refs = follow_references tblname in - let other_tbl_refs = - List.fold_left - (fun accu (tbl, fld) -> - let fld_value = List.assoc fld kv in - if is_valid_ref fld_value then - let fld_value = Schema.Value.Unsafe_cast.string fld_value in - ( tbl - , fld_value - , find_get_record tbl ~__context:context ~self:fld_value - ) - :: accu - else - accu - ) - [] other_tbl_refs - in - let other_tbl_events = events_of_other_tbl_refs other_tbl_refs in - ( match snapshot () with - | None -> - error "Failed to generate ADD event for %s %s" tblname new_objref - (* Printf.printf "Failed to generate ADD event for %s %s\n%!" tblname new_objref; *) - | Some snapshot -> - events_notify ~snapshot tblname "add" new_objref - ) ; - List.iter - (function - | tbl, ref, None -> - error "Failed to generate MOD event for %s %s" tbl ref - (* Printf.printf "Failed to generate MOD event for %s %s\n%!" tbl ref;*) - | tbl, ref, Some s -> - events_notify ~snapshot:s tbl "mod" ref - ) - other_tbl_events + (* Compute modify events for the old and new field values, if + either value appears to be a reference. *) + let events_old_val = get_other_ref_events oldval in + let events_new_val = get_other_ref_events newval in + (* Emit modify events for records referenced by the old row's value. *) + emit_events ~kind:Modify events_old_val ; + (* Emit a modify event for the current row. *) + let getter = find_get_record tblname ~__context ~self:objref in + let snapshot = getter () in + emit_events ~kind:Modify [(tblname, objref, snapshot)] ; + (* Emit modify events for records referenced by the new row's value. *) + emit_events ~kind:Modify events_new_val + | PreDelete (tblname, objref) -> + (* Emit a deletion event for the deleted row. *) + let getter = find_get_record tblname ~__context ~self:objref in + let snapshot = getter () in + emit_events ~kind:Delete [(tblname, objref, snapshot)] + | Delete (tblname, _objref, kvs) -> + (* Deleting a row requires similar modify events as overwriting a + field's value does. If any of the deleted cells may be a + reference, we must emit modify events for each of the related + objects. *) + compute_other_table_events tblname kvs |> emit_events ~kind:Modify + | Create (tblname, new_objref, kvs) -> + (* Emit an add event for the new object. *) + let getter = find_get_record tblname ~__context ~self:new_objref in + let snapshot = getter () in + emit_events ~kind:Add [(tblname, new_objref, snapshot)] ; + (* Emit modification events for any newly-referenced objects. *) + compute_other_table_events tblname kvs |> emit_events ~kind:Modify let database_callback event db = - let context = Context.make "eventgen" in + let __context = Context.make __MODULE__ in Xapi_stdext_pervasives.Pervasiveext.finally - (fun () -> database_callback_inner event db context) - (fun () -> Context.complete_tracing context) + (fun () -> database_callback_inner event db ~__context) + (fun () -> Context.complete_tracing __context) From cc50840312f586de3c3e7158d325a10d60a56ba3 Mon Sep 17 00:00:00 2001 From: Colin James Date: Mon, 16 Dec 2024 15:13:03 +0000 Subject: [PATCH 26/73] Add eventgen.mli Signed-off-by: Colin James --- ocaml/xapi/eventgen.mli | 25 +++++++++++++++++++++++++ quality-gate.sh | 2 +- 2 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 ocaml/xapi/eventgen.mli diff --git a/ocaml/xapi/eventgen.mli b/ocaml/xapi/eventgen.mli new file mode 100644 index 00000000000..279a43eded2 --- /dev/null +++ b/ocaml/xapi/eventgen.mli @@ -0,0 +1,25 @@ +(* + * Copyright (C) 2024 Cloud Software Group. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +type get_record = unit -> Rpc.t + +val get_record_table : + (string, __context:Context.t -> self:string -> get_record) Hashtbl.t + +open Xapi_database.Db_cache_types + +val database_callback : update -> Database.t -> unit + +val find_get_record : + string -> __context:Context.t -> self:string -> unit -> Rpc.t option diff --git a/quality-gate.sh b/quality-gate.sh index a7ffefea72b..cfef6614e00 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=497 + N=496 # do not count ml files from the tests in ocaml/{tests/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) From 4f871952d69c486a6b8b2f39830bd9f82a80905d Mon Sep 17 00:00:00 2001 From: Colin James Date: Mon, 16 Dec 2024 15:27:28 +0000 Subject: [PATCH 27/73] Hide that get_records are stored in a Hashtbl Signed-off-by: Colin James --- ocaml/idl/ocaml_backend/gen_db_actions.ml | 3 +-- ocaml/xapi/eventgen.ml | 2 ++ ocaml/xapi/eventgen.mli | 12 ++++++------ 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index 06f54f228ba..cc9a23857ee 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -411,8 +411,7 @@ let db_action api : O.Module.t = O.Let.make ~name:"_" ~params:[] ~ty:"unit" ~body: [ - Printf.sprintf "Hashtbl.add Eventgen.get_record_table \"%s\"" - obj.DT.name + Printf.sprintf "Eventgen.set_get_record \"%s\"" obj.DT.name ; Printf.sprintf "(fun ~__context ~self -> (fun () -> API.rpc_of_%s_t \ (%s.get_record ~__context ~self:(Ref.of_%sstring self))))" diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index b19be7b33e1..dfc04d944b7 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -19,6 +19,8 @@ let get_record_table : (string, __context:Context.t -> self:string -> get_record) Hashtbl.t = Hashtbl.create 64 +let set_get_record = Hashtbl.replace get_record_table + let find_get_record obj_name ~__context ~self () : Rpc.t option = Option.map (fun f -> f ~__context ~self ()) diff --git a/ocaml/xapi/eventgen.mli b/ocaml/xapi/eventgen.mli index 279a43eded2..18167241ddb 100644 --- a/ocaml/xapi/eventgen.mli +++ b/ocaml/xapi/eventgen.mli @@ -12,14 +12,14 @@ * GNU Lesser General Public License for more details. *) -type get_record = unit -> Rpc.t - -val get_record_table : - (string, __context:Context.t -> self:string -> get_record) Hashtbl.t - open Xapi_database.Db_cache_types -val database_callback : update -> Database.t -> unit +type get_record = unit -> Rpc.t + +val set_get_record : + string -> (__context:Context.t -> self:string -> get_record) -> unit val find_get_record : string -> __context:Context.t -> self:string -> unit -> Rpc.t option + +val database_callback : update -> Database.t -> unit From ed2e5021e65bc6ddf6ab23f06db2e260b8c4c161 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 17 Dec 2024 15:43:52 +0000 Subject: [PATCH 28/73] Document eventgen.mli Signed-off-by: Colin James --- ocaml/xapi/eventgen.mli | 50 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/ocaml/xapi/eventgen.mli b/ocaml/xapi/eventgen.mli index 18167241ddb..adc0d03b9bb 100644 --- a/ocaml/xapi/eventgen.mli +++ b/ocaml/xapi/eventgen.mli @@ -12,14 +12,64 @@ * GNU Lesser General Public License for more details. *) +(** Eventgen is responsible for producing events for the event APIs + ([event.next] and [event.from]) to provide to clients. + + Each update may result in many events, each with a snapshot of the + related object(s), marshalled as [Rpc.t] dictionaries. *) + open Xapi_database.Db_cache_types type get_record = unit -> Rpc.t +(* Type of the thunks used to read a record, marshalled as an [Rpc.t] + dictionary, from the database. + + In practice, such functions arise from functions provided by the + generated [Db_actions] module - which contains the logic to + serialise internal and external views of database records. + + This type is emphasised because values of this type are used as + thunks to delay evaluation, such that the actual fetching of + object snapshots can be done in an orderly way by this module, + when producing events. The closures produced by [Db_actions] + capture the relevant context and reference information to produce + a snapshot on-demand, when invoked. *) val set_get_record : string -> (__context:Context.t -> self:string -> get_record) -> unit +(** [set_get_record table accessor] is used by [Db_actions] to + register a means by which this module can read records from + database, in order to produce snapshots used by the events + mechanism. + + Upon initialisation, [Db_actions] calls [set_get_record] to + register an accessor for each object type stored in the + database. These accessors consist of logic internal to + [Db_actions] which performs all the related reading and + marshalling of values from the database. + + This function should not be called by any module other than + [Db_actions]. *) val find_get_record : string -> __context:Context.t -> self:string -> unit -> Rpc.t option +(** [find_get_record table context reference] yields a partial + function which, when invoked, attempts to read a record snapshot from + the database. Any [table] used must have already been registered + by initialisation code within [Db_actions] (i.e. from a previous + call to [set_get_record]). + + The function returns an option type as a convenience, as the + inherent delaying of the evaluation of snapshots could mean that a + record referred to by [reference] is no longer present in the + database. *) val database_callback : update -> Database.t -> unit +(** [database_call update db] notifies [Xapi_event] (indirectly) of + transitive events arising from a single logical [update] within the + database. + + Many events may follow a single [update] as referential fields, + related by the datamodel schema, may produce changes in related + objects (so, previously and newly referenced objects' snapshots + must be emitted as modification events). *) From d622dd8dd629b77c978c9d24409d5a4e3a6113d6 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 17 Dec 2024 16:16:05 +0000 Subject: [PATCH 29/73] Precompute symmetric closure table To avoid recomputing the symmetric closure several times during module initialisation for Eventgen, we introduce a hashtable that stores the relation. Signed-off-by: Colin James --- ocaml/xapi/eventgen.ml | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index dfc04d944b7..753bb8fdf7b 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -26,6 +26,24 @@ let find_get_record obj_name ~__context ~self () : Rpc.t option = (fun f -> f ~__context ~self ()) (Hashtbl.find_opt get_record_table obj_name) +(* Bidirectional lookup for relations encoded in all_relations. *) +let lookup_object_relation = + (* Precompute the symmetric closure of all_relations and store it as + a hash table. *) + let symmetric_table = + let table = Hashtbl.create 128 in + let relate = Hashtbl.replace table in + let api = Datamodel.all_api in + let close (p, p') = + (* R U= { (p, p'), (p', p) } where p, p' are of the form + (object, field) *) + relate p p' ; relate p' p + in + Dm_api.relations_of_api api |> List.iter close ; + table + in + Hashtbl.find_opt symmetric_table + (* If a record is modified, events must be emitted for related objects' records. We collect a list of related objects by querying the (Ref _)-typed fields of the input object against the relations encoded by the datamodel. @@ -37,16 +55,11 @@ let compute_object_references_to_follow (obj_name : string) = let module DT = Datamodel_types in let api = Datamodel.all_api in let obj = Dm_api.get_obj_by_name api ~objname:obj_name in - let symmetric = - (* Symmetric closure of the field relation set. *) - Dm_api.relations_of_api api - |> List.concat_map (fun (a, b) -> [(a, b); (b, a)]) - in (* Find an object related to the input field using the datamodel. *) let find_related_object = function | DT.{field_name; ty= Ref _; _} -> let this_end = (obj_name, field_name) in - List.assoc_opt this_end symmetric + lookup_object_relation this_end |> Option.map (fun (other_object, _) -> (other_object, field_name)) | _ -> None From d08c6cb8a2581726690b1eb6f78951f9a5abf1a4 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 9 Dec 2024 18:18:26 +0000 Subject: [PATCH 30/73] CA-402921: Relax VIF constraint for PVS proxy The current constraint is that the VIF used for PVS proxy must have device number 0. It turned out that this can be relaxed. It is sufficient to enforce that the VIF is the one with the lowest device number for the VM. Signed-off-by: Rob Hoes --- ocaml/idl/datamodel_errors.ml | 5 +++++ ocaml/xapi-consts/api_errors.ml | 2 ++ ocaml/xapi/xapi_pvs_proxy.ml | 15 ++++++++++++--- 3 files changed, 19 insertions(+), 3 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 80b36218f25..81f5ca9fdf3 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1818,6 +1818,11 @@ let _ = "The address specified is already in use by an existing PVS_server object" () ; + error Api_errors.pvs_vif_must_be_first_device [] + ~doc: + "The VIF used by PVS proxy must be the one with the lowest device number" + () ; + error Api_errors.usb_group_contains_vusb ["vusbs"] ~doc:"The USB group contains active VUSBs and cannot be deleted." () ; error Api_errors.usb_group_contains_pusb ["pusbs"] diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 53e9e06176b..0acf87020e3 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1246,6 +1246,8 @@ let pvs_proxy_already_present = add_error "PVS_PROXY_ALREADY_PRESENT" let pvs_server_address_in_use = add_error "PVS_SERVER_ADDRESS_IN_USE" +let pvs_vif_must_be_first_device = add_error "PVS_VIF_MUST_BE_FIRST_DEVICE" + let extension_protocol_failure = add_error "EXTENSION_PROTOCOL_FAILURE" let usb_group_contains_vusb = add_error "USB_GROUP_CONTAINS_VUSB" diff --git a/ocaml/xapi/xapi_pvs_proxy.ml b/ocaml/xapi/xapi_pvs_proxy.ml index 3f81ffc783e..5c3545952a5 100644 --- a/ocaml/xapi/xapi_pvs_proxy.ml +++ b/ocaml/xapi/xapi_pvs_proxy.ml @@ -32,9 +32,18 @@ let create ~__context ~site ~vIF = ) ; Helpers.assert_is_valid_ref ~__context ~name:"site" ~ref:site ; Helpers.assert_is_valid_ref ~__context ~name:"VIF" ~ref:vIF ; - let device = Db.VIF.get_device ~__context ~self:vIF in - if device <> "0" then - raise Api_errors.(Server_error (invalid_device, [device])) ; + let device = Db.VIF.get_device ~__context ~self:vIF |> int_of_string in + let min_device = + let open Xapi_database.Db_filter_types in + let vm = Db.VIF.get_VM ~__context ~self:vIF in + Db.VIF.get_records_where ~__context + ~expr:(Eq (Field "VM", Literal (Ref.string_of vm))) + |> List.fold_left + (fun m (_, {API.vIF_device= d; _}) -> min m (int_of_string d)) + device + in + if device <> min_device then + raise Api_errors.(Server_error (pvs_vif_must_be_first_device, [])) ; let pvs_proxy = Ref.make () in let uuid = Uuidx.(to_string (make ())) in Db.PVS_proxy.create ~__context ~ref:pvs_proxy ~uuid ~site ~vIF From 2f2ee291641bb7e281533eeb0e6905c989bc7c00 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 11 Dec 2024 16:54:52 +0000 Subject: [PATCH 31/73] CA-402921: Update PVS-proxy tests Signed-off-by: Rob Hoes --- ocaml/tests/test_pvs_proxy.ml | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/ocaml/tests/test_pvs_proxy.ml b/ocaml/tests/test_pvs_proxy.ml index 2c102c0ca32..47e41ab3c24 100644 --- a/ocaml/tests/test_pvs_proxy.ml +++ b/ocaml/tests/test_pvs_proxy.ml @@ -34,12 +34,28 @@ let test_create_ok () = "test_create_ok testing get_VIF" vIF (Db.PVS_proxy.get_VIF ~__context ~self:pvs_proxy) -let test_create_invalid_device () = +let test_create_ok_lowest_device_number () = let __context = T.make_test_database () in let site = T.make_pvs_site ~__context () in let vIF = T.make_vif ~__context ~device:"1" () in - Alcotest.check_raises "test_create_invalid_device should raise invalid_device" - Api_errors.(Server_error (invalid_device, ["1"])) + let _vIF' = T.make_vif ~__context ~device:"2" () in + let pvs_proxy = Xapi_pvs_proxy.create ~__context ~site ~vIF in + Alcotest.(check (Alcotest_comparators.ref ())) + "test_create_ok testing get_site" site + (Db.PVS_proxy.get_site ~__context ~self:pvs_proxy) ; + Alcotest.(check (Alcotest_comparators.ref ())) + "test_create_ok testing get_VIF" vIF + (Db.PVS_proxy.get_VIF ~__context ~self:pvs_proxy) + +let test_create_not_lowest_device_number () = + let __context = T.make_test_database () in + let site = T.make_pvs_site ~__context () in + let _vIF' = T.make_vif ~__context ~device:"0" () in + let vIF = T.make_vif ~__context ~device:"1" () in + Alcotest.check_raises + "test_create_not_lowest_device_number should raise \ + pvs_vif_must_be_first_device" + Api_errors.(Server_error (pvs_vif_must_be_first_device, [])) (fun () -> ignore (Xapi_pvs_proxy.create ~__context ~site ~vIF)) let test_create_invalid_site () = @@ -103,7 +119,14 @@ let test = [ ("test_unlicensed", `Quick, test_unlicensed) ; ("test_create_ok", `Quick, test_create_ok) - ; ("test_create_invalid_device", `Quick, test_create_invalid_device) + ; ( "test_create_ok_lowest_device_number" + , `Quick + , test_create_ok_lowest_device_number + ) + ; ( "test_create_not_lowest_device_number" + , `Quick + , test_create_not_lowest_device_number + ) ; ("test_create_invalid_site", `Quick, test_create_invalid_site) ; ("test_create_invalid_vif", `Quick, test_create_invalid_vif) ; ("test_destroy", `Quick, test_destroy) From 14406ba90312c595c2a75e7f07eb25b8dba66892 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 18 Dec 2024 13:15:06 +0000 Subject: [PATCH 32/73] CA-402921: Restrict VIF.create When creating a new VIF and there is already a VIF with PVS_proxy, check that the new VIF does not have a lower device number than the PVS_proxy VIF. Signed-off-by: Rob Hoes --- ocaml/idl/datamodel_errors.ml | 7 +++++++ ocaml/xapi-consts/api_errors.ml | 3 +++ ocaml/xapi/xapi_vif_helpers.ml | 37 +++++++++++++++++++++++++++++---- 3 files changed, 43 insertions(+), 4 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 81f5ca9fdf3..fed2f830db1 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1823,6 +1823,13 @@ let _ = "The VIF used by PVS proxy must be the one with the lowest device number" () ; + error Api_errors.pvs_proxy_present_on_higher_vif_device ["device"] + ~doc: + "The VM has a VIF, with a higher device number than the new VIF, that \ + uses a PVS proxy. The VIF used by PVS proxy must be the one with the \ + lowest device number." + () ; + error Api_errors.usb_group_contains_vusb ["vusbs"] ~doc:"The USB group contains active VUSBs and cannot be deleted." () ; error Api_errors.usb_group_contains_pusb ["pusbs"] diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 0acf87020e3..54bdd6f6660 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1248,6 +1248,9 @@ let pvs_server_address_in_use = add_error "PVS_SERVER_ADDRESS_IN_USE" let pvs_vif_must_be_first_device = add_error "PVS_VIF_MUST_BE_FIRST_DEVICE" +let pvs_proxy_present_on_higher_vif_device = + add_error "PVS_PROXY_PRESENT_ON_HIGHER_VIF_DEVICE" + let extension_protocol_failure = add_error "EXTENSION_PROTOCOL_FAILURE" let usb_group_contains_vusb = add_error "USB_GROUP_CONTAINS_VUSB" diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 4a469b84368..da6ede482fa 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -287,13 +287,42 @@ let create ~__context ~device ~network ~vM ~mAC ~mTU ~other_config ) ; (* Check to make sure the device is unique *) Xapi_stdext_threads.Threadext.Mutex.execute m (fun () -> - let all = Db.VM.get_VIFs ~__context ~self:vM in - let all_devices = - List.map (fun self -> Db.VIF.get_device ~__context ~self) all + let all_vifs_with_devices = + Db.VM.get_VIFs ~__context ~self:vM + |> List.map (fun self -> + (self, int_of_string (Db.VIF.get_device ~__context ~self)) + ) in - if List.mem device all_devices then + let new_device = int_of_string device in + if List.exists (fun (_, d) -> d = new_device) all_vifs_with_devices then raise (Api_errors.Server_error (Api_errors.device_already_exists, [device])) ; + + (* If the VM uses a PVS_proxy, then the proxy _must_ be associated with + the VIF that has the lowest device number. Check that the new VIF + respects this. *) + ( match all_vifs_with_devices with + | [] -> + () + | hd :: tl -> + let min_vif, min_device = + List.fold_left + (fun ((_, d) as v) ((_, d') as v') -> if d' < d then v' else v) + hd tl + in + let vm_has_pvs_proxy = + Pvs_proxy_control.find_proxy_for_vif ~__context ~vif:min_vif <> None + in + if vm_has_pvs_proxy && new_device < min_device then + raise + Api_errors.( + Server_error + ( pvs_proxy_present_on_higher_vif_device + , [Printf.sprintf "%d" min_device] + ) + ) + ) ; + let metrics = Ref.make () and metrics_uuid = Uuidx.to_string (Uuidx.make ()) in Db.VIF_metrics.create ~__context ~ref:metrics ~uuid:metrics_uuid From 819279248403e034f8e9a9e5778e852d9c5bb58b Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 18 Dec 2024 13:16:07 +0000 Subject: [PATCH 33/73] CA-402921: Add some unit tests for Xapi_vif_helpers Signed-off-by: Rob Hoes --- ocaml/tests/suite_alcotest.ml | 1 + ocaml/tests/test_vif_helpers.ml | 90 +++++++++++++++++++++++++++++++++ 2 files changed, 91 insertions(+) create mode 100644 ocaml/tests/test_vif_helpers.ml diff --git a/ocaml/tests/suite_alcotest.ml b/ocaml/tests/suite_alcotest.ml index c2e422c2379..7c425e39639 100644 --- a/ocaml/tests/suite_alcotest.ml +++ b/ocaml/tests/suite_alcotest.ml @@ -37,6 +37,7 @@ let () = ; ("Test_pvs_site", Test_pvs_site.test) ; ("Test_pvs_proxy", Test_pvs_proxy.test) ; ("Test_pvs_server", Test_pvs_server.test) + ; ("Test_vif_helpers", Test_vif_helpers.test) ; ("Test_vm_memory_constraints", Test_vm_memory_constraints.test) ; ("Test_xapi_xenops", Test_xapi_xenops.test) ; ("Test_network_event_loop", Test_network_event_loop.test) diff --git a/ocaml/tests/test_vif_helpers.ml b/ocaml/tests/test_vif_helpers.ml new file mode 100644 index 00000000000..2e92a3d7f01 --- /dev/null +++ b/ocaml/tests/test_vif_helpers.ml @@ -0,0 +1,90 @@ +(* + * Copyright (C) Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module T = Test_common + +(* Function under test *) +let create ~__context ~device ~network ~vM ?(mAC = "00:00:00:00:00:00") + ?(mTU = 1500L) ?(qos_algorithm_type = "") ?(qos_algorithm_params = []) + ?(currently_attached = false) ?(other_config = []) + ?(locking_mode = `unlocked) ?(ipv4_allowed = []) ?(ipv6_allowed = []) + ?(ipv4_configuration_mode = `None) ?(ipv4_addresses = []) + ?(ipv4_gateway = "") ?(ipv6_configuration_mode = `None) + ?(ipv6_addresses = []) ?(ipv6_gateway = "") () = + Xapi_vif_helpers.create ~__context ~device ~network ~vM ~mAC ~mTU + ~other_config ~qos_algorithm_type ~qos_algorithm_params ~currently_attached + ~locking_mode ~ipv4_allowed ~ipv6_allowed ~ipv4_configuration_mode + ~ipv4_addresses ~ipv4_gateway ~ipv6_configuration_mode ~ipv6_addresses + ~ipv6_gateway + +let test_create_ok () = + let __context = T.make_test_database () in + let vM = T.make_vm ~__context () in + let network = T.make_network ~__context () in + let vif = create ~__context ~device:"0" ~network ~vM () in + Alcotest.(check (Alcotest_comparators.ref ())) + "test_create_ok testing get_VM" vM + (Db.VIF.get_VM ~__context ~self:vif) + +let test_create_duplicate_device () = + let __context = T.make_test_database () in + let vM = T.make_vm ~__context () in + let network = T.make_network ~__context () in + let _vif0 = T.make_vif ~__context ~device:"0" ~vM ~network () in + Alcotest.check_raises + "test_create_duplicate_device should raise device_already_exists" + Api_errors.(Server_error (device_already_exists, ["0"])) + @@ fun () -> + let _ = create ~__context ~device:"0" ~network ~vM () in + () + +let test_create_with_pvs_proxy_ok () = + let __context = T.make_test_database () in + let vM = T.make_vm ~__context () in + let network = T.make_network ~__context () in + let vIF = T.make_vif ~__context ~device:"0" ~vM ~network () in + let _vIF2 = T.make_vif ~__context ~device:"2" ~vM ~network () in + let site = T.make_pvs_site ~__context () in + let _pvs_proxy = T.make_pvs_proxy ~__context ~site ~vIF () in + let vif1 = create ~__context ~device:"1" ~network ~vM () in + Alcotest.(check (Alcotest_comparators.ref ())) + "test_create_with_pvs_proxy_ok testing get_VM" vM + (Db.VIF.get_VM ~__context ~self:vif1) + +let test_create_with_pvs_proxy_not_ok () = + let __context = T.make_test_database () in + let vM = T.make_vm ~__context () in + let network = T.make_network ~__context () in + let vIF = T.make_vif ~__context ~device:"1" ~vM ~network () in + let _vIF2 = T.make_vif ~__context ~device:"2" ~vM ~network () in + let site = T.make_pvs_site ~__context () in + let _pvs_proxy = T.make_pvs_proxy ~__context ~site ~vIF () in + Alcotest.check_raises + "test_create_with_pvs_proxy_not_ok should raise \ + pvs_proxy_present_on_higher_vif_device" + Api_errors.(Server_error (pvs_proxy_present_on_higher_vif_device, ["1"])) + @@ fun () -> + let _ = create ~__context ~device:"0" ~network ~vM () in + () + +let test = + [ + ("test_create_ok", `Quick, test_create_ok) + ; ("test_create_duplicate_device", `Quick, test_create_duplicate_device) + ; ("test_create_with_pvs_proxy_ok", `Quick, test_create_with_pvs_proxy_ok) + ; ( "test_create_with_pvs_proxy_not_ok" + , `Quick + , test_create_with_pvs_proxy_not_ok + ) + ] From e8bde26fe9f9fd35a110723b47c425bae28bca20 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 18 Dec 2024 11:21:56 +0000 Subject: [PATCH 34/73] CA-403422: lengthen the timeout for xenopsd's serialized tasks Historically parallel operations were run in tasks as part of serial operations, and serial tasks were not run as part of parallel ones. This changed recently, causing some timeouts that did not happen before. To mitigate this issue, now the timeouts for tasks are 20 minutes per single serialized operation, instead of 20 minutes per task. Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/lib/xenops_server.ml | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index f4c784faa11..e3f5c48f890 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -278,6 +278,15 @@ let rec name_of_atomic = function | Best_effort atomic -> Printf.sprintf "Best_effort (%s)" (name_of_atomic atomic) +let rec atomic_expires_after = function + | Serial (_, _, ops) -> + List.map atomic_expires_after ops |> List.fold_left ( +. ) 0. + | Parallel (_, _, ops) -> + List.map atomic_expires_after ops |> List.fold_left Float.max 0. + | _ -> + (* 20 minutes, in seconds *) + 1200. + type vm_migrate_op = { vmm_id: Vm.id ; vmm_vdi_map: (string * string) list @@ -2341,16 +2350,17 @@ and queue_atomics_and_wait ~progress_callback ~max_parallel_atoms dbg id ops = let atom_id = Printf.sprintf "%s.chunk=%d.atom=%d" id chunk_idx atom_idx in - queue_atomic_int ~progress_callback dbg atom_id op + (queue_atomic_int ~progress_callback dbg atom_id op, op) ) ops in let timeout_start = Unix.gettimeofday () in List.map - (fun task -> + (fun (task, op) -> let task_id = Xenops_task.id_of_handle task in + let expiration = atomic_expires_after op in let completion = - event_wait updates task ~from ~timeout_start 1200.0 + event_wait updates task ~from ~timeout_start expiration (is_task task_id) task_ended in (task_id, task, completion) From a899232032e5b181582bac1293681aa003923525 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 19 Dec 2024 10:49:35 +0000 Subject: [PATCH 35/73] xenopsd: remove unused subtask parameter Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/lib/xenops_server.ml | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index e3f5c48f890..e3f0a77f5e8 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -1857,7 +1857,7 @@ let with_tracing ~name ~task f = warn "Failed to start tracing: %s" (Printexc.to_string e) ; f () -let rec perform_atomic ~progress_callback ?subtask:_ ?result (op : atomic) +let rec perform_atomic ~progress_callback ?result (op : atomic) (t : Xenops_task.task_handle) : unit = let module B = (val get_backend () : S) in with_tracing ~name:(name_of_atomic op) ~task:t @@ fun () -> @@ -2396,7 +2396,7 @@ let perform_atomics atomics t = progress_callback progress (weight /. total_weight) t in debug "Performing: %s" (string_of_atomic x) ; - perform_atomic ~subtask:(string_of_atomic x) ~progress_callback x t ; + perform_atomic ~progress_callback x t ; progress_callback 1. ; progress +. (weight /. total_weight) ) @@ -2530,8 +2530,7 @@ and trigger_cleanup_after_failure_atom op t = | VM_import_metadata _ -> () -and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) - : unit = +and perform_exn ?result (op : operation) (t : Xenops_task.task_handle) : unit = let module B = (val get_backend () : S) in with_tracing ~name:(name_of_operation op) ~task:t @@ fun () -> match op with @@ -2658,9 +2657,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) (id, vm.Vm.memory_dynamic_min, vm.Vm.memory_dynamic_min) in let (_ : unit) = - perform_atomic ~subtask:(string_of_atomic atomic) - ~progress_callback:(fun _ -> ()) - atomic t + perform_atomic ~progress_callback:(fun _ -> ()) atomic t in (* Waiting here is not essential but adds a degree of safety and reducess unnecessary memory copying. *) @@ -3172,7 +3169,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) VUSB_DB.signal id | Atomic op -> let progress_callback = progress_callback 0. 1. t in - perform_atomic ~progress_callback ?subtask ?result op t + perform_atomic ~progress_callback ?result op t and verify_power_state op = let module B = (val get_backend () : S) in @@ -3201,7 +3198,7 @@ and perform ?subtask ?result (op : operation) (t : Xenops_task.task_handle) : unit = let one op = verify_power_state op ; - try perform_exn ?subtask ?result op t + try perform_exn ?result op t with e -> Backtrace.is_important e ; info "Caught %s executing %s: triggering cleanup actions" From ac2255bdc44157af456a4f944e2c653cf715160c Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Thu, 19 Dec 2024 14:55:06 +0000 Subject: [PATCH 36/73] XSI-1773 improve logging if service file unexpectedly exists We have seen failures where a service file unexpectedly exists. It could have been left behind but a failed stop but we don't have evidence for that. To help with this, provide more details of the file found. Signed-off-by: Christian Lindig --- ocaml/forkexecd/lib/dune | 1 + ocaml/forkexecd/lib/fe_systemctl.ml | 24 +++++++++++++++++++----- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index 749f173b977..e8dd8c8312e 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -13,6 +13,7 @@ xapi-log xapi-stdext-pervasives xapi-stdext-unix + xapi-stdext-date xapi-tracing ) (preprocess (per_module ((pps ppx_deriving_rpc) Fe)))) diff --git a/ocaml/forkexecd/lib/fe_systemctl.ml b/ocaml/forkexecd/lib/fe_systemctl.ml index b36ee6674ae..046396002ca 100644 --- a/ocaml/forkexecd/lib/fe_systemctl.ml +++ b/ocaml/forkexecd/lib/fe_systemctl.ml @@ -130,14 +130,28 @@ let is_active ~service = in Unix.WEXITED 0 = status -let exists ~service = - Sys.file_exists (Filename.concat run_path (service ^ ".service")) +(** path to service file *) +let path service = Filename.concat run_path (service ^ ".service") + +(** does [service] file exist *) +let exists ~service = Sys.file_exists (path service) + +(** creation time of [path] as a string *) +let ctime path = + let ctime = Unix.((stat path).st_ctime) in + Xapi_stdext_date.Date.(of_unix_time ctime |> to_rfc3339) let start_transient ?env ?properties ?(exec_ty = Type.Simple) ~service cmd args = - if exists ~service then - (* this can only happen if there is a bug in the caller *) - invalid_arg (Printf.sprintf "Tried to start %s twice" service) ; + ( match exists ~service with + | true -> + (* this can only happen if there is a bug in the caller *) + let path = path service in + let invalid fmt = Printf.ksprintf invalid_arg fmt in + invalid "Tried to start %s twice: %s exists (%s)" service path (ctime path) + | false -> + () + ) ; try start_transient ?env ?properties ~exec_ty ~service cmd args with e -> Backtrace.is_important e ; From 3d394e0e4cbf317cbe126c25aed19732008fbf8b Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Fri, 20 Dec 2024 11:31:11 +0000 Subject: [PATCH 37/73] XSI-1773 clean up swtpm service files We have seen swtpm systemd service files not being removed. We now call Fe_systemctl.stop even when the servive is potentially not running to ensure clean up is happening regardless. Signed-off-by: Christian Lindig --- ocaml/xenopsd/xc/service.ml | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/ocaml/xenopsd/xc/service.ml b/ocaml/xenopsd/xc/service.ml index 0fabf791888..98c942d13a9 100644 --- a/ocaml/xenopsd/xc/service.ml +++ b/ocaml/xenopsd/xc/service.ml @@ -608,26 +608,17 @@ module SystemdDaemonMgmt (D : DAEMONPIDPATH) = struct else None - let is_running ~xs domid = - match of_domid domid with - | None -> - Compat.is_running ~xs domid - | Some key -> - Fe_systemctl.is_active ~service:key - let stop ~xs domid = - match (of_domid domid, is_running ~xs domid) with - | None, true -> + match of_domid domid with + | None when Compat.is_running ~xs domid -> Compat.stop ~xs domid - | Some service, true -> - (* xenstore cleanup is done by systemd unit file *) - let (_ : Fe_systemctl.status) = Fe_systemctl.stop ~service in - () - | Some service, false -> - info "Not trying to stop %s since it's not running" service - | None, false -> + | None -> info "Not trying to stop %s for domid %i since it's not running" D.name domid + | Some service -> + (* call even when not running for clean up *) + let (_ : Fe_systemctl.status) = Fe_systemctl.stop ~service in + () let start_daemon ~path ~args ~domid () = debug "Starting daemon: %s with args [%s]" path (String.concat "; " args) ; From 4394f84bc43484b79c97b9d3ff38a81b506504f6 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 23 Dec 2024 10:50:31 +0000 Subject: [PATCH 38/73] CA-404020: Do not fail when removing a non-existing datasource The latest changes in the metrics daemon changes how archived and live metrics are synchronised, and archived sources are created less often. This meant that on some cases, like SR.forget, the operations failed because they could query for existing sources, but the call to remove them failed, because the metrics only exist in live form, not archived one. (what happens with the live one, do they disappear when the SR is forgotten?) Signed-off-by: Pau Ruiz Safont --- ocaml/libs/xapi-rrd/lib/rrd.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index c9d646345cd..744544693a8 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -632,13 +632,14 @@ let rrd_add_ds rrd timestamp newds = else rrd_add_ds_unsafe rrd timestamp newds -(** Remove the named DS from an RRD. Removes all of the data associated with it, too *) +(** Remove the named DS from an RRD. Removes all of the data associated with + it, too. THe function is idempotent. *) let rrd_remove_ds rrd ds_name = let n = Utils.array_index ds_name (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) in if n = -1 then - raise (Invalid_data_source ds_name) + rrd else { rrd with From 74fe42714afdad7a1c7e511edddd948ca763cb78 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 23 Dec 2024 11:34:01 +0000 Subject: [PATCH 39/73] rrd/lib: remove outdated functions from utils Also removes some traversals when reading from XML data Signed-off-by: Pau Ruiz Safont --- ocaml/libs/xapi-rrd/lib/rrd.ml | 105 +++++++++++++-------------- ocaml/libs/xapi-rrd/lib/rrd_utils.ml | 25 +------ 2 files changed, 53 insertions(+), 77 deletions(-) diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index 744544693a8..d68de77909a 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -635,26 +635,24 @@ let rrd_add_ds rrd timestamp newds = (** Remove the named DS from an RRD. Removes all of the data associated with it, too. THe function is idempotent. *) let rrd_remove_ds rrd ds_name = - let n = - Utils.array_index ds_name (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) - in - if n = -1 then - rrd - else - { - rrd with - rrd_dss= Utils.array_remove n rrd.rrd_dss - ; rrd_rras= - Array.map - (fun rra -> - { - rra with - rra_data= Utils.array_remove n rra.rra_data - ; rra_cdps= Utils.array_remove n rra.rra_cdps - } - ) - rrd.rrd_rras - } + match Utils.find_index (fun ds -> ds.ds_name = ds_name) rrd.rrd_dss with + | None -> + rrd + | Some n -> + { + rrd with + rrd_dss= Utils.array_remove n rrd.rrd_dss + ; rrd_rras= + Array.map + (fun rra -> + { + rra with + rra_data= Utils.array_remove n rra.rra_data + ; rra_cdps= Utils.array_remove n rra.rra_cdps + } + ) + rrd.rrd_rras + } (** Find the RRA with a particular CF that contains a particular start time, and also has a minimum pdp_cnt. If it can't find an @@ -699,18 +697,17 @@ let find_best_rras rrd pdp_interval cf start = List.filter (contains_time newstarttime) rras let query_named_ds rrd as_of_time ds_name cf = - let n = - Utils.array_index ds_name (Array.map (fun ds -> ds.ds_name) rrd.rrd_dss) - in - if n = -1 then - raise (Invalid_data_source ds_name) - else - let rras = find_best_rras rrd 0 (Some cf) (Int64.of_float as_of_time) in - match rras with - | [] -> - raise No_RRA_Available - | rra :: _ -> - Fring.peek rra.rra_data.(n) 0 + match Utils.find_index (fun ds -> ds.ds_name = ds_name) rrd.rrd_dss with + | None -> + raise (Invalid_data_source ds_name) + | Some n -> ( + let rras = find_best_rras rrd 0 (Some cf) (Int64.of_float as_of_time) in + match rras with + | [] -> + raise No_RRA_Available + | rra :: _ -> + Fring.peek rra.rra_data.(n) 0 + ) (******************************************************************************) (* Marshalling/Unmarshalling functions *) @@ -877,30 +874,26 @@ let from_xml input = (* Purge any repeated data sources from the RRD *) let ds_names = ds_names rrd in - let ds_names_set = Utils.setify ds_names in - let ds_name_counts = - List.map - (fun name -> - let x, _ = List.partition (( = ) name) ds_names in - (name, List.length x) - ) - ds_names_set - in - let removals_required = - List.filter (fun (_, x) -> x > 1) ds_name_counts - in - List.fold_left - (fun rrd (name, n) -> - (* Remove n-1 lots of this data source *) - let rec inner rrd n = - if n = 1 then - rrd - else - inner (rrd_remove_ds rrd name) (n - 1) - in - inner rrd n - ) - rrd removals_required + List.sort_uniq String.compare ds_names + |> List.filter_map (fun name -> + match List.filter (String.equal name) ds_names with + | [] | [_] -> + None + | x -> + Some (name, List.length x) + ) + |> List.fold_left + (fun rrd (name, n) -> + (* Remove n-1 lots of this data source *) + let rec inner rrd n = + if n = 1 then + rrd + else + inner (rrd_remove_ds rrd name) (n - 1) + in + inner rrd n + ) + rrd ) input diff --git a/ocaml/libs/xapi-rrd/lib/rrd_utils.ml b/ocaml/libs/xapi-rrd/lib/rrd_utils.ml index c0863d0175f..aa959a042dd 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd_utils.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd_utils.ml @@ -47,13 +47,13 @@ end let isnan x = match classify_float x with FP_nan -> true | _ -> false -let array_index e a = +let find_index f a = let len = Array.length a in let rec check i = if len <= i then - -1 - else if a.(i) = e then - i + None + else if f a.(i) then + Some i else check (i + 1) in @@ -62,23 +62,6 @@ let array_index e a = let array_remove n a = Array.append (Array.sub a 0 n) (Array.sub a (n + 1) (Array.length a - n - 1)) -let filter_map f list = - let rec inner acc l = - match l with - | [] -> - List.rev acc - | x :: xs -> - let acc = match f x with Some res -> res :: acc | None -> acc in - inner acc xs - in - inner [] list - -let rec setify = function - | [] -> - [] - | x :: xs -> - if List.mem x xs then setify xs else x :: setify xs - (** C# and JS representation of special floats are 'NaN' and 'Infinity' which are different from ocaml's native representation. Caml is fortunately more forgiving when doing a float_of_string, and can cope with these forms, so From e4e20ad93fcebfcde5f6fb32a471a87661ebb4e1 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 23 Dec 2024 15:50:23 +0000 Subject: [PATCH 40/73] rrdd: add more comments about its datastructures Signed-off-by: Pau Ruiz Safont --- ocaml/libs/xapi-rrd/lib/rrd.ml | 6 +++--- ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml | 10 +++++----- ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml | 2 +- ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml | 9 ++++++--- 4 files changed, 15 insertions(+), 12 deletions(-) diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index d68de77909a..75610964fc1 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -621,9 +621,9 @@ let rrd_add_ds_unsafe rrd timestamp newds = rrd.rrd_rras } -(** Add in a new DS into a pre-existing RRD. Preserves data of all the other archives - and fills the new one full of NaNs. Note that this doesn't fill in the CDP values - correctly at the moment! +(** Add in a new DS into a pre-existing RRD. Preserves data of all the other + archives and fills the new one full of NaNs. Note that this doesn't fill + in the CDP values correctly at the moment! *) let rrd_add_ds rrd timestamp newds = diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index c46a33d6f96..3decd260673 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml @@ -51,10 +51,10 @@ let merge_new_dss rrdi dss = !Rrdd_shared.enable_all_dss || ds.ds_default in let default_dss = StringMap.filter should_enable_ds dss in - (* NOTE: It's enough to check if all the default datasources have been added - to the RRD_INFO, because if a non-default one has been enabled at runtime, - it's added to the RRD immediately and we don't need to bother *) - let new_dss = + (* NOTE: Only add enabled dss to the live rrd, ignoring non-default ones. + This is because non-default ones are added to the RRD when they are + enabled. *) + let new_enabled_dss = StringMap.filter (fun ds_name _ -> not (StringMap.mem ds_name rrdi.dss)) default_dss @@ -73,7 +73,7 @@ let merge_new_dss rrdi dss = rrd_add_ds_unsafe rrd timestamp (Rrd.ds_create ds.ds_name ds.Ds.ds_type ~mrhb:300.0 Rrd.VT_Unknown) ) - new_dss rrdi.rrd + new_enabled_dss rrdi.rrd ) module OwnerMap = Map.Make (struct diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index f8f3c99bf8b..d9d41114e00 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -347,7 +347,7 @@ let send_host_rrd_to_master master_address = let fail_missing name = raise (Rrdd_error (Datasource_missing name)) (** {add_ds rrdi ds_name} creates a new time series (rrd) in {rrdi} with the - name {ds_name}. The operation fails if rrdi does not contain any live + name {ds_name}. The operation fails if rrdi does not contain any datasource with the name {ds_name} *) let add_ds ~rrdi ~ds_name = match Rrd.StringMap.find_opt ds_name rrdi.dss with diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml index 08807e39b74..883f9844cb5 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_shared.ml @@ -77,10 +77,13 @@ let mutex = Mutex.create () type rrd_info = { rrd: Rrd.rrd + (** Contains the live metrics, i.e. The datasources that are enabled + and being collected .*) ; mutable dss: (float * Ds.ds) Rrd.StringMap.t - (* Important: this must contain the entire list of datasources associated - with the RRD, even the ones disabled by default, as rrd_add_ds calls - can enable DSs at runtime *) + (** Important: this must contain the entire list of datasources + associated with the RRD, even the ones disabled by default, because + functions like rrd_add_ds or rrd_remove_ds expect disabled + datasources to be present. e.g. to enable DSs at runtime *) ; mutable domid: int } From 87013f1d074dd7aa5c82a1d68f62be8e1faa43b0 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 12 Oct 2022 13:44:46 +0100 Subject: [PATCH 41/73] CA-364194: use timespans for script timeouts This has two advantages: 1. Always non-negative: they represent absolute differences in time 2. Forces users to define the units of time, allowing to read the time in minutes, when appropriate Signed-off-by: Pau Ruiz Safont --- ocaml/forkexecd/lib/dune | 2 ++ ocaml/forkexecd/lib/forkhelpers.ml | 19 ++++++++----- ocaml/forkexecd/lib/forkhelpers.mli | 4 +-- ocaml/forkexecd/test/dune | 2 +- ocaml/forkexecd/test/fe_test.ml | 44 +++++++++++++++++------------ ocaml/networkd/bin/dune | 3 +- ocaml/networkd/bin/networkd.ml | 10 +++++-- ocaml/networkd/lib/network_utils.ml | 8 ++++-- ocaml/xapi/helpers.ml | 2 +- ocaml/xapi/static_vdis.ml | 4 ++- ocaml/xapi/xapi_globs.ml | 15 +++++----- ocaml/xenopsd/lib/dune | 1 + ocaml/xenopsd/lib/xenopsd.ml | 2 +- ocaml/xenopsd/xc/service.ml | 12 ++++---- 14 files changed, 77 insertions(+), 51 deletions(-) diff --git a/ocaml/forkexecd/lib/dune b/ocaml/forkexecd/lib/dune index e8dd8c8312e..662223770f4 100644 --- a/ocaml/forkexecd/lib/dune +++ b/ocaml/forkexecd/lib/dune @@ -4,7 +4,9 @@ (wrapped false) (libraries astring + clock fd-send-recv + mtime rpclib.core rpclib.json rpclib.xml diff --git a/ocaml/forkexecd/lib/forkhelpers.ml b/ocaml/forkexecd/lib/forkhelpers.ml index 7b7fc0b2247..2407b86b924 100644 --- a/ocaml/forkexecd/lib/forkhelpers.ml +++ b/ocaml/forkexecd/lib/forkhelpers.ml @@ -315,8 +315,8 @@ let safe_close_and_exec ?tracing ?env stdin stdout stderr close_fds let execute_command_get_output_inner ?tracing ?env ?stdin - ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) - ?(timeout = -1.0) cmd args = + ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) timeout + cmd args = let to_close = ref [] in let close fd = if List.mem fd !to_close then ( @@ -354,8 +354,13 @@ let execute_command_get_output_inner ?tracing ?env ?stdin close wr ) stdinandpipes ; - if timeout > 0. then - Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout ; + ( match timeout with + | Some span -> + let timeout = Clock.Timer.span_to_s span in + Unix.setsockopt_float sock Unix.SO_RCVTIMEO timeout + | None -> + () + ) ; with_tracing ~tracing ~name:"Forkhelpers.waitpid" @@ fun _ -> try waitpid (sock, pid) with Unix.(Unix_error ((EAGAIN | EWOULDBLOCK), _, _)) -> @@ -380,12 +385,12 @@ let execute_command_get_output_inner ?tracing ?env ?stdin let execute_command_get_output ?tracing ?env ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) ?timeout cmd args = with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> - execute_command_get_output_inner ?tracing ?env ?stdin:None ?timeout - ~syslog_stdout ~redirect_stderr_to_stdout cmd args + execute_command_get_output_inner ?tracing ?env ?stdin:None ~syslog_stdout + ~redirect_stderr_to_stdout timeout cmd args let execute_command_get_output_send_stdin ?tracing ?env ?(syslog_stdout = NoSyslogging) ?(redirect_stderr_to_stdout = false) ?timeout cmd args stdin = with_tracing ~tracing ~name:__FUNCTION__ @@ fun tracing -> execute_command_get_output_inner ?tracing ?env ~stdin ~syslog_stdout - ~redirect_stderr_to_stdout ?timeout cmd args + ~redirect_stderr_to_stdout timeout cmd args diff --git a/ocaml/forkexecd/lib/forkhelpers.mli b/ocaml/forkexecd/lib/forkhelpers.mli index a91afa52a87..b98a03ef5e0 100644 --- a/ocaml/forkexecd/lib/forkhelpers.mli +++ b/ocaml/forkexecd/lib/forkhelpers.mli @@ -48,7 +48,7 @@ val execute_command_get_output : -> ?env:string array -> ?syslog_stdout:syslog_stdout -> ?redirect_stderr_to_stdout:bool - -> ?timeout:float + -> ?timeout:Mtime.Span.t -> string -> string list -> string * string @@ -61,7 +61,7 @@ val execute_command_get_output_send_stdin : -> ?env:string array -> ?syslog_stdout:syslog_stdout -> ?redirect_stderr_to_stdout:bool - -> ?timeout:float + -> ?timeout:Mtime.Span.t -> string -> string list -> string diff --git a/ocaml/forkexecd/test/dune b/ocaml/forkexecd/test/dune index 7ab49f0e214..91c90e64188 100644 --- a/ocaml/forkexecd/test/dune +++ b/ocaml/forkexecd/test/dune @@ -1,7 +1,7 @@ (executable (modes exe) (name fe_test) - (libraries forkexec uuid xapi-stdext-unix fd-send-recv)) + (libraries fmt forkexec mtime clock mtime.clock.os uuid xapi-stdext-unix fd-send-recv)) (rule (alias runtest) diff --git a/ocaml/forkexecd/test/fe_test.ml b/ocaml/forkexecd/test/fe_test.ml index 870ac591601..57455ed5dc4 100644 --- a/ocaml/forkexecd/test/fe_test.ml +++ b/ocaml/forkexecd/test/fe_test.ml @@ -115,12 +115,6 @@ let one fds x = :: string_of_int (fds - (x.max_extra - number_of_extra)) :: shuffle cmdline_names in - (* Printf.fprintf stderr "stdin = %s\n" (if x.stdin then "Some" else "None"); - Printf.fprintf stderr "stdout = %s\n" (if x.stdout then "Some" else "None"); - Printf.fprintf stderr "stderr = %s\n" (if x.stderr then "Some" else "None"); - List.iter (fun (uuid, _) -> Printf.fprintf stderr "uuid %s -> stdin\n" uuid) table; - Printf.fprintf stderr "%s %s\n" exe (String.concat " " args); - *) Forkhelpers.waitpid_fail_if_bad_exit (Forkhelpers.safe_close_and_exec (if x.stdin then Some fd else None) @@ -129,26 +123,43 @@ let one fds x = table exe args ) +type in_range = In_range | Longer | Shorter + +let in_range ~e:leeway ~around span = + let upper = Mtime.Span.add around leeway in + if Clock.Timer.span_is_shorter ~than:around span then + Shorter + else if Clock.Timer.span_is_longer ~than:upper span then + Longer + else + In_range + let test_delay () = - let start = Unix.gettimeofday () in + let start = Mtime_clock.counter () in let args = ["sleep"] in (* Need to have fractional part because some internal usage split integer and fractional and do computation. Better to have a high fractional part (> 0.5) to more probably exceed the unit. *) - let timeout = 1.7 in + let timeout = Mtime.Span.(1700 * ms) in try Forkhelpers.execute_command_get_output ~timeout exe args |> ignore ; fail "Failed to timeout" with - | Forkhelpers.Subprocess_timeout -> - let elapsed = Unix.gettimeofday () -. start in - Printf.printf "Caught timeout exception after %f seconds\n%!" elapsed ; - if elapsed < timeout then - failwith "Process exited too soon" ; - if elapsed > timeout +. 0.2 then - failwith "Excessive time elapsed" + | Forkhelpers.Subprocess_timeout -> ( + let elapsed = Mtime_clock.count start in + Printf.printf "Caught timeout exception after %s seconds\n%!" + Fmt.(to_to_string Mtime.Span.pp elapsed) ; + + match in_range ~e:Mtime.Span.(200 * ms) ~around:timeout elapsed with + | In_range -> + () + | Shorter -> + failwith "Process exited too soon" + | Longer -> + failwith "Process took too long to exit" + ) | e -> fail "Failed with unexpected exception: %s" (Printexc.to_string e) @@ -289,9 +300,6 @@ let slave = function ) fds ; (* Check that we have the expected number *) - (* - Printf.fprintf stderr "%s %d\n" total_fds (List.length present - 1) - *) if total_fds <> List.length filtered then fail "Expected %d fds; /proc/self/fd has %d: %s" total_fds (List.length filtered) ls diff --git a/ocaml/networkd/bin/dune b/ocaml/networkd/bin/dune index 9d755a10e37..be140076b58 100644 --- a/ocaml/networkd/bin/dune +++ b/ocaml/networkd/bin/dune @@ -14,10 +14,11 @@ (modes exe) (libraries astring - + clock forkexec http_lib integers + mtime netlink networklibs rpclib.core diff --git a/ocaml/networkd/bin/networkd.ml b/ocaml/networkd/bin/networkd.ml index 3b3163a8a7a..bd4b813f6c9 100644 --- a/ocaml/networkd/bin/networkd.ml +++ b/ocaml/networkd/bin/networkd.ml @@ -105,8 +105,14 @@ let options = , "Path to the Unix command dracut" ) ; ( "dracut-timeout" - , Arg.Set_float Network_utils.dracut_timeout - , (fun () -> string_of_float !Network_utils.dracut_timeout) + , Arg.Float + (fun x -> + let x = Float.to_int (x *. 1000.) in + Network_utils.dracut_timeout := Mtime.Span.(x * ms) + ) + , (fun () -> + Float.to_string (Clock.Timer.span_to_s !Network_utils.dracut_timeout) + ) , "Default value for the dracut command timeout" ) ; ( "modinfo-cmd-path" diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 4a473b29579..5a135e55084 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -67,7 +67,7 @@ let dracut = ref "/sbin/dracut" let modinfo = ref "/sbin/modinfo" -let dracut_timeout = ref 180.0 +let dracut_timeout = ref Mtime.Span.(3 * min) let fcoedriver = ref "/opt/xensource/libexec/fcoe_driver" @@ -128,7 +128,8 @@ let check_n_run ?(on_error = default_error_handler) ?(log = true) run_func | Forkhelpers.Spawn_internal_error (stderr, stdout, status) -> on_error script args stdout stderr status -let call_script ?(timeout = Some 60.0) ?on_error ?log script args = +let call_script ?(timeout = Some Mtime.Span.(1 * min)) ?on_error ?log script + args = let call_script_internal env script args = let out, _err = Forkhelpers.execute_command_get_output ~env ?timeout script args @@ -1064,7 +1065,8 @@ end = struct end module Fcoe = struct - let call ?log args = call_script ?log ~timeout:(Some 10.0) !fcoedriver args + let call ?log args = + call_script ?log ~timeout:(Some Mtime.Span.(10 * s)) !fcoedriver args let get_capabilities name = try diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 68368754e72..68dde2a1c48 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -71,7 +71,7 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = | None -> "without a timeout" | Some t -> - Printf.sprintf "with a timeout of %.3f seconds" t + Fmt.str "with a timeout of %a" Mtime.Span.pp t in debug "about to call script %s: %s %s" timeout_msg script (String.concat " " (filter_args args)) ; diff --git a/ocaml/xapi/static_vdis.ml b/ocaml/xapi/static_vdis.ml index 049708e9c71..2197ac559a5 100644 --- a/ocaml/xapi/static_vdis.ml +++ b/ocaml/xapi/static_vdis.ml @@ -37,7 +37,9 @@ let permanent_vdi_attach ~__context ~vdi ~reason = ) ) ; ignore - (Helpers.call_script ~timeout:60.0 !Xapi_globs.static_vdis + (Helpers.call_script + ~timeout:Mtime.Span.(1 * min) + !Xapi_globs.static_vdis ["add"; Db.VDI.get_uuid ~__context ~self:vdi; reason] ) ; (* VDI will be attached on next boot; attach it now too *) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index efdcabfbdb6..2c279f6fc8d 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -994,7 +994,7 @@ let winbind_allow_kerberos_auth_fallback = ref false let winbind_keep_configuration = ref false -let winbind_ldap_query_subject_timeout = ref 20. +let winbind_ldap_query_subject_timeout = ref Mtime.Span.(20 * s) let tdb_tool = ref "/usr/bin/tdbtool" @@ -1145,7 +1145,13 @@ let xapi_globs_spec = ; ("test-open", Int test_open) (* for consistency with xenopsd *) ] -let xapi_globs_spec_with_descriptions = [] +let xapi_globs_spec_with_descriptions = + [ + ( "winbind_ldap_query_subject_timeout" + , ShortDurationFromSeconds winbind_ldap_query_subject_timeout + , "Timeout to perform ldap query for subject information" + ) + ] let option_of_xapi_globs_spec ?(description = None) (name, ty) = let spec = @@ -1466,11 +1472,6 @@ let other_options = , "Whether to clear winbind configuration when join domain failed or leave \ domain" ) - ; ( "winbind_ldap_query_subject_timeout" - , Arg.Set_float winbind_ldap_query_subject_timeout - , (fun () -> string_of_float !winbind_ldap_query_subject_timeout) - , "Timeout to perform ldap query for subject information" - ) ; ( "hsts_max_age" , Arg.Set_int hsts_max_age , (fun () -> string_of_int !hsts_max_age) diff --git a/ocaml/xenopsd/lib/dune b/ocaml/xenopsd/lib/dune index 2810eb88ef3..f7226792549 100644 --- a/ocaml/xenopsd/lib/dune +++ b/ocaml/xenopsd/lib/dune @@ -9,6 +9,7 @@ fd-send-recv fmt forkexec + mtime re gzip zstd diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 8d3c9b75f88..a0b192e6824 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -37,7 +37,7 @@ let vgpu_ready_timeout = ref 30. let varstored_ready_timeout = ref 30. -let swtpm_ready_timeout = ref 60 +let swtpm_ready_timeout = ref Mtime.Span.(1 * min) let use_upstream_qemu = ref false diff --git a/ocaml/xenopsd/xc/service.ml b/ocaml/xenopsd/xc/service.ml index 98c942d13a9..6462852cf4a 100644 --- a/ocaml/xenopsd/xc/service.ml +++ b/ocaml/xenopsd/xc/service.ml @@ -40,7 +40,7 @@ type t = { ; exec_path: string ; pid_filename: string ; chroot: Chroot.t - ; timeout_seconds: int + ; timeout: Mtime.Span.t ; args: string list ; execute: path:string -> args:string list -> domid:Xenctrl.domid -> unit -> string @@ -180,7 +180,7 @@ let start_and_wait_for_readyness ~task ~service = Xenops_task.check_cancelling task ; - let amount = Mtime.Span.(service.timeout_seconds * s) in + let amount = service.timeout in (* wait for pidfile to appear *) Result.iter_error raise_e (wait ~amount ~service_name:syslog_key) ; @@ -797,16 +797,14 @@ module Swtpm = struct swtpm-wrapper runs as a service and getting the exact error back is difficult. *) let needs_init = check_state_needs_init task vtpm_uuid in - let timeout_seconds = !Xenopsd.swtpm_ready_timeout in + let timeout = !Xenopsd.swtpm_ready_timeout in if needs_init then ( debug "vTPM %s is empty, needs to be created" (Uuidm.to_string vtpm_uuid) ; let key = Printf.sprintf "%s-%d" (Filename.basename exec_path) domid in let _, _ = Forkhelpers.execute_command_get_output ~syslog_stdout:(Forkhelpers.Syslog_WithKey key) - ~redirect_stderr_to_stdout:true - ~timeout:(float_of_int timeout_seconds) - exec_path (args true) + ~redirect_stderr_to_stdout:true ~timeout exec_path (args true) in let state_file = Filename.concat tpm_root "tpm2-00.permall" in let state = Unixext.string_of_file state_file |> Base64.encode_exn in @@ -825,7 +823,7 @@ module Swtpm = struct ; chroot ; args= args false ; execute - ; timeout_seconds + ; timeout } in From 0e8cc2074f1fa0f39bc289cd0a3f54e0532121b8 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 27 Dec 2024 14:24:51 +0800 Subject: [PATCH 42/73] CA-404062: Wrongly restart xapi when receiving HTTP errors The xapi on a supporter host would restart when it received HTTP error from the xapi on the coordinator host. This breaks the pool.designate_new_master use case for a big pool, e.g. 64-host pool. In this case, some supporters may restart unexpectedly within the phase of committing new coordinator due to the logic above. Additionally, the purpose of this logic, explained by the error message, is not correct also. Not all HTTP errors are caused by "our master address is wrong". On the other hand, if a use case requires to restart the xapi, an more explicit logic should ensure that, instead of leveraging an implicit HTTP error code. Furhtermore, if a supporter indeed is connecting to a wrong coordinator, this should be a bug and can be recovered manually. Based on above arguments, the restarting xapi after receiving HTTP error is removed. This follows the TODO concluded in CA-36936 as well. Signed-off-by: Ming Lu --- ocaml/database/master_connection.ml | 115 ++++++++++++++-------------- 1 file changed, 57 insertions(+), 58 deletions(-) diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index e10658d48c0..89247488820 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -204,6 +204,7 @@ let connection_timeout = ref !Db_globs.master_connection_default_timeout are exceeded *) let restart_on_connection_timeout = ref true + exception Content_length_required let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : @@ -221,6 +222,59 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : else if !backoff_delay > 256.0 then backoff_delay := 256.0 in + let reconnect () = + (* RPC failed - there's no way we can recover from this so try reopening connection every 2s + backoff delay *) + ( match !my_connection with + | None -> + () + | Some st_proc -> ( + my_connection := None ; + (* don't want to try closing multiple times *) + try Stunnel.disconnect st_proc with _ -> () + ) + ) ; + let time_sofar = Unix.gettimeofday () -. time_call_started in + if !connection_timeout < 0. then ( + if not !surpress_no_timeout_logs then ( + debug + "Connection to master died. I will continue to retry \ + indefinitely (supressing future logging of this message)." ; + error + "Connection to master died. I will continue to retry \ + indefinitely (supressing future logging of this message)." + ) ; + surpress_no_timeout_logs := true + ) else + debug + "Connection to master died: time taken so far in this call '%f'; \ + will %s" + time_sofar + ( if !connection_timeout < 0. then + "never timeout" + else + Printf.sprintf "timeout after '%f'" !connection_timeout + ) ; + if time_sofar > !connection_timeout && !connection_timeout >= 0. then + if !restart_on_connection_timeout then ( + debug + "Exceeded timeout for retrying master connection: restarting xapi" ; + !Db_globs.restart_fn () + ) else ( + debug + "Exceeded timeout for retrying master connection: raising \ + Cannot_connect_to_master" ; + raise Cannot_connect_to_master + ) ; + debug "Sleeping %f seconds before retrying master connection..." + !backoff_delay ; + let timed_out = Scheduler.PipeDelay.wait delay !backoff_delay in + if not timed_out then + debug "%s: Sleep interrupted, retrying master connection now" + __FUNCTION__ ; + update_backoff_delay () ; + D.log_and_ignore_exn open_secure_connection + in + while not !write_ok do try let req_string = req in @@ -266,67 +320,12 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : Db_globs.http_limit_max_rpc_size ; debug "Re-raising exception to caller." ; raise Http.Client_requested_size_over_limit - (* TODO: This http exception handler caused CA-36936 and can probably be removed now that there's backoff delay in the generic handler _ below *) | Http_client.Http_error (http_code, err_msg) -> - error - "Received HTTP error %s (%s) from master. This suggests our master \ - address is wrong. Sleeping for %.0fs and then executing restart_fn." - http_code err_msg - !Db_globs.permanent_master_failure_retry_interval ; - Thread.delay !Db_globs.permanent_master_failure_retry_interval ; - !Db_globs.restart_fn () + error "Received HTTP error %s (%s) from the coordinator" http_code err_msg ; + reconnect () | e -> error "Caught %s" (Printexc.to_string e) ; - (* RPC failed - there's no way we can recover from this so try reopening connection every 2s + backoff delay *) - ( match !my_connection with - | None -> - () - | Some st_proc -> ( - my_connection := None ; - (* don't want to try closing multiple times *) - try Stunnel.disconnect st_proc with _ -> () - ) - ) ; - let time_sofar = Unix.gettimeofday () -. time_call_started in - if !connection_timeout < 0. then ( - if not !surpress_no_timeout_logs then ( - debug - "Connection to master died. I will continue to retry \ - indefinitely (supressing future logging of this message)." ; - error - "Connection to master died. I will continue to retry \ - indefinitely (supressing future logging of this message)." - ) ; - surpress_no_timeout_logs := true - ) else - debug - "Connection to master died: time taken so far in this call '%f'; \ - will %s" - time_sofar - ( if !connection_timeout < 0. then - "never timeout" - else - Printf.sprintf "timeout after '%f'" !connection_timeout - ) ; - if time_sofar > !connection_timeout && !connection_timeout >= 0. then - if !restart_on_connection_timeout then ( - debug - "Exceeded timeout for retrying master connection: restarting xapi" ; - !Db_globs.restart_fn () - ) else ( - debug - "Exceeded timeout for retrying master connection: raising \ - Cannot_connect_to_master" ; - raise Cannot_connect_to_master - ) ; - debug "Sleeping %f seconds before retrying master connection..." - !backoff_delay ; - let timed_out = Scheduler.PipeDelay.wait delay !backoff_delay in - if not timed_out then - debug "%s: Sleep interrupted, retrying master connection now" - __FUNCTION__ ; - update_backoff_delay () ; - D.log_and_ignore_exn open_secure_connection + reconnect () done ; !result From 9a44916385b7e787d553210f5b90e4d684b860fc Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 2 Jan 2025 05:32:59 +0000 Subject: [PATCH 43/73] CA-404062: Reformat Signed-off-by: Ming Lu --- ocaml/database/master_connection.ml | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index 89247488820..ed9bfbd2826 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -204,7 +204,6 @@ let connection_timeout = ref !Db_globs.master_connection_default_timeout are exceeded *) let restart_on_connection_timeout = ref true - exception Content_length_required let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : @@ -237,17 +236,17 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : if !connection_timeout < 0. then ( if not !surpress_no_timeout_logs then ( debug - "Connection to master died. I will continue to retry \ - indefinitely (supressing future logging of this message)." ; + "Connection to master died. I will continue to retry indefinitely \ + (supressing future logging of this message)." ; error - "Connection to master died. I will continue to retry \ - indefinitely (supressing future logging of this message)." + "Connection to master died. I will continue to retry indefinitely \ + (supressing future logging of this message)." ) ; surpress_no_timeout_logs := true ) else debug - "Connection to master died: time taken so far in this call '%f'; \ - will %s" + "Connection to master died: time taken so far in this call '%f'; will \ + %s" time_sofar ( if !connection_timeout < 0. then "never timeout" @@ -256,8 +255,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : ) ; if time_sofar > !connection_timeout && !connection_timeout >= 0. then if !restart_on_connection_timeout then ( - debug - "Exceeded timeout for retrying master connection: restarting xapi" ; + debug "Exceeded timeout for retrying master connection: restarting xapi" ; !Db_globs.restart_fn () ) else ( debug @@ -269,8 +267,7 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : !backoff_delay ; let timed_out = Scheduler.PipeDelay.wait delay !backoff_delay in if not timed_out then - debug "%s: Sleep interrupted, retrying master connection now" - __FUNCTION__ ; + debug "%s: Sleep interrupted, retrying master connection now" __FUNCTION__ ; update_backoff_delay () ; D.log_and_ignore_exn open_secure_connection in @@ -321,7 +318,8 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : debug "Re-raising exception to caller." ; raise Http.Client_requested_size_over_limit | Http_client.Http_error (http_code, err_msg) -> - error "Received HTTP error %s (%s) from the coordinator" http_code err_msg ; + error "Received HTTP error %s (%s) from the coordinator" http_code + err_msg ; reconnect () | e -> error "Caught %s" (Printexc.to_string e) ; From 2fafeb7724fdf88705d22093deab50ad8f86f15c Mon Sep 17 00:00:00 2001 From: Lin Liu Date: Tue, 31 Dec 2024 08:39:41 +0000 Subject: [PATCH 44/73] CP-51895: Drop FCoE support when fcoe_driver does not exists FCoE support will be removed from XS9 and dom0 will no longer provide fcoe_driver. However, XS8 still actively support it. Xapi checks the existence of fcoe_driver, and thinks all PIFs no longer support FCoE if fcoe_driver not found Signed-off-by: Lin Liu --- ocaml/networkd/lib/network_utils.ml | 17 +++++--- ocaml/xapi/xapi_globs.ml | 11 +++--- ocaml/xapi/xapi_pif.ml | 60 ++++++++++++++++------------- 3 files changed, 51 insertions(+), 37 deletions(-) diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 4a473b29579..0cd8d4769bb 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -1067,12 +1067,17 @@ module Fcoe = struct let call ?log args = call_script ?log ~timeout:(Some 10.0) !fcoedriver args let get_capabilities name = - try - let output = call ~log:false ["--xapi"; name; "capable"] in - if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] - with _ -> - debug "Failed to get fcoe support status on device %s" name ; - [] + match Sys.file_exists !fcoedriver with + | false -> + [] (* Does not support FCoE *) + | true -> ( + try + let output = call ~log:false ["--xapi"; name; "capable"] in + if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] + with _ -> + debug "Failed to get fcoe support status on device %s" name ; + [] + ) end module Sysctl = struct diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index efdcabfbdb6..23cc4e95c39 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1689,11 +1689,6 @@ module Resources = struct ; ("xsh", xsh, "Path to xsh binary") ; ("static-vdis", static_vdis, "Path to static-vdis script") ; ("xen-cmdline-script", xen_cmdline_script, "Path to xen-cmdline script") - ; ( "fcoe-driver" - , fcoe_driver - , "Execute during PIF unplug to get the lun devices related with the \ - ether interface of the PIF" - ) ; ("list_domains", list_domains, "Path to the list_domains command") ; ("systemctl", systemctl, "Control the systemd system and service manager") ; ( "alert-certificate-check" @@ -1797,6 +1792,12 @@ module Resources = struct , "Path to yum-config-manager command" ) ; ("c_rehash", c_rehash, "Path to regenerate CA store") + (* Dropped since XS9, list here as XS8 still requires it *) + ; ( "fcoe-driver" + , fcoe_driver + , "Execute during PIF unplug to get the lun devices related with the \ + ether interface of the PIF" + ) ] let essential_files = diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index a2383ed9d9b..f52def6d8ee 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -319,33 +319,41 @@ let assert_no_other_local_pifs ~__context ~host ~network = ) let assert_fcoe_not_in_use ~__context ~self = - let interface = Db.PIF.get_device ~__context ~self in - let output, _ = - Forkhelpers.execute_command_get_output !Xapi_globs.fcoe_driver - ["-t"; interface] - in - let output = String.trim output in - debug "Scsi ids on %s are: %s" interface output ; - let fcoe_scsids = Str.split (Str.regexp " ") output in - Helpers.get_my_pbds __context - |> List.iter (fun (_, pbd_rec) -> - let sr = pbd_rec.API.pBD_SR in - match Db.SR.get_type ~__context ~self:sr with - | "lvmofcoe" -> ( - try - let scsid = List.assoc "SCSIid" pbd_rec.API.pBD_device_config in - if List.mem scsid fcoe_scsids then - raise - (Api_errors.Server_error - ( Api_errors.pif_has_fcoe_sr_in_use - , [Ref.string_of self; Ref.string_of sr] - ) - ) - with Not_found -> () + match Sys.file_exists !Xapi_globs.fcoe_driver with + | false -> + (* Does not support FCoE from XS9, presuming not in use + * Upgrade plugin will block upgrade with FCoE in use *) + () + | true -> + let interface = Db.PIF.get_device ~__context ~self in + let output, _ = + Forkhelpers.execute_command_get_output !Xapi_globs.fcoe_driver + ["-t"; interface] + in + let output = String.trim output in + debug "Scsi ids on %s are: %s" interface output ; + let fcoe_scsids = Str.split (Str.regexp " ") output in + Helpers.get_my_pbds __context + |> List.iter (fun (_, pbd_rec) -> + let sr = pbd_rec.API.pBD_SR in + match Db.SR.get_type ~__context ~self:sr with + | "lvmofcoe" -> ( + try + let scsid = + List.assoc "SCSIid" pbd_rec.API.pBD_device_config + in + if List.mem scsid fcoe_scsids then + raise + (Api_errors.Server_error + ( Api_errors.pif_has_fcoe_sr_in_use + , [Ref.string_of self; Ref.string_of sr] + ) + ) + with Not_found -> () + ) + | _ -> + () ) - | _ -> - () - ) let find_or_create_network (bridge : string) (device : string) ~managed ~__context = From e3f11da6af88b815cfcbf3cc750dbe71a20d7603 Mon Sep 17 00:00:00 2001 From: Guillaume Date: Thu, 2 Jan 2025 10:07:56 +0100 Subject: [PATCH 45/73] Report memory available as Kib This fixes #6157 Signed-off-by: Guillaume --- ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 455723633bb..bb0285b4b18 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -292,7 +292,7 @@ let dss_mem_vms doms = | Ok mem -> Some ( Rrd.VM uuid - , Ds.ds_make ~name:"memory_internal_free" ~units:"B" + , Ds.ds_make ~name:"memory_internal_free" ~units:"KiB" ~description:"Dom0 current free memory" ~value:(Rrd.VT_Int64 mem) ~ty:Rrd.Gauge ~min:0.0 ~default:true () From 75f0b41f93996d9d52fe7911844edf6f939ef161 Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Thu, 2 Jan 2025 13:46:39 +0000 Subject: [PATCH 46/73] xenopsd: Avoid calling to_string every time Minor style. "uuid" is always converted to string, avoid doing it every time it's used. Signed-off-by: Frediano Ziglio --- ocaml/xenopsd/xc/domain.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index d33fc482e5f..fce32abf19b 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -625,6 +625,7 @@ let shutdown_wait_for_ack (t : Xenops_task.task_handle) ~timeout ~xc ~xs domid (domain_type : [`pv | `pvh | `hvm]) req = let di = Xenctrl.domain_getinfo xc domid in let uuid = get_uuid ~xc domid in + let uuid = Uuidx.to_string uuid in let expecting_ack = match (di.Xenctrl.hvm_guest, domain_type) with | false, _ -> @@ -640,12 +641,12 @@ let shutdown_wait_for_ack (t : Xenops_task.task_handle) ~timeout ~xc ~xs domid debug "VM = %s; domid = %d; HVM guest without PV drivers: not expecting any \ acknowledgement" - (Uuidx.to_string uuid) domid ; + uuid domid ; Xenctrl.domain_shutdown xc domid (shutdown_to_xc_shutdown req) ) else ( debug "VM = %s; domid = %d; Waiting for domain to acknowledge shutdown request" - (Uuidx.to_string uuid) domid ; + uuid domid ; let path = control_shutdown ~xs domid in let cancel = Domain domid in if @@ -654,11 +655,10 @@ let shutdown_wait_for_ack (t : Xenops_task.task_handle) ~timeout ~xc ~xs domid [Watch.key_to_disappear path] t ~xs ~timeout () then - info "VM = %s; domid = %d; Domain acknowledged shutdown request" - (Uuidx.to_string uuid) domid - else - debug "VM = %s; domid = %d; Domain disappeared" (Uuidx.to_string uuid) + info "VM = %s; domid = %d; Domain acknowledged shutdown request" uuid domid + else + debug "VM = %s; domid = %d; Domain disappeared" uuid domid ) let sysrq ~xs domid key = From a2e04f9811d39f65b1d1294823a7f56455a49769 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 17 Dec 2024 18:00:44 +0800 Subject: [PATCH 47/73] CA-403620: Drop the usage of fuser in stunnel client proxy The drawback of fuser is that it gets too many things involved. E.g. it is observed that it got stuck on cifs kernel module. This change uses a cleaner way to remember the stunnel client proxy. Even when the xapi restarted unexpectedly, it can stop the remnant stunnel proxy and start a new one. Signed-off-by: Ming Lu --- ocaml/libs/stunnel/stunnel.ml | 58 ++++++++++++-------------------- ocaml/libs/stunnel/stunnel.mli | 3 +- ocaml/xapi/repository_helpers.ml | 7 ++-- 3 files changed, 28 insertions(+), 40 deletions(-) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 6b7d42608e7..0f5c74564c8 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -448,44 +448,30 @@ let with_connect ?unique_id ?use_fork_exec_helper ?write_to_log ~verify_cert ) 5 -let with_client_proxy ~verify_cert ~remote_host ~remote_port ~local_host - ~local_port f = - ( try - D.debug "Clean up running stunnel client proxy if there is any ..." ; - let out, _ = - Forkhelpers.execute_command_get_output "/usr/sbin/fuser" - ["-4k"; string_of_int local_port ^ "/tcp"] - in - D.debug "Killed running stunnel client proxy:%s" out - with - | Forkhelpers.Spawn_internal_error (stderr, stdout, process_status) -> ( - match process_status with - | Unix.WEXITED 1 -> - D.debug "No running stunnel client proxy" - | _ -> - D.warn - "Cleaning up running stunnel client proxy returned unexpectedly: \ - stdout=(%s); stderr=(%s)" - stdout stderr - ) - ) ; - - retry +let with_client_proxy_systemd_service ~verify_cert ~remote_host ~remote_port + ~local_host ~local_port ~service f = + let cmd_path = stunnel_path () in + let config = + config_file + ~accept:(Some (local_host, local_port)) + verify_cert remote_host remote_port + in + let stop () = ignore (Fe_systemctl.stop ~service) in + (* Try stopping anyway before starting it. *) + ignore_exn stop () ; + let conf_path, out = Filename.open_temp_file service ".conf" in + let finally = Xapi_stdext_pervasives.Pervasiveext.finally in + finally (fun () -> - let pid, _ = - attempt_one_connect - (`Local_host_port (local_host, local_port)) - verify_cert remote_host remote_port - in - D.debug "Started a client proxy (pid:%s): %s:%s -> %s:%s" - (string_of_int (getpid pid)) - local_host (string_of_int local_port) remote_host - (string_of_int remote_port) ; - Xapi_stdext_pervasives.Pervasiveext.finally - (fun () -> f ()) - (fun () -> disconnect_with_pid ~wait:false ~force:true pid) + finally (fun () -> output_string out config) (fun () -> close_out out) ; + finally + (fun () -> + Fe_systemctl.start_transient ~service cmd_path [conf_path] ; + f () + ) + (fun () -> ignore_exn stop ()) ) - 5 + (fun () -> Unixext.unlink_safe conf_path) let check_verify_error line = let sub_after i s = diff --git a/ocaml/libs/stunnel/stunnel.mli b/ocaml/libs/stunnel/stunnel.mli index eba084a9ef2..99fcba608ce 100644 --- a/ocaml/libs/stunnel/stunnel.mli +++ b/ocaml/libs/stunnel/stunnel.mli @@ -88,11 +88,12 @@ val with_moved_exn : t -> (t -> 'd) -> 'd val safe_release : t -> unit -val with_client_proxy : +val with_client_proxy_systemd_service : verify_cert:verification_config option -> remote_host:string -> remote_port:int -> local_host:string -> local_port:int + -> service:string -> (unit -> 'a) -> 'a diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 51699612739..38a46edc3bb 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -398,10 +398,11 @@ let with_local_repositories ~__context f = with Pool_role.This_host_is_a_master -> Option.get (Helpers.get_management_ip_addr ~__context) in - Stunnel.with_client_proxy ~verify_cert:(Stunnel_client.pool ()) - ~remote_host:master_addr ~remote_port:Constants.default_ssl_port - ~local_host:"127.0.0.1" + Stunnel.with_client_proxy_systemd_service + ~verify_cert:(Stunnel_client.pool ()) ~remote_host:master_addr + ~remote_port:Constants.default_ssl_port ~local_host:"127.0.0.1" ~local_port:!Xapi_globs.local_yum_repo_port + ~service:"stunnel_proxy_for_update_client" @@ fun () -> let enabled = get_enabled_repositories ~__context in Xapi_stdext_pervasives.Pervasiveext.finally From e7f2b70dfa210418c08b2bb16432f6943c370c16 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 26 Dec 2024 14:41:31 +0800 Subject: [PATCH 48/73] CA-403620: Make the stunnel proxy local port configurable Making it configurable can avoid the situation when the port conflicts with others, e.g. an external program from users. Signed-off-by: Ming Lu --- ocaml/xapi/xapi_globs.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index efdcabfbdb6..a62ba9cdb43 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1143,6 +1143,7 @@ let xapi_globs_spec = ; ("max_traces", Int max_traces) ; ("max_observer_file_size", Int max_observer_file_size) ; ("test-open", Int test_open) (* for consistency with xenopsd *) + ; ("local_yum_repo_port", Int local_yum_repo_port) ] let xapi_globs_spec_with_descriptions = [] From b245449bc885be9a2dc226fc231ab68598588d8e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 2 Jan 2025 15:45:07 +0000 Subject: [PATCH 49/73] gencert: name the pem parsers Helpful for debugging pem-parsing issues Signed-off-by: Pau Ruiz Safont --- ocaml/gencert/pem.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/ocaml/gencert/pem.ml b/ocaml/gencert/pem.ml index 436fa73e4fd..54a98875dbb 100644 --- a/ocaml/gencert/pem.ml +++ b/ocaml/gencert/pem.ml @@ -43,29 +43,31 @@ let footer = function | OTHER -> "-----END PRIVATE KEY-----" -let key_header = string "-----BEGIN" *> kind <* string "PRIVATE KEY-----" +let key_header = + string "-----BEGIN" *> kind <* string "PRIVATE KEY-----" "key_header" -let key_footer k = string (footer k) +let key_footer k = string (footer k) "key_footer" -let cert_header = string "-----BEGIN CERTIFICATE-----" +let cert_header = string "-----BEGIN CERTIFICATE-----" "cert_header" -let cert_footer = string "-----END CERTIFICATE-----" +let cert_footer = string "-----END CERTIFICATE-----" "cert_footer" let key = key_header >>= fun kind -> data >>= fun body -> key_footer kind *> return (String.concat "" [header kind; body; footer kind]) + "key" let cert = cert_header >>= fun hd -> data >>= fun body -> - cert_footer >>= fun tl -> return (String.concat "" [hd; body; tl]) + cert_footer >>= fun tl -> return (String.concat "" [hd; body; tl]) "cert" let pem = many end_of_line *> key >>= fun private_key -> many end_of_line *> cert >>= fun host_cert -> many end_of_line *> many cert >>= fun other_certs -> - many end_of_line *> return {private_key; host_cert; other_certs} + many end_of_line *> return {private_key; host_cert; other_certs} "pem" let defer f = Fun.protect ~finally:f From 2d84622f08f1c20c487e2a3132cc42d5e97fe37b Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 2 Jan 2025 15:50:44 +0000 Subject: [PATCH 50/73] CA-404236, gencert: when parsing pems, ignore data between key and certificates This is needed in order to be compliant with RFC 7468: https://datatracker.ietf.org/doc/html/rfc7468#section-2 Data before the encapsulation boundaries are permitted, and parsers MUST NOT malfunction when processing such data. Signed-off-by: Pau Ruiz Safont --- ocaml/gencert/pem.ml | 16 +++- .../pems/pass-extra-lines-multiple-certs.pem | 87 +++++++++++++++++++ .../pems/pass-extra-lines-one-cert.pem | 49 +++++++++++ 3 files changed, 149 insertions(+), 3 deletions(-) create mode 100644 ocaml/gencert/test_data/pems/pass-extra-lines-multiple-certs.pem create mode 100644 ocaml/gencert/test_data/pems/pass-extra-lines-one-cert.pem diff --git a/ocaml/gencert/pem.ml b/ocaml/gencert/pem.ml index 54a98875dbb..86182c2dfd6 100644 --- a/ocaml/gencert/pem.ml +++ b/ocaml/gencert/pem.ml @@ -18,6 +18,8 @@ type t = {private_key: string; host_cert: string; other_certs: string list} let is_data = function '-' -> false | _ -> true +let is_eol = function '\n' | '\r' -> true | _ -> false + let data = take_while1 is_data type kind = RSA | EC | OTHER @@ -58,15 +60,23 @@ let key = key_footer kind *> return (String.concat "" [header kind; body; footer kind]) "key" +let line = take_till is_eol *> end_of_line + +(* try to read a key, or skip a line and try again *) +let until_key = fix (fun m -> key <|> line *> m) "until_key" + let cert = cert_header >>= fun hd -> data >>= fun body -> cert_footer >>= fun tl -> return (String.concat "" [hd; body; tl]) "cert" +(* try to read a cert, or skip a line and try again *) +let until_cert = fix (fun m -> cert <|> line *> m) "until_cert" + let pem = - many end_of_line *> key >>= fun private_key -> - many end_of_line *> cert >>= fun host_cert -> - many end_of_line *> many cert >>= fun other_certs -> + until_key >>= fun private_key -> + until_cert >>= fun host_cert -> + many until_cert >>= fun other_certs -> many end_of_line *> return {private_key; host_cert; other_certs} "pem" let defer f = Fun.protect ~finally:f diff --git a/ocaml/gencert/test_data/pems/pass-extra-lines-multiple-certs.pem b/ocaml/gencert/test_data/pems/pass-extra-lines-multiple-certs.pem new file mode 100644 index 00000000000..eeb088698a2 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-extra-lines-multiple-certs.pem @@ -0,0 +1,87 @@ +extra line +-----BEGIN RSA PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH +tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI +r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 +eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 +iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes +rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG +N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij +gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK +8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 +EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad +EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ +OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 +hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf +A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ +/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 +awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks +rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf +CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 +fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 +cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 +XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu +nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din +TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH +ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT +6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo +FIPEq03cDKVNDCgABw4mkw== +-----END RSA PRIVATE KEY----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line diff --git a/ocaml/gencert/test_data/pems/pass-extra-lines-one-cert.pem b/ocaml/gencert/test_data/pems/pass-extra-lines-one-cert.pem new file mode 100644 index 00000000000..bc43f444a28 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-extra-lines-one-cert.pem @@ -0,0 +1,49 @@ +extra line +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH +tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI +r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 +eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 +iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes +rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG +N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij +gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK +8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 +EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad +EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ +OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 +hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf +A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ +/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 +awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks +rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf +CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 +fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 +cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 +XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu +nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din +TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH +ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT +6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo +FIPEq03cDKVNDCgABw4mkw== +-----END PRIVATE KEY----- +extra line +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- +extra line From 71c87a18a383d9f72366349b93d5235345a6a1da Mon Sep 17 00:00:00 2001 From: Lin Liu Date: Mon, 6 Jan 2025 05:12:25 +0000 Subject: [PATCH 51/73] CP-51895: Drop FCoE support when fcoe_driver does not exists - Add logs when fcoe_driver does not exist - Use List.assoc_opt instead of try catch - Add __FUNCTION__ to the logs Signed-off-by: Lin Liu --- ocaml/networkd/lib/network_utils.ml | 4 +++- ocaml/xapi/xapi_pif.ml | 27 +++++++++++++-------------- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 0cd8d4769bb..b6c696ea896 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -1069,13 +1069,15 @@ module Fcoe = struct let get_capabilities name = match Sys.file_exists !fcoedriver with | false -> + info "%s: %s not found, does not support FCoE" __FUNCTION__ !fcoedriver ; [] (* Does not support FCoE *) | true -> ( try let output = call ~log:false ["--xapi"; name; "capable"] in if Astring.String.is_infix ~affix:"True" output then ["fcoe"] else [] with _ -> - debug "Failed to get fcoe support status on device %s" name ; + debug "%s: Failed to get fcoe support status on device %s" __FUNCTION__ + name ; [] ) end diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index f52def6d8ee..0284a134a68 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -323,7 +323,7 @@ let assert_fcoe_not_in_use ~__context ~self = | false -> (* Does not support FCoE from XS9, presuming not in use * Upgrade plugin will block upgrade with FCoE in use *) - () + debug "%s not found, does not support FCoE" !Xapi_globs.fcoe_driver | true -> let interface = Db.PIF.get_device ~__context ~self in let output, _ = @@ -331,25 +331,24 @@ let assert_fcoe_not_in_use ~__context ~self = ["-t"; interface] in let output = String.trim output in - debug "Scsi ids on %s are: %s" interface output ; + debug "%s: SCSI ids on %s are: %s" __FUNCTION__ interface output ; let fcoe_scsids = Str.split (Str.regexp " ") output in Helpers.get_my_pbds __context |> List.iter (fun (_, pbd_rec) -> let sr = pbd_rec.API.pBD_SR in match Db.SR.get_type ~__context ~self:sr with | "lvmofcoe" -> ( - try - let scsid = - List.assoc "SCSIid" pbd_rec.API.pBD_device_config - in - if List.mem scsid fcoe_scsids then - raise - (Api_errors.Server_error - ( Api_errors.pif_has_fcoe_sr_in_use - , [Ref.string_of self; Ref.string_of sr] - ) - ) - with Not_found -> () + match List.assoc_opt "SCSIid" pbd_rec.API.pBD_device_config with + | Some scsid -> + if List.mem scsid fcoe_scsids then + raise + (Api_errors.Server_error + ( Api_errors.pif_has_fcoe_sr_in_use + , [Ref.string_of self; Ref.string_of sr] + ) + ) + | None -> + () ) | _ -> () From 5428164b405e9a996dd41b4a5b9e1c631351cff6 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Fri, 3 Jan 2025 11:25:32 +0000 Subject: [PATCH 52/73] CA-403344: Add `db_get_by_uuid_opt` to db_cache* MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Edwin Török Signed-off-by: Vincent Liu --- ocaml/database/db_remote_cache_access_v1.ml | 6 ++++++ ocaml/database/db_remote_cache_access_v2.ml | 2 ++ ocaml/database/db_rpc_client_v2.ml | 2 +- ocaml/database/db_rpc_common_v1.ml | 2 ++ ocaml/database/db_rpc_common_v2.ml | 1 + 5 files changed, 12 insertions(+), 1 deletion(-) diff --git a/ocaml/database/db_remote_cache_access_v1.ml b/ocaml/database/db_remote_cache_access_v1.ml index ec198755739..1499fa3fc13 100644 --- a/ocaml/database/db_remote_cache_access_v1.ml +++ b/ocaml/database/db_remote_cache_access_v1.ml @@ -102,6 +102,12 @@ module DBCacheRemoteListener = struct let s, e = unmarshall_db_get_by_uuid_args args in success (marshall_db_get_by_uuid_response (DBCache.db_get_by_uuid t s e)) + | "db_get_by_uuid_opt" -> + let s, e = unmarshall_db_get_by_uuid_args args in + success + (marshall_db_get_by_uuid_opt_response + (DBCache.db_get_by_uuid_opt t s e) + ) | "db_get_by_name_label" -> let s, e = unmarshall_db_get_by_name_label_args args in success diff --git a/ocaml/database/db_remote_cache_access_v2.ml b/ocaml/database/db_remote_cache_access_v2.ml index 040ad215600..754fd2fa340 100644 --- a/ocaml/database/db_remote_cache_access_v2.ml +++ b/ocaml/database/db_remote_cache_access_v2.ml @@ -36,6 +36,8 @@ let process_rpc (req : Rpc.t) = Response.Read_field_where (DB.read_field_where t w) | Request.Db_get_by_uuid (a, b) -> Response.Db_get_by_uuid (DB.db_get_by_uuid t a b) + | Request.Db_get_by_uuid_opt (a, b) -> + Response.Db_get_by_uuid_opt (DB.db_get_by_uuid_opt t a b) | Request.Db_get_by_name_label (a, b) -> Response.Db_get_by_name_label (DB.db_get_by_name_label t a b) | Request.Create_row (a, b, c) -> diff --git a/ocaml/database/db_rpc_client_v2.ml b/ocaml/database/db_rpc_client_v2.ml index 3a32b3149e9..2e03f069497 100644 --- a/ocaml/database/db_rpc_client_v2.ml +++ b/ocaml/database/db_rpc_client_v2.ml @@ -78,7 +78,7 @@ functor raise Remote_db_server_returned_bad_message let db_get_by_uuid_opt _ t u = - match process (Request.Db_get_by_uuid (t, u)) with + match process (Request.Db_get_by_uuid_opt (t, u)) with | Response.Db_get_by_uuid_opt y -> y | _ -> diff --git a/ocaml/database/db_rpc_common_v1.ml b/ocaml/database/db_rpc_common_v1.ml index cced73dd9ca..b4ef9a4163e 100644 --- a/ocaml/database/db_rpc_common_v1.ml +++ b/ocaml/database/db_rpc_common_v1.ml @@ -192,6 +192,8 @@ let unmarshall_db_get_by_uuid_args xml = unmarshall_2strings xml let marshall_db_get_by_uuid_response s = XMLRPC.To.string s +let marshall_db_get_by_uuid_opt_response = marshall_stringopt + let unmarshall_db_get_by_uuid_response xml = XMLRPC.From.string xml let unmarshall_db_get_by_uuid_opt_response xml = unmarshall_stringopt xml diff --git a/ocaml/database/db_rpc_common_v2.ml b/ocaml/database/db_rpc_common_v2.ml index 4cd9d7541ab..6700d159f18 100644 --- a/ocaml/database/db_rpc_common_v2.ml +++ b/ocaml/database/db_rpc_common_v2.ml @@ -23,6 +23,7 @@ module Request = struct | Find_refs_with_filter of string * Db_filter_types.expr | Read_field_where of Db_cache_types.where_record | Db_get_by_uuid of string * string + | Db_get_by_uuid_opt of string * string | Db_get_by_name_label of string * string | Create_row of string * (string * string) list * string | Delete_row of string * string From eacc53b8255b4bd1f5eaaa0f8c528a5e3af6ec06 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Fri, 3 Jan 2025 11:34:50 +0000 Subject: [PATCH 53/73] Add unit test to the new `db_get_by_uuid_opt` function Signed-off-by: Vincent Liu --- ocaml/database/database_test.ml | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index 51e28dbf387..f3c10944b19 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -580,6 +580,24 @@ functor let (_ : string) = Client.db_get_by_uuid t "VM" invalid_uuid in failwith "db_get_by_uuid " ) ; + Printf.printf "db_get_by_uuid_opt \n" ; + let r = Client.db_get_by_uuid_opt t "VM" valid_uuid in + ( if r <> Some valid_ref then + let rs = Option.value ~default:"None" r in + failwith + (Printf.sprintf + "db_get_by_uuid_opt : got %s; expected %s" rs + valid_ref + ) + ) ; + Printf.printf "db_get_by_uuid_opt \n" ; + let r = Client.db_get_by_uuid_opt t "VM" invalid_uuid in + if not (Option.is_none r) then + failwith + (Printf.sprintf + "db_get_by_uuid_opt : got %s; expected None" + valid_ref + ) ; Printf.printf "get_by_name_label \n" ; if Client.db_get_by_name_label t "VM" invalid_name <> [] then failwith "db_get_by_name_label " ; From c69aec917145bc9be9539cdadaa2d6ae75e566f9 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Mon, 6 Jan 2025 12:11:40 +0000 Subject: [PATCH 54/73] Style: Refactor using failwith_fmt Signed-off-by: Vincent Liu --- ocaml/database/database_test.ml | 93 ++++++++++++--------------------- 1 file changed, 34 insertions(+), 59 deletions(-) diff --git a/ocaml/database/database_test.ml b/ocaml/database/database_test.ml index f3c10944b19..dc176488f3b 100644 --- a/ocaml/database/database_test.ml +++ b/ocaml/database/database_test.ml @@ -16,6 +16,8 @@ let name_label = "name__label" let name_description = "name__description" +let failwith_fmt fmt = Printf.ksprintf failwith fmt + module Tests = functor (Client : Db_interface.DB_ACCESS) @@ -111,7 +113,7 @@ functor ; where_value= "" } in - failwith (Printf.sprintf "%s " fn_name) + failwith_fmt "%s " fn_name ) ; Printf.printf "%s \n" @@ -126,11 +128,9 @@ functor ; where_value= name } in - failwith - (Printf.sprintf - "%s " - fn_name - ) + failwith_fmt + "%s " + fn_name ) ; Printf.printf "%s \n" @@ -145,11 +145,9 @@ functor ; where_value= "" } in - failwith - (Printf.sprintf - "%s " - fn_name - ) + failwith_fmt + "%s " + fn_name ) (* Verify the ref_index contents are correct for a given [tblname] and [key] (uuid/ref) *) @@ -168,10 +166,9 @@ functor | Some {Ref_index.name_label= name_label'; uuid; _ref} -> (* key should be either uuid or _ref *) if key <> uuid && key <> _ref then - failwith - (Printf.sprintf "check_ref_index %s key %s: got ref %s uuid %s" - tblname key _ref uuid - ) ; + failwith_fmt "check_ref_index %s key %s: got ref %s uuid %s" tblname + key _ref uuid ; + let real_ref = if Client.is_valid_ref t key then key @@ -183,14 +180,11 @@ functor with _ -> None in if name_label' <> real_name_label then - failwith - (Printf.sprintf - "check_ref_index %s key %s: ref_index name_label = %s; db has \ - %s" - tblname key - (Option.value ~default:"None" name_label') - (Option.value ~default:"None" real_name_label) - ) + failwith_fmt + "check_ref_index %s key %s: ref_index name_label = %s; db has %s" + tblname key + (Option.value ~default:"None" name_label') + (Option.value ~default:"None" real_name_label) open Db_cache_types @@ -226,11 +220,9 @@ functor in let bar_foos = Row.find "foos" bar_1 in if bar_foos <> Set ["foo:1"] then - failwith - (Printf.sprintf - "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s" - (Schema.Value.marshal bar_foos) - ) ; + failwith_fmt + "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s" + (Schema.Value.marshal bar_foos) ; (* set foo.bars to [] *) (* let foo_1 = Table.find "foo:1" (TableSet.find "foo" (Database.tableset db)) in*) let db = set_field "foo" "foo:1" "bars" (Set []) db in @@ -240,11 +232,8 @@ functor in let bar_foos = Row.find "foos" bar_1 in if bar_foos <> Set [] then - failwith - (Printf.sprintf - "check_many_to_many: bar(bar:1).foos expected () got %s" - (Schema.Value.marshal bar_foos) - ) ; + failwith_fmt "check_many_to_many: bar(bar:1).foos expected () got %s" + (Schema.Value.marshal bar_foos) ; (* add 'bar' to foo.bars *) let db = set_field "foo" "foo:1" "bars" (Set ["bar:1"]) db in (* check that 'bar.foos' includes 'foo' *) @@ -253,11 +242,9 @@ functor in let bar_foos = Row.find "foos" bar_1 in if bar_foos <> Set ["foo:1"] then - failwith - (Printf.sprintf - "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2" - (Schema.Value.marshal bar_foos) - ) ; + failwith_fmt + "check_many_to_many: bar(bar:1).foos expected ('foo:1') got %s - 2" + (Schema.Value.marshal bar_foos) ; (* delete 'bar' *) let db = remove_row "bar" "bar:1" db in (* check that 'foo.bars' is empty *) @@ -266,11 +253,8 @@ functor in let foo_bars = Row.find "bars" foo_1 in if foo_bars <> Set [] then - failwith - (Printf.sprintf - "check_many_to_many: foo(foo:1).foos expected () got %s" - (Schema.Value.marshal foo_bars) - ) ; + failwith_fmt "check_many_to_many: foo(foo:1).foos expected () got %s" + (Schema.Value.marshal foo_bars) ; () let check_events t = @@ -503,8 +487,7 @@ functor | None -> Printf.printf "Reference '%s' has no associated table\n" invalid_ref | Some t -> - failwith - (Printf.sprintf "Reference '%s' exists in table '%s'" invalid_ref t) + failwith_fmt "Reference '%s' exists in table '%s'" invalid_ref t ) ; Printf.printf "is_valid_ref \n" ; if Client.is_valid_ref t invalid_ref then @@ -571,10 +554,8 @@ functor Printf.printf "db_get_by_uuid \n" ; let r = Client.db_get_by_uuid t "VM" valid_uuid in if r <> valid_ref then - failwith - (Printf.sprintf "db_get_by_uuid : got %s; expected %s" r - valid_ref - ) ; + failwith_fmt "db_get_by_uuid : got %s; expected %s" r + valid_ref ; Printf.printf "db_get_by_uuid \n" ; expect_missing_uuid "VM" invalid_uuid (fun () -> let (_ : string) = Client.db_get_by_uuid t "VM" invalid_uuid in @@ -584,20 +565,14 @@ functor let r = Client.db_get_by_uuid_opt t "VM" valid_uuid in ( if r <> Some valid_ref then let rs = Option.value ~default:"None" r in - failwith - (Printf.sprintf - "db_get_by_uuid_opt : got %s; expected %s" rs - valid_ref - ) + failwith_fmt "db_get_by_uuid_opt : got %s; expected %s" rs + valid_ref ) ; Printf.printf "db_get_by_uuid_opt \n" ; let r = Client.db_get_by_uuid_opt t "VM" invalid_uuid in if not (Option.is_none r) then - failwith - (Printf.sprintf - "db_get_by_uuid_opt : got %s; expected None" - valid_ref - ) ; + failwith_fmt "db_get_by_uuid_opt : got %s; expected None" + valid_ref ; Printf.printf "get_by_name_label \n" ; if Client.db_get_by_name_label t "VM" invalid_name <> [] then failwith "db_get_by_name_label " ; From 769c863b8e0c9bd08a9647492cda5736ecfc4bb3 Mon Sep 17 00:00:00 2001 From: Konstantina Chremmou Date: Fri, 20 Dec 2024 18:36:58 +0000 Subject: [PATCH 55/73] Removed deprecated methods. Signed-off-by: Konstantina Chremmou --- ocaml/sdk-gen/csharp/autogen/src/Session.cs | 30 ------------------- .../csharp/templates/ApiVersion.mustache | 28 +++-------------- 2 files changed, 4 insertions(+), 54 deletions(-) diff --git a/ocaml/sdk-gen/csharp/autogen/src/Session.cs b/ocaml/sdk-gen/csharp/autogen/src/Session.cs index 4a84b5bcd0c..e6b4b87eb47 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/Session.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/Session.cs @@ -70,24 +70,11 @@ public Session(JsonRpcClient client) JsonRpcClient = client; } - [Obsolete("Use Session(string url) { Timeout = ... }; instead.")] - public Session(int timeout, string url) - : this(new JsonRpcClient(url)) - { - JsonRpcClient.Timeout = timeout; - } - public Session(string url) : this(new JsonRpcClient(url)) { } - [Obsolete("Use Session(string host, int port) { Timeout = ... }; instead.")] - public Session(int timeout, string host, int port) - : this(timeout, GetUrl(host, port)) - { - } - public Session(string host, int port) : this(GetUrl(host, port)) { @@ -100,23 +87,6 @@ public Session(string url, string opaqueRef) SetupSessionDetails(); } - /// - /// Create a new Session instance, using the given instance and timeout. The connection details and Xen-API session handle will be - /// copied from the given instance, but a new connection will be created. Use this if you want a duplicate connection to a host, - /// for example when you need to cancel an operation that is blocking the primary connection. - /// - /// - /// - [Obsolete("Use Session(Session session) { Timeout = ... }; instead.")] - public Session(Session session, int timeout) - : this(session) - { - if (JsonRpcClient != null) - { - JsonRpcClient.Timeout = timeout; - } - } - /// /// Create a new Session instance, using the given instance. The connection details /// and Xen-API session handle will be copied from the given instance, but a new diff --git a/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache b/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache index a8be1e4e8a5..9cac0b97c18 100644 --- a/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache +++ b/ocaml/sdk-gen/csharp/templates/ApiVersion.mustache @@ -28,9 +28,6 @@ */ using System; -using System.Collections; -using System.Collections.Generic; - namespace XenAPI { @@ -63,8 +60,7 @@ namespace XenAPI { try { - return (API_Version)Enum.Parse(typeof(API_Version), - string.Format("API_{0}_{1}", major, minor)); + return (API_Version)Enum.Parse(typeof(API_Version), $"API_{major}_{minor}"); } catch (ArgumentException) { @@ -82,30 +78,14 @@ namespace XenAPI { string[] tokens = version.Split('.'); int major, minor; - if (tokens.Length == 2 && int.TryParse(tokens[0], out major) && int.TryParse(tokens[1], out minor)) + if (tokens.Length == 2 && + int.TryParse(tokens[0], out major) && + int.TryParse(tokens[1], out minor)) { return GetAPIVersion(major, minor); } } return API_Version.UNKNOWN; } - - /// - /// Return a positive number if the given session's API version is greater than the given - /// API_version, negative if it is less, and 0 if they are equal. - /// - internal static int APIVersionCompare(Session session, API_Version v) - { - return (int)session.APIVersion - (int)v; - } - - /// - /// Return true if the given session's API version is greater than or equal to the given - /// API_version. - /// - internal static bool APIVersionMeets(Session session, API_Version v) - { - return APIVersionCompare(session, v) >= 0; - } } } From ad4f3d94ca58bc1fd09aaa130c4aed0156f3b787 Mon Sep 17 00:00:00 2001 From: Konstantina Chremmou Date: Fri, 20 Dec 2024 18:45:06 +0000 Subject: [PATCH 56/73] Cmdlet refactoring: - Moved certificate methods to the Connect-XenServer cmdlet and refactored them to avoid multiple loads of the global variable KnownServerCertificatesFilePath. - Fixed accessibility of CommonCmdletFunctions members. Signed-off-by: Konstantina Chremmou --- .../autogen/src/CommonCmdletFunctions.cs | 73 ++-------------- .../autogen/src/Connect-XenServer.cs | 83 ++++++++++++++++--- 2 files changed, 76 insertions(+), 80 deletions(-) diff --git a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs index 8f29ecde1f5..d22d5eadee0 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/CommonCmdletFunctions.cs @@ -39,14 +39,11 @@ namespace Citrix.XenServer { - class CommonCmdletFunctions + internal class CommonCmdletFunctions { private const string SessionsVariable = "global:Citrix.XenServer.Sessions"; - private const string DefaultSessionVariable = "global:XenServer_Default_Session"; - private const string KnownServerCertificatesFilePathVariable = "global:KnownServerCertificatesFilePath"; - static CommonCmdletFunctions() { Session.UserAgent = string.Format("XenServerPSModule/{0}", Assembly.GetExecutingAssembly().GetName().Version); @@ -78,72 +75,12 @@ internal static void SetDefaultXenSession(PSCmdlet cmdlet, Session session) cmdlet.SessionState.PSVariable.Set(DefaultSessionVariable, session); } - internal static string GetKnownServerCertificatesFilePathVariable(PSCmdlet cmdlet) - { - var knownCertificatesFilePathObject = cmdlet.SessionState.PSVariable.GetValue(KnownServerCertificatesFilePathVariable); - if (knownCertificatesFilePathObject is PSObject psObject) - return psObject.BaseObject as string; - return knownCertificatesFilePathObject?.ToString() ?? string.Empty; - } - internal static string GetUrl(string hostname, int port) { - return string.Format("{0}://{1}:{2}", port == 80 ? "http" : "https", hostname, port); - } - - public static Dictionary LoadCertificates(PSCmdlet cmdlet) - { - Dictionary certificates = new Dictionary(); - var knownServerCertificatesFilePath = GetKnownServerCertificatesFilePathVariable(cmdlet); - - if (File.Exists(knownServerCertificatesFilePath)) - { - XmlDocument doc = new XmlDocument(); - doc.Load(knownServerCertificatesFilePath); - - foreach (XmlNode node in doc.GetElementsByTagName("certificate")) - { - XmlAttribute hostAtt = node.Attributes?["hostname"]; - XmlAttribute fngprtAtt = node.Attributes?["fingerprint"]; - - if (hostAtt != null && fngprtAtt != null) - certificates[hostAtt.Value] = fngprtAtt.Value; - } - } - - return certificates; - } - - public static void SaveCertificates(PSCmdlet cmdlet, Dictionary certificates) - { - var knownServerCertificatesFilePath = GetKnownServerCertificatesFilePathVariable(cmdlet); - string dirName = Path.GetDirectoryName(knownServerCertificatesFilePath); - - if (!Directory.Exists(dirName)) - Directory.CreateDirectory(dirName); - - XmlDocument doc = new XmlDocument(); - XmlDeclaration decl = doc.CreateXmlDeclaration("1.0", "utf-8", null); - doc.AppendChild(decl); - XmlNode node = doc.CreateElement("certificates"); - - foreach (KeyValuePair cert in certificates) - { - XmlNode certNode = doc.CreateElement("certificate"); - XmlAttribute hostname = doc.CreateAttribute("hostname"); - XmlAttribute fingerprint = doc.CreateAttribute("fingerprint"); - hostname.Value = cert.Key; - fingerprint.Value = cert.Value; - certNode.Attributes?.Append(hostname); - certNode.Attributes?.Append(fingerprint); - node.AppendChild(certNode); - } - - doc.AppendChild(node); - doc.Save(knownServerCertificatesFilePath); + return $"{(port == 80 ? "http" : "https")}://{hostname}:{port}"; } - public static string FingerprintPrettyString(string fingerprint) + internal static string FingerprintPrettyString(string fingerprint) { List pairs = new List(); while (fingerprint.Length > 1) @@ -157,7 +94,7 @@ public static string FingerprintPrettyString(string fingerprint) return string.Join(":", pairs.ToArray()); } - public static Dictionary ConvertHashTableToDictionary(Hashtable tbl) + internal static Dictionary ConvertHashTableToDictionary(Hashtable tbl) { if (tbl == null) return null; @@ -169,7 +106,7 @@ public static Dictionary ConvertHashTableToDictionary(Hashtable tbl) return dict; } - public static Hashtable ConvertDictionaryToHashtable(Dictionary dict) + internal static Hashtable ConvertDictionaryToHashtable(Dictionary dict) { if (dict == null) return null; diff --git a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs index f300801f5ef..a1dc4ecf964 100644 --- a/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs +++ b/ocaml/sdk-gen/powershell/autogen/src/Connect-XenServer.cs @@ -29,6 +29,7 @@ using System; using System.Collections.Generic; +using System.IO; using System.Management.Automation; using System.Net; using System.Net.Security; @@ -36,6 +37,7 @@ using System.Security; using System.Security.Cryptography; using System.Security.Cryptography.X509Certificates; +using System.Xml; using XenAPI; namespace Citrix.XenServer.Commands @@ -43,6 +45,8 @@ namespace Citrix.XenServer.Commands [Cmdlet("Connect", "XenServer")] public class ConnectXenServerCommand : PSCmdlet { + private const string CertificatesPathVariable = "global:KnownServerCertificatesFilePath"; + private readonly object _certificateValidationLock = new object(); public ConnectXenServerCommand() @@ -214,7 +218,10 @@ protected override void ProcessRecord() { if (ShouldContinue(ex.Message, ex.Caption)) { - AddCertificate(ex.Hostname, ex.Fingerprint); + var certPath = GetCertificatesPath(); + var certificates = LoadCertificates(certPath); + certificates[ex.Hostname] = ex.Fingerprint; + SaveCertificates(certPath, certificates); i--; continue; } @@ -254,13 +261,6 @@ protected override void ProcessRecord() WriteObject(newSessions.Values, true); } - private void AddCertificate(string hostname, string fingerprint) - { - var certificates = CommonCmdletFunctions.LoadCertificates(this); - certificates[hostname] = fingerprint; - CommonCmdletFunctions.SaveCertificates(this, certificates); - } - private bool ValidateServerCertificate(object sender, X509Certificate certificate, X509Chain chain, SslPolicyErrors sslPolicyErrors) { if (sslPolicyErrors == SslPolicyErrors.None) @@ -277,11 +277,11 @@ private bool ValidateServerCertificate(object sender, X509Certificate certificat bool trusted = VerifyInAllStores(new X509Certificate2(certificate)); - var certificates = CommonCmdletFunctions.LoadCertificates(this); + var certPath = GetCertificatesPath(); + var certificates = LoadCertificates(certPath); - if (certificates.ContainsKey(hostname)) + if (certificates.TryGetValue(hostname, out var fingerprintOld)) { - string fingerprintOld = certificates[hostname]; if (fingerprintOld == fingerprint) return true; @@ -295,7 +295,7 @@ private bool ValidateServerCertificate(object sender, X509Certificate certificat } certificates[hostname] = fingerprint; - CommonCmdletFunctions.SaveCertificates(this, certificates); + SaveCertificates(certPath, certificates); return true; } } @@ -312,6 +312,65 @@ private bool VerifyInAllStores(X509Certificate2 certificate2) return false; } } + + private string GetCertificatesPath() + { + var certPathObject = SessionState.PSVariable.GetValue(CertificatesPathVariable); + + return certPathObject is PSObject psObject + ? psObject.BaseObject as string + : certPathObject?.ToString() ?? string.Empty; + } + + private Dictionary LoadCertificates(string certPath) + { + var certificates = new Dictionary(); + + if (File.Exists(certPath)) + { + var doc = new XmlDocument(); + doc.Load(certPath); + + foreach (XmlNode node in doc.GetElementsByTagName("certificate")) + { + var hostAtt = node.Attributes?["hostname"]; + var fngprtAtt = node.Attributes?["fingerprint"]; + + if (hostAtt != null && fngprtAtt != null) + certificates[hostAtt.Value] = fngprtAtt.Value; + } + } + + return certificates; + } + + private void SaveCertificates(string certPath, Dictionary certificates) + { + string dirName = Path.GetDirectoryName(certPath); + + if (!Directory.Exists(dirName)) + Directory.CreateDirectory(dirName); + + XmlDocument doc = new XmlDocument(); + XmlDeclaration decl = doc.CreateXmlDeclaration("1.0", "utf-8", null); + doc.AppendChild(decl); + XmlNode node = doc.CreateElement("certificates"); + + foreach (KeyValuePair cert in certificates) + { + XmlNode certNode = doc.CreateElement("certificate"); + XmlAttribute hostname = doc.CreateAttribute("hostname"); + XmlAttribute fingerprint = doc.CreateAttribute("fingerprint"); + hostname.Value = cert.Key; + fingerprint.Value = cert.Value; + certNode.Attributes?.Append(hostname); + certNode.Attributes?.Append(fingerprint); + node.AppendChild(certNode); + } + + doc.AppendChild(node); + doc.Save(certPath); + } } internal abstract class CertificateValidationException : Exception From fa1bf903f260ed442620e13ebcdb6a03d2c1e6d2 Mon Sep 17 00:00:00 2001 From: Konstantina Chremmou Date: Fri, 20 Dec 2024 20:35:07 +0000 Subject: [PATCH 57/73] CP-53003: Use JsonRpc v1.0 by default and switch to v2.0 once the API version is known. Signed-off-by: Konstantina Chremmou --- ocaml/sdk-gen/csharp/autogen/src/Session.cs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/ocaml/sdk-gen/csharp/autogen/src/Session.cs b/ocaml/sdk-gen/csharp/autogen/src/Session.cs index e6b4b87eb47..82db84a8210 100644 --- a/ocaml/sdk-gen/csharp/autogen/src/Session.cs +++ b/ocaml/sdk-gen/csharp/autogen/src/Session.cs @@ -65,7 +65,6 @@ public Session(JsonRpcClient client) client.KeepAlive = true; client.UserAgent = UserAgent; client.WebProxy = Proxy; - client.JsonRpcVersion = JsonRpcVersion.v2; client.AllowAutoRedirect = true; JsonRpcClient = client; } @@ -145,6 +144,14 @@ private void SetAPIVersion() Host host = Host.get_record(this, pool.master); APIVersion = Helper.GetAPIVersion(host.API_version_major, host.API_version_minor); } + + if (JsonRpcClient != null) + { + if (APIVersion == API_Version.API_2_6) + JsonRpcClient.JsonRpcVersion = JsonRpcVersion.v1; + else if (APIVersion >= API_Version.API_2_8) + JsonRpcClient.JsonRpcVersion = JsonRpcVersion.v2; + } } private void CopyADFromSession(Session session) From e68cda76071000e5513521cd307bebb0e3e8c19c Mon Sep 17 00:00:00 2001 From: Frediano Ziglio Date: Tue, 7 Jan 2025 10:35:13 +0000 Subject: [PATCH 58/73] Use Mtime.Span.to_float_ns instead of Mtime.Span.to_uint64_ns+Int64.to_float Minor code reduction. Signed-off-by: Frediano Ziglio --- ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml index a544ed79bbb..200b9925786 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/scheduler.ml @@ -36,8 +36,7 @@ let lock = Mutex.create () module Clock = struct let span s = Mtime.Span.of_uint64_ns (Int64.of_float (s *. 1e9)) - let span_to_s span = - Mtime.Span.to_uint64_ns span |> Int64.to_float |> fun ns -> ns /. 1e9 + let span_to_s span = Mtime.Span.to_float_ns span |> fun ns -> ns /. 1e9 let add_span clock secs = (* return mix or max available value if the add overflows *) From 38a8f9883c9b8d4c3d9abb68d3d734a24ce01ae3 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 7 Jan 2025 15:01:29 +0000 Subject: [PATCH 59/73] CA-404013: do not relock the mutex when backing up rrds The point of using try_lock is to not get the thread suspended while trying to hold the mutex. Releasing it and calling `lock` may suspend the thread and defeats the purpose of using try_lock in the first place. Reorganise the sequence to read and copy all the rrds first while under the locked mutex, release it, and then archive the copies. Signed-off-by: Pau Ruiz Safont --- ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml | 52 +++++++++++--------------- 1 file changed, 21 insertions(+), 31 deletions(-) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index d9d41114e00..fdae263d867 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -99,6 +99,7 @@ let archive_rrd vm_uuid (remote_address : string option) : unit = master host, exclusively. Any attempt to send the rrds to pools outside the host will fail. *) let backup_rrds (remote_address : string option) () : unit = + let __FUN = __FUNCTION__ in let transport = Option.map (fun address -> @@ -119,50 +120,39 @@ let backup_rrds (remote_address : string option) () : unit = | Some address -> Printf.sprintf "host %s" address in - info "%s: trying to back up RRDs to %s" __FUNCTION__ destination ; + info "%s: trying to back up RRDs to %s" __FUN destination ; let total_cycles = 5 in let cycles_tried = ref 0 in + let host_uuid = Inventory.lookup Inventory._installation_uuid in while !cycles_tried < total_cycles do if Mutex.try_lock mutex then ( cycles_tried := total_cycles ; - let vrrds = - try Hashtbl.fold (fun k v acc -> (k, v.rrd) :: acc) vm_rrds [] - with exn -> Mutex.unlock mutex ; raise exn - in - Mutex.unlock mutex ; - List.iter - (fun (uuid, rrd) -> - debug "%s: saving RRD for VM uuid=%s" __FUNCTION__ uuid ; - let rrd = with_lock mutex (fun () -> Rrd.copy_rrd rrd) in - archive_rrd_internal ~transport ~uuid ~rrd () - ) - vrrds ; - Mutex.lock mutex ; - let srrds = - try Hashtbl.fold (fun k v acc -> (k, v.rrd) :: acc) sr_rrds [] - with exn -> Mutex.unlock mutex ; raise exn + let rrds_copy = + [ + Hashtbl.fold + (fun k v acc -> ("VM", k, Rrd.copy_rrd v.rrd) :: acc) + vm_rrds [] + ; Hashtbl.fold + (fun k v acc -> ("SR", k, Rrd.copy_rrd v.rrd) :: acc) + sr_rrds [] + ; Option.fold ~none:[] + ~some:(fun rrdi -> [("host", host_uuid, Rrd.copy_rrd rrdi.rrd)]) + !host_rrd + ] + |> List.concat in Mutex.unlock mutex ; + List.iter - (fun (uuid, rrd) -> - debug "%s: saving RRD for SR uuid=%s" __FUNCTION__ uuid ; - let rrd = with_lock mutex (fun () -> Rrd.copy_rrd rrd) in + (fun (cls, uuid, rrd) -> + debug "%s: saving RRD for %s uuid=%s" __FUN cls uuid ; archive_rrd_internal ~transport ~uuid ~rrd () ) - srrds ; - match !host_rrd with - | Some rrdi -> - debug "%s: saving RRD for host" __FUNCTION__ ; - let rrd = with_lock mutex (fun () -> Rrd.copy_rrd rrdi.rrd) in - archive_rrd_internal ~transport - ~uuid:(Inventory.lookup Inventory._installation_uuid) - ~rrd () - | None -> - () + rrds_copy ) else ( cycles_tried := 1 + !cycles_tried ; if !cycles_tried >= total_cycles then - warn "%s: Could not acquire RRD lock, skipping RRD backup" __FUNCTION__ + warn "%s: Could not acquire RRD lock, skipping RRD backup" __FUN else Thread.delay 1. ) From 77258a4f5c20a8217d9fae7ebdefab030007d143 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 8 Jan 2025 10:04:29 +0000 Subject: [PATCH 60/73] database: do not log when a field is dropped when loading from db_xml It causes logspam and hasn't been useful in the years it's been present. Lowering it to a debug statement would still cause it to be logged, so drop the message completely instead. Signed-off-by: Pau Ruiz Safont --- ocaml/database/db_xml.ml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/ocaml/database/db_xml.ml b/ocaml/database/db_xml.ml index d7c73db3d84..1795cdef3bd 100644 --- a/ocaml/database/db_xml.ml +++ b/ocaml/database/db_xml.ml @@ -161,12 +161,9 @@ module From = struct D.warn "no lifetime information about %s.%s, ignoring" tblname k ; false in - if do_not_load then ( - D.info - {|dropping column "%s.%s": it has been removed from the datamodel|} - tblname k ; + if do_not_load then row - ) else + else let column_schema = Schema.Table.find k table_schema in let value = Schema.Value.unmarshal column_schema.Schema.Column.ty From 5efa5d066837f995ef1494fb0ebae742f86698b6 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Tue, 7 Jan 2025 19:27:42 +0800 Subject: [PATCH 61/73] CA-404013: replace Thread.delay with Delay module Reporter.cancel would be blocked for a long time by backoff delay when another thread is waiting for next reading, replace Thread.delay with Delay module so that Reporter.cancel will not be blocked. Signed-off-by: Gang Ji --- ocaml/xcp-rrdd/lib/plugin/reporter.ml | 36 ++++++++++++++++++--- ocaml/xcp-rrdd/lib/plugin/reporter_local.ml | 2 +- 2 files changed, 32 insertions(+), 6 deletions(-) diff --git a/ocaml/xcp-rrdd/lib/plugin/reporter.ml b/ocaml/xcp-rrdd/lib/plugin/reporter.ml index 683af78b243..b7c9c018cbd 100644 --- a/ocaml/xcp-rrdd/lib/plugin/reporter.ml +++ b/ocaml/xcp-rrdd/lib/plugin/reporter.ml @@ -12,6 +12,8 @@ * GNU Lesser General Public License for more details. *) +module Delay = Xapi_stdext_threads.Threadext.Delay + let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute (* This exception is setup to be raised on sigint by Process.initialise, @@ -57,10 +59,20 @@ type state = | Cancelled | Stopped of [`New | `Cancelled | `Failed of exn] -type t = {mutable state: state; lock: Mutex.t; condition: Condition.t} +type t = { + mutable state: state + ; lock: Mutex.t + ; condition: Condition.t + ; delay: Delay.t +} let make () = - {state= Stopped `New; lock= Mutex.create (); condition= Condition.create ()} + { + state= Stopped `New + ; lock= Mutex.create () + ; condition= Condition.create () + ; delay= Delay.make () + } let choose_protocol = function | Rrd_interface.V1 -> @@ -69,13 +81,20 @@ let choose_protocol = function Rrd_protocol_v2.protocol let wait_until_next_reading (module D : Debug.DEBUG) ~neg_shift ~uid ~protocol - ~overdue_count = + ~overdue_count ~reporter = let next_reading = RRDD.Plugin.Local.register uid Rrd.Five_Seconds protocol in let wait_time = next_reading -. neg_shift in let wait_time = if wait_time < 0.1 then wait_time +. 5. else wait_time in (* overdue count - 0 if there is no overdue; +1 if there is overdue *) if wait_time > 0. then ( - Thread.delay wait_time ; 0 + ( match reporter with + | Some reporter -> + let (_ : bool) = Delay.wait reporter.delay wait_time in + () + | None -> + Thread.delay wait_time + ) ; + 0 ) else ( if overdue_count > 1 then ( (* if register returns negative more than once in a succession, @@ -84,7 +103,12 @@ let wait_until_next_reading (module D : Debug.DEBUG) ~neg_shift ~uid ~protocol D.debug "rrdd says next reading is overdue, seems like rrdd is busy;\n\ \t\t\t\tBacking off for %.1f seconds" backoff_time ; - Thread.delay backoff_time + match reporter with + | Some reporter -> + let (_ : bool) = Delay.wait reporter.delay backoff_time in + () + | None -> + Thread.delay backoff_time ) else D.debug "rrdd says next reading is overdue by %.1f seconds; not sleeping" (-.wait_time) ; @@ -147,8 +171,10 @@ let cancel ~reporter = match reporter.state with | Running -> reporter.state <- Cancelled ; + Delay.signal reporter.delay ; Condition.wait reporter.condition reporter.lock | Cancelled -> + Delay.signal reporter.delay ; Condition.wait reporter.condition reporter.lock | Stopped _ -> () diff --git a/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml b/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml index 42955b5ae1f..fec90d1dc8e 100644 --- a/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml +++ b/ocaml/xcp-rrdd/lib/plugin/reporter_local.ml @@ -28,7 +28,7 @@ let start_local (module D : Debug.DEBUG) ~reporter ~uid ~neg_shift ~page_count overdue_count := wait_until_next_reading (module D) - ~neg_shift ~uid ~protocol ~overdue_count:!overdue_count ; + ~neg_shift ~uid ~protocol ~overdue_count:!overdue_count ~reporter ; if page_count > 0 then let payload = Rrd_protocol.{timestamp= Utils.now (); datasources= dss_f ()} From 5689150c6fa34039a55a6f4581ae34d887e17ab3 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 17 Dec 2024 12:54:19 +0000 Subject: [PATCH 62/73] CA-403700 use iso9660 file system for updates Be explicit about the file system of an update ISO. Remove dead code. Signed-off-by: Christian Lindig --- ocaml/xapi/xapi_pool_update.ml | 2 +- ocaml/xenopsd/xc/xenops_server_xen.ml | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index daed914ccdf..c7f3b4ebdfb 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -291,7 +291,7 @@ let attach_helper ~__context ~uuid ~vdi ~use_localhost_proxy = "/dev/" ^ Client.VBD.get_device ~rpc ~session_id ~self:vbd ) in - with_api_errors (mount device) mount_point ; + with_api_errors (mount ~ty:(Some "iso9660") device) mount_point ; debug "pool_update.attach_helper Mounted %s" mount_point ) ; let ip = diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index d97ddede77b..7f6ede23895 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -2465,9 +2465,8 @@ module VM = struct | true -> Unixext.with_file path [Unix.O_RDONLY] 0o600 f_synced | false -> - with_mounted_dir_ro path @@ fun dir -> - let filename = Filename.concat dir "suspend-image" in - Unixext.with_file filename [Unix.O_RDONLY] 0o600 f_synced + error "%s: can't mount %s" __FUNCTION__ path ; + internal_error "can't mount %s (not a file or block dev)" path ) let wait_ballooning task vm = From 32b154edf76ccfe543c5b3c075bb825979ce7a63 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Tue, 7 Jan 2025 14:18:40 +0000 Subject: [PATCH 63/73] rrd2csv: Accept a trailing comma in metrics names rrd2csv itself prints out a list of comma-separated metrics names, but could't accept this list as command line arguments: ``` $ rrd2csv .....memory_total_kib, memory_free_kib, .... $ rrd2csv memory_total_kib, memory_free_kib WARNING: Requested metric AVERAGE:host:05e817e2-3a65-484d-b0da-a7163f9ffc12:memory_total_kib, is disabled or non-existant timestamp, AVERAGE:host:05e817e2-3a65-484d-b0da-a7163f9ffc12:memory_free_kib 2025-01-07T14:06:45Z, 30042000 ``` Now this works just fine: ``` $ rrd2csv memory_total_kib, memory_free_kib timestamp, AVERAGE:host:92bc3b1e-e0a3-49ba-8994-fc305ff882b7:memory_total_kib, AVERAGE:host:92bc3b1e-e0a3-49ba-8994-fc305ff882b7:memory_free_kib 2025-01-07T15:04:50Z, 33350000, 30023000 ``` Signed-off-by: Andrii Sultanov --- ocaml/rrd2csv/src/rrd2csv.ml | 46 ++++++++++++++++++++---------------- 1 file changed, 26 insertions(+), 20 deletions(-) diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index 0448c4e067f..b22c430f656 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -149,27 +149,33 @@ module Ds_selector = struct let of_string str = let open Rrd in - let splitted = Xstringext.String.split ':' str in + let splitted = Xstringext.String.split ',' str in match splitted with - | [cf; owner; uuid; metric] -> - { - cf= (try Some (cf_type_of_string cf) with _ -> None) - ; owner= - ( match owner with - | "vm" -> - Some (VM uuid) - | "sr" -> - Some (SR uuid) - | "host" -> - Some Host - | _ -> - None - ) - ; uuid - ; metric - } - | [metric] -> - {empty with metric} + | without_trailing_comma :: _ -> ( + let splitted = Xstringext.String.split ':' without_trailing_comma in + match splitted with + | [cf; owner; uuid; metric] -> + { + cf= (try Some (cf_type_of_string cf) with _ -> None) + ; owner= + ( match owner with + | "vm" -> + Some (VM uuid) + | "sr" -> + Some (SR uuid) + | "host" -> + Some Host + | _ -> + None + ) + ; uuid + ; metric + } + | [metric] -> + {empty with metric} + | _ -> + failwith "ds_selector_of_string" + ) | _ -> failwith "ds_selector_of_string" From 02ca33e2c444909db358fa1b5ef2eac1ee6a2d42 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Wed, 8 Jan 2025 21:32:15 +0000 Subject: [PATCH 64/73] CA-404512: Add feature flag to the new clustering interface The new clustering interface uses a constructor `Extended` address when a cluster hots is trying to join a cluster. This causes problems during upgrades as a newly upgraded host might send out the new address format to old hosts, which do not understand this format, causing the new hosts not able to join. The fix would be to use a new cluster_address feature flag/pool restrictions to control the use of the new clustering interface. This makes sure that the new interface would only be used if all of the hosts understand this new interface, i.e. have this feature enabled. The cluster_address feature is controlled by v6d and is pool-wide, therefore the new interface would only be enabled if all v6ds are updated to the correct level, which also implies that the accompanying xapi are updated to the correct level. Signed-off-by: Vincent Liu --- ocaml/xapi-types/features.ml | 2 ++ ocaml/xapi-types/features.mli | 1 + ocaml/xapi/xapi_cluster.ml | 9 ++------- ocaml/xapi/xapi_cluster_helpers.ml | 8 ++++++++ ocaml/xapi/xapi_cluster_host.ml | 19 ++++--------------- ocaml/xapi/xapi_cluster_host_helpers.ml | 14 ++++++++++++++ 6 files changed, 31 insertions(+), 22 deletions(-) diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index c80d3c833a5..52469387acc 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -58,6 +58,7 @@ type feature = | USB_passthrough | Network_sriov | Corosync + | Cluster_address | Zstd_export | Pool_secret_rotation | Certificate_verification @@ -123,6 +124,7 @@ let keys_of_features = ; (USB_passthrough, ("restrict_usb_passthrough", Negative, "USB_passthrough")) ; (Network_sriov, ("restrict_network_sriov", Negative, "Network_sriov")) ; (Corosync, ("restrict_corosync", Negative, "Corosync")) + ; (Cluster_address, ("restrict_cluster_address", Negative, "Cluster_address")) ; (Zstd_export, ("restrict_zstd_export", Negative, "Zstd_export")) ; ( Pool_secret_rotation , ("restrict_pool_secret_rotation", Negative, "Pool_secret_rotation") diff --git a/ocaml/xapi-types/features.mli b/ocaml/xapi-types/features.mli index f6efce3f0a5..018749cb685 100644 --- a/ocaml/xapi-types/features.mli +++ b/ocaml/xapi-types/features.mli @@ -65,6 +65,7 @@ type feature = | USB_passthrough (** Enable the use of USB passthrough. *) | Network_sriov (** Enable the use of Network SRIOV. *) | Corosync (** Enable the use of corosync. *) + | Cluster_address (** Enable the use of extended cluster address interface *) | Zstd_export (** Enable the use of VM export with zstd compression. *) | Pool_secret_rotation (** Enable Pool Secret Rotation *) | Certificate_verification (** Used by XenCenter *) diff --git a/ocaml/xapi/xapi_cluster.ml b/ocaml/xapi/xapi_cluster.ml index 498a0ea4111..1968e5f0774 100644 --- a/ocaml/xapi/xapi_cluster.ml +++ b/ocaml/xapi/xapi_cluster.ml @@ -13,7 +13,6 @@ *) open Xapi_clustering -open Ipaddr_rpc_type module D = Debug.Make (struct let name = "xapi_cluster" end) @@ -65,12 +64,8 @@ let create ~__context ~pIF ~cluster_stack ~pool_auto_join ~token_timeout let hostuuid = Inventory.lookup Inventory._installation_uuid in let hostname = Db.Host.get_hostname ~__context ~self:host in let member = - Extended - { - ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) - ; hostuuid - ; hostname - } + Xapi_cluster_host_helpers.get_cluster_host_address ~__context ~ip_addr + ~hostuuid ~hostname in let token_timeout_ms = Int64.of_float (token_timeout *. 1000.0) in let token_timeout_coefficient_ms = diff --git a/ocaml/xapi/xapi_cluster_helpers.ml b/ocaml/xapi/xapi_cluster_helpers.ml index 954b946b0fa..a4d30bcedaa 100644 --- a/ocaml/xapi/xapi_cluster_helpers.ml +++ b/ocaml/xapi/xapi_cluster_helpers.ml @@ -12,6 +12,8 @@ * GNU Lesser General Public License for more details. *) +module D = Debug.Make (struct let name = __MODULE__ end) + let finally = Xapi_stdext_pervasives.Pervasiveext.finally let all_cluster_operations = [`add; `remove; `enable; `disable; `destroy] @@ -104,6 +106,12 @@ let with_cluster_operation ~__context ~(self : [`Cluster] API.Ref.t) ~doc ~op with _ -> () ) +let cluster_address_enabled ~__context = + let r = Pool_features.is_enabled ~__context Features.Cluster_address in + D.debug "%s extended cluster address is %s" __FUNCTION__ + (if r then "enabled" else "disabled") ; + r + let corosync3_enabled ~__context = let pool = Helpers.get_pool ~__context in let restrictions = Db.Pool.get_restrictions ~__context ~self:pool in diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index e022f75c706..713261931a4 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -13,7 +13,6 @@ *) open Xapi_clustering -open Ipaddr_rpc_type module D = Debug.Make (struct let name = "xapi_cluster_host" end) @@ -126,12 +125,8 @@ let join_internal ~__context ~self = let host = Db.Cluster_host.get_host ~__context ~self in let hostname = Db.Host.get_hostname ~__context ~self:host in let member = - Extended - { - ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) - ; hostuuid - ; hostname - } + Xapi_cluster_host_helpers.get_cluster_host_address ~__context ~ip_addr + ~hostuuid ~hostname in let ip_list = List.filter_map @@ -338,14 +333,8 @@ let enable ~__context ~self = let hostuuid = Inventory.lookup Inventory._installation_uuid in let hostname = Db.Host.get_hostname ~__context ~self:host in let member = - Cluster_interface.( - Extended - { - ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) - ; hostuuid - ; hostname - } - ) + Xapi_cluster_host_helpers.get_cluster_host_address ~__context ~ip_addr + ~hostuuid ~hostname in let cluster_ref = Db.Cluster_host.get_cluster ~__context ~self in let cluster_stack = diff --git a/ocaml/xapi/xapi_cluster_host_helpers.ml b/ocaml/xapi/xapi_cluster_host_helpers.ml index 37e16d43178..59e5141da73 100644 --- a/ocaml/xapi/xapi_cluster_host_helpers.ml +++ b/ocaml/xapi/xapi_cluster_host_helpers.ml @@ -106,3 +106,17 @@ let with_cluster_host_operation ~__context ~(self : [`Cluster_host] API.Ref.t) (Datamodel_common._cluster_host, Ref.string_of self) with _ -> () ) + +let get_cluster_host_address ~__context ~ip_addr ~hostuuid ~hostname = + let open Ipaddr_rpc_type in + if Xapi_cluster_helpers.cluster_address_enabled ~__context then + Cluster_interface.( + Extended + { + ip= Ipaddr.of_string_exn (ipstr_of_address ip_addr) + ; hostuuid + ; hostname + } + ) + else + Cluster_interface.(IPv4 (ipstr_of_address ip_addr)) From 142137d1726d6a3d74a1e98801203711fbd3e2d7 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 14 Jan 2025 14:57:45 +0000 Subject: [PATCH 65/73] Remove unused Unixext.Direct module Signed-off-by: Rob Hoes --- .../xapi-stdext/lib/xapi-stdext-unix/dune | 4 +- .../lib/xapi-stdext-unix/unixext.ml | 29 ------- .../lib/xapi-stdext-unix/unixext.mli | 30 -------- .../lib/xapi-stdext-unix/unixext_open_stubs.c | 75 ------------------- .../xapi-stdext-unix/unixext_write_stubs.c | 65 ---------------- 5 files changed, 1 insertion(+), 202 deletions(-) delete mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c delete mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune index 92b77753a86..e73e4d47fa3 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/dune @@ -16,7 +16,5 @@ (language c) (names blkgetsize_stubs - unixext_open_stubs - unixext_stubs - unixext_write_stubs)) + unixext_stubs)) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index c63a61ff783..4a8dc687989 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -925,35 +925,6 @@ let test_open n = done ) -module Direct = struct - type t = Unix.file_descr - - external openfile : string -> Unix.open_flag list -> Unix.file_perm -> t - = "stub_stdext_unix_open_direct" - - let close = Unix.close - - let with_openfile path flags perms f = - let t = openfile path flags perms in - finally (fun () -> f t) (fun () -> close t) - - external unsafe_write : t -> bytes -> int -> int -> int - = "stub_stdext_unix_write" - - let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then - invalid_arg "Unixext.write" - else - unsafe_write fd buf ofs len - - let copy_from_fd ?limit socket fd = - copy_file_internal ?limit (Unix.read socket) (write fd) - - let fsync x = fsync x - - let lseek fd x cmd = Unix.LargeFile.lseek fd x cmd -end - (* --------------------------------------------------------------------------------------- *) module Daemon = struct diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli index fa8eb331f25..bec31c222a6 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -266,36 +266,6 @@ val test_open : int -> unit The file descriptors will stay open until the program exits. *) -module Direct : sig - (** Perform I/O in O_DIRECT mode using 4KiB page-aligned buffers *) - - (** represents a file open in O_DIRECT mode *) - type t - - val openfile : string -> Unix.open_flag list -> Unix.file_perm -> t - (** [openfile name flags perm] behaves the same as [Unix.openfile] but includes the O_DIRECT flag *) - - val close : t -> unit - (** [close t] closes [t], a file open in O_DIRECT mode *) - - val with_openfile : - string -> Unix.open_flag list -> Unix.file_perm -> (t -> 'a) -> 'a - (** [with_openfile name flags perm f] opens [name], applies the result to [f] and closes *) - - val write : t -> bytes -> int -> int -> int - (** [write t buf ofs len] writes [len] bytes at offset [ofs] from buffer [buf] to - [t] using page-aligned buffers. *) - - val copy_from_fd : ?limit:int64 -> Unix.file_descr -> t -> int64 - (** [copy_from_fd ?limit fd t] copies from [fd] to [t] up to [limit] *) - - val fsync : t -> unit - (** [fsync t] commits all outstanding writes, throwing an error if necessary. *) - - val lseek : t -> int64 -> Unix.seek_command -> int64 - (** [lseek t offset command]: see Unix.LargeFile.lseek *) -end - module Daemon : sig (** OCaml interface to libsystemd. diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c deleted file mode 100644 index d15cfeff0b1..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_open_stubs.c +++ /dev/null @@ -1,75 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: open.c 9547 2010-01-22 12:48:24Z doligez $ */ - -#define _GNU_SOURCE /* O_DIRECT */ - -#include -#include -#include -#include -#include -#include -#include - -#ifndef O_NONBLOCK -#define O_NONBLOCK O_NDELAY -#endif -#ifndef O_DSYNC -#define O_DSYNC 0 -#endif -#ifndef O_SYNC -#define O_SYNC 0 -#endif -#ifndef O_RSYNC -#define O_RSYNC 0 -#endif - -static int open_flag_table[] = { - O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, - O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC -}; - -CAMLprim value stub_stdext_unix_open_direct(value path, value flags, value perm) -{ - CAMLparam3(path, flags, perm); - int fd, cv_flags; -#ifndef O_DIRECT - int ret; -#endif - char * p; - - cv_flags = caml_convert_flag_list(flags, open_flag_table); - -#ifdef O_DIRECT - cv_flags |= O_DIRECT; -#endif - p = caml_stat_alloc(caml_string_length(path) + 1); - strcpy(p, String_val(path)); - /* open on a named FIFO can block (PR#1533) */ - caml_enter_blocking_section(); - fd = open(p, cv_flags, Int_val(perm)); -#ifndef O_DIRECT - if (fd != -1) - ret = fcntl(fd, F_NOCACHE); -#endif - caml_leave_blocking_section(); - caml_stat_free(p); - if (fd == -1) uerror("open", path); -#ifndef O_DIRECT - if (ret == -1) uerror("fcntl", path); -#endif - - CAMLreturn (Val_int(fd)); -} diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c deleted file mode 100644 index e4be9f68018..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext_write_stubs.c +++ /dev/null @@ -1,65 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: write.c 9547 2010-01-22 12:48:24Z doligez $ */ - -#include -#include -#include -#include -#include -#include - -#define PAGE_SIZE 4096 - -#ifndef EAGAIN -#define EAGAIN (-1) -#endif -#ifndef EWOULDBLOCK -#define EWOULDBLOCK (-1) -#endif - -CAMLprim value stub_stdext_unix_write(value fd, value buf, value vofs, value vlen) -{ - long ofs, len, written; - int numbytes, ret; - void *iobuf = NULL; - - Begin_root (buf); - ofs = Long_val(vofs); - len = Long_val(vlen); - written = 0; - while (len > 0) { - numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; - ret = posix_memalign(&iobuf, PAGE_SIZE, numbytes); - if (ret != 0) - uerror("write/posix_memalign", Nothing); - - memmove (iobuf, &Byte(buf, ofs), numbytes); - caml_enter_blocking_section(); - ret = write(Int_val(fd), iobuf, numbytes); - caml_leave_blocking_section(); - free(iobuf); - - if (ret == -1) { - if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break; - uerror("write", Nothing); - } - written += ret; - ofs += ret; - len -= ret; - } - End_roots(); - return Val_long(written); -} - From 8992f9d88697563e1d1f86a2ed580b9538bbe0a8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 15 Jan 2025 10:25:02 +0000 Subject: [PATCH 66/73] github: update release for ubuntu 24.04 The package dune has been replaced with ocaml-dune Signed-off-by: Pau Ruiz Safont --- .github/workflows/release.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 919cf406127..b27787c719f 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -22,7 +22,7 @@ jobs: - name: Install build dependencies run: | pip install build - sudo apt-get install ocaml dune libfindlib-ocaml-dev libdune-ocaml-dev libcmdliner-ocaml-dev + sudo apt-get install ocaml ocaml-dune libfindlib-ocaml-dev libdune-ocaml-dev libcmdliner-ocaml-dev - name: Generate python package for XenAPI run: | From de7e1eb1cf7ba5d60f8a6be8397c4f87c168f4aa Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 15 Jan 2025 15:56:31 +0000 Subject: [PATCH 67/73] github: remove dependency of python wheel's on dune Ubuntu's dune is way too old for the version generally used. On top of that the command doesn't fail when this happens, making the setup brittle. Instead write the version variable to config.mk and run make. Signed-off-by: Pau Ruiz Safont --- .github/workflows/release.yml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index b27787c719f..5c3f1cd5502 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -20,13 +20,11 @@ jobs: python-version: "3.x" - name: Install build dependencies - run: | - pip install build - sudo apt-get install ocaml ocaml-dune libfindlib-ocaml-dev libdune-ocaml-dev libcmdliner-ocaml-dev + run: pip install build - name: Generate python package for XenAPI run: | - ./configure --xapi_version=${{ github.ref_name }} + echo "export XAPI_VERSION=${{ github.ref_name }}" > config.mk make python - name: Store python distribution artifacts From aac5802acc075a0d4b8a04f1c7089015ca0cf009 Mon Sep 17 00:00:00 2001 From: Christian Lindig Date: Tue, 14 Jan 2025 15:24:43 +0000 Subject: [PATCH 68/73] CA-404640 XSI-1781 accept in PEM key/cert in any order We have so far hard-coded the exectation that in a PEM file a private key is followed by a certficate but this is actually not required by the PEM standard and let to a failure in XSI-1781. This is a simple fix first collects all keys and certificates while skipping over other content and the uses the first key and certificate. Signed-off-by: Christian Lindig --- ocaml/gencert/pem.ml | 45 +++++-- ocaml/gencert/test_data/pems/fail-06.pem | 93 ++++++++++++++- .../pems/{fail-01.pem => pass-05.pem} | 0 ocaml/gencert/test_data/pems/pass-06.pem | 109 +++++++++++++++++ .../test_data/pems/pass-xsi-1781-reformat.pem | 51 ++++++++ .../gencert/test_data/pems/pass-xsi-1781.pem | 111 ++++++++++++++++++ ocaml/gencert/test_data/reformat.sh | 27 +++++ 7 files changed, 423 insertions(+), 13 deletions(-) rename ocaml/gencert/test_data/pems/{fail-01.pem => pass-05.pem} (100%) create mode 100644 ocaml/gencert/test_data/pems/pass-06.pem create mode 100644 ocaml/gencert/test_data/pems/pass-xsi-1781-reformat.pem create mode 100644 ocaml/gencert/test_data/pems/pass-xsi-1781.pem create mode 100755 ocaml/gencert/test_data/reformat.sh diff --git a/ocaml/gencert/pem.ml b/ocaml/gencert/pem.ml index 86182c2dfd6..9a9354babdb 100644 --- a/ocaml/gencert/pem.ml +++ b/ocaml/gencert/pem.ml @@ -24,6 +24,10 @@ let data = take_while1 is_data type kind = RSA | EC | OTHER +type block = Key of string | Cert of string + +let fail_fmt fmt = Printf.ksprintf (fun str -> fail str) fmt + let kind = string " RSA " *> return RSA <|> string " EC " *> return EC @@ -60,24 +64,39 @@ let key = key_footer kind *> return (String.concat "" [header kind; body; footer kind]) "key" -let line = take_till is_eol *> end_of_line - -(* try to read a key, or skip a line and try again *) -let until_key = fix (fun m -> key <|> line *> m) "until_key" - let cert = cert_header >>= fun hd -> data >>= fun body -> cert_footer >>= fun tl -> return (String.concat "" [hd; body; tl]) "cert" -(* try to read a cert, or skip a line and try again *) -let until_cert = fix (fun m -> cert <|> line *> m) "until_cert" +let line = take_till is_eol *> end_of_line +let any_block = + cert >>= (fun c -> return (Cert c)) <|> (key >>= fun k -> return (Key k)) + +(* this skips over junk until we succeed finding the next block *) +let block = fix (fun m -> any_block <|> line *> m) "until_block" + +(* collect and tag all blocks *) +let blocks = many block "PEM blocks" + +(* decompose blocks into certs and keys *) let pem = - until_key >>= fun private_key -> - until_cert >>= fun host_cert -> - many until_cert >>= fun other_certs -> - many end_of_line *> return {private_key; host_cert; other_certs} "pem" + let ( let* ) = ( >>= ) in + let strip = function Cert c -> c | Key k -> k in + blocks >>= fun bs -> + match List.partition (function Key _ -> true | Cert _ -> false) bs with + | [Key k], Cert c :: xs -> + return {private_key= k; host_cert= c; other_certs= List.map strip xs} + | [_], [] -> + let* p = pos in + fail_fmt "PEM is lacking a certificate (at offset %d)" p + | [], _ -> + let* p = pos in + fail_fmt "PEM is missing a private key (at offset %d)" p + | _ :: _, _ -> + let* p = pos in + fail_fmt "PEM has more than one private key (at offset %d)" p let defer f = Fun.protect ~finally:f @@ -86,6 +105,10 @@ let read_file path = defer (fun () -> close_in ic) @@ fun () -> really_input_string ic (in_channel_length ic) +let _parse_with t path = + let consume = Consume.Prefix in + read_file path |> parse_string ~consume t + let parse_string str = let consume = Consume.Prefix in parse_string ~consume pem str diff --git a/ocaml/gencert/test_data/pems/fail-06.pem b/ocaml/gencert/test_data/pems/fail-06.pem index 6b63e248c1b..05a638c7a02 100644 --- a/ocaml/gencert/test_data/pems/fail-06.pem +++ b/ocaml/gencert/test_data/pems/fail-06.pem @@ -1,4 +1,74 @@ ------BEGIN RSA PRIVATE KEY----- +This fails because we have two keys (rather than just one). + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH +tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI +r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 +eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 +iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes +rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG +N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij +gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK +8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 +EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad +EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ +OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 +hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf +A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ +/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 +awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks +rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf +CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 +fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 +cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 +XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu +nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din +TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH +ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT +6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo +FIPEq03cDKVNDCgABw4mkw== +-----END PRIVATE KEY----- + + +-----BEGIN PRIVATE KEY----- MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 @@ -25,8 +95,26 @@ TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT 6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo FIPEq03cDKVNDCgABw4mkw== ------END EC PRIVATE KEY----- +-----END PRIVATE KEY----- +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE @@ -47,3 +135,4 @@ erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= -----END CERTIFICATE----- + diff --git a/ocaml/gencert/test_data/pems/fail-01.pem b/ocaml/gencert/test_data/pems/pass-05.pem similarity index 100% rename from ocaml/gencert/test_data/pems/fail-01.pem rename to ocaml/gencert/test_data/pems/pass-05.pem diff --git a/ocaml/gencert/test_data/pems/pass-06.pem b/ocaml/gencert/test_data/pems/pass-06.pem new file mode 100644 index 00000000000..18d7d7e0a96 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-06.pem @@ -0,0 +1,109 @@ +Multiple certificates and one key. + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + + +-----BEGIN PRIVATE KEY----- +MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH +tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI +r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 +eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 +iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes +rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG +N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij +gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK +8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 +EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad +EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ +OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 +hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf +A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ +/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 +awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks +rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf +CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 +fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 +cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 +XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu +nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din +TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH +ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT +6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo +FIPEq03cDKVNDCgABw4mkw== +-----END PRIVATE KEY----- + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + +-----BEGIN CERTIFICATE----- +MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE +AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx +MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN +BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e +gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH ++vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG +hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS +WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx +ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB +oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN +AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb +LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF +GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl +erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ +/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA +JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= +-----END CERTIFICATE----- + + diff --git a/ocaml/gencert/test_data/pems/pass-xsi-1781-reformat.pem b/ocaml/gencert/test_data/pems/pass-xsi-1781-reformat.pem new file mode 100644 index 00000000000..b0e3cf8288f --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-xsi-1781-reformat.pem @@ -0,0 +1,51 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC7qKYiCfucgzLI +X78/NTAtFXA97Cp3PfnQwpi90tF0YmWUObOdVdxP2FHvUTyMhItpvimsvztX503D +C0Q7lI9/omK3AbPPy51lhRCKTMiz8ic2fmiHU9lePmkZMZJv0p/eHgAIcOmIl5Kc +uvoKvOutLnFTRKrYhUQMu2eyBz0f8rzY/4yhLLNflkQUJ3zc3W0jeMuAUei7Zmtz +jpj+s3Ll5rwzVYG3xLbndzpCR7NaP5uZcchByhsirohR90m3dQtrFdtLTkiDJ8vJ +hW7z3AzAA0Btw/CtH1/Ef/rHt3XHKGMJoJ3nQ2zRvSutdrRSAknNqYONe0hyrLvy +MRGno7SjAgMBAAECggEANHjKw1fRQAk7aOXE3xKrPt/wu4/Oq/rrYGEZPnK1WHqu +9oxP2d2JNdZBys4HRS9GoDGpC4GJQWIOz0vWL2ax3Tl1qsBSG/dOMnXLkzA3KoG6 +TzV3WueqLvz6fC3tSVE2nG/9CF8yHZxsRWDOy7PZnloPG/5mWxagWYMJUrFNeSH2 +nXd40Rff5uM43OzKtiOOzoKv2bKlKReyJVcI98MkyqSbUiie6qO1/NqrOUhq7rsV +zFmbtjy8UL4gXR2VVz0itb/w/iV/SDVHdMQ36obo8EM9eyxUFu4QPscrbK0FvjHV +lsKTnzu1zj/fm68NafXDy/KL5I9jethsj8ReNaQzoQKBgQDLkaIxBtNtAZfcFK7S +dXtR7fIQfUTtgDrxznYXPqCkCy/0wp53hj7aShX2C/rfFQVElBUPkf2E/P6v7Xnf +b+M/Zj6TH7XYbScoVu+8cqfIm1ySd3evK4GoqGIUiJeuSYEfeLqZSTp1XxO05lGb +ZmAEtZUHor24Co9HIV/3P86EcwKBgQDr/fqn6b6V1O64r7/cnOmWhW1+5MjoWO2K ++y0fSutrPMOFK4ItJIk4Q5JbHA42cwyYRMe+oElGXzWJXGbqxyorFhW0Er/+roTa +6GXwNrRkdA3S0rgPAE7IS42WLDsAO9/muiZJ4heXtk8i0xDoyy3Y8UQ/6hR4h1px +jtn9Bs4zEQKBgBdW+TuZxr/mwNyQ2oJyydLY7zoIwtBgNWHoBA4iNhTY24S6k6Ss +laQ9fksZkIfnRxVXzRpd6K1IvIK7PY/qqilotZ/0sMrBqQ2s+gunMamEdpasb+J7 +oIAP3j7wckOfVdif5PUSOkuevQmupoiksjmYACBB/nKNc2P6ZaBZhnoVAoGBAJuc +4z777BeCzFNuWJaRxZniq9wj4rMLiL+/dvaOgYQ6EjdrBDDeSbmXHRgE/P48iQ6T +NB9oNEk6GORV0Ot5nz3AF1mhj4bR73smCaoHeJZQzJi7KHGD429CGr/utI0n7jGH +iB3p/2Kj7bTp9tl6uOW32ihHI26C2knNR8MITMnxAoGAZ+Dpg1a6u2ZMTSgOn9Vc +pECwENGtOQP4RKyXmnq3ET5ykx1hMMCf9uoA09TXDRuJ/20hVfsAGvLZdbQq/9DL +C3bckcoalhy8RXC/OV9c6SC/xgoYiggxmZtzV34wnQSLM4Cr+Q/lhOaj7sop6iJi +apYRps2sXbUdu3pDTub/zSI= +-----END PRIVATE KEY----- +-----BEGIN CERTIFICATE----- +MIIDwzCCAqugAwIBAgIUZeSD7KNhTFOoqpI7cWxxWcN417EwDQYJKoZIhvcNAQEL +BQAwcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNVBAcM +CUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2ZXIx +FDASBgNVBAMMC2V4YW1wbGUuY29tMB4XDTI1MDExNDE1NDIwMFoXDTM1MDExMjE1 +NDIwMFowcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNV +BAcMCUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2 +ZXIxFDASBgNVBAMMC2V4YW1wbGUuY29tMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEAu6imIgn7nIMyyF+/PzUwLRVwPewqdz350MKYvdLRdGJllDmznVXc +T9hR71E8jISLab4prL87V+dNwwtEO5SPf6JitwGzz8udZYUQikzIs/InNn5oh1PZ +Xj5pGTGSb9Kf3h4ACHDpiJeSnLr6CrzrrS5xU0Sq2IVEDLtnsgc9H/K82P+MoSyz +X5ZEFCd83N1tI3jLgFHou2Zrc46Y/rNy5ea8M1WBt8S253c6QkezWj+bmXHIQcob +Iq6IUfdJt3ULaxXbS05IgyfLyYVu89wMwANAbcPwrR9fxH/6x7d1xyhjCaCd50Ns +0b0rrXa0UgJJzamDjXtIcqy78jERp6O0owIDAQABo1MwUTAdBgNVHQ4EFgQUK3or +CHusUjk/eheKHz6JMuYQBkAwHwYDVR0jBBgwFoAUK3orCHusUjk/eheKHz6JMuYQ +BkAwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEATq7rhHQE3xSk +NUsD1dIFUwz7NJ1eIbdNQ8kJGybcTkIsBY9PrUcrnXFozEE05dZaZizCK/F0To3v +903kVAwaBe04sZuIqAVDHAjewH2yfCAIRkgA6RPnSHio6NTCLMi3Ukqrhj5bIFGy +eqcAKy0akXeV3uLIKKY/ZdNpPRP5gW2UZpC+p9ZBEcVDNKAWEK+GVLDar1MLdyIp +XyCp4wimx4iK+TyXEYKRK7G5+/HPtYOU2OrHtuUFnppz4G5/QuyuDO7yDAJaK8X/ +9hIuR4tcxzt3FdBMVXju5PViMpKbpw5XslbGxdAFFCSrkSRvzYw98tq7HkUB5IyV +OgjjLNHdJg== +-----END CERTIFICATE----- diff --git a/ocaml/gencert/test_data/pems/pass-xsi-1781.pem b/ocaml/gencert/test_data/pems/pass-xsi-1781.pem new file mode 100644 index 00000000000..7623c6e5cf0 --- /dev/null +++ b/ocaml/gencert/test_data/pems/pass-xsi-1781.pem @@ -0,0 +1,111 @@ +Certificate: + Data: + Version: 3 (0x2) + Serial Number: + 65:e4:83:ec:a3:61:4c:53:a8:aa:92:3b:71:6c:71:59:c3:78:d7:b1 + Signature Algorithm: sha256WithRSAEncryption + Issuer: C = UK, ST = Some-State, L = Cambridge, O = Citrix, OU = XenServer, CN = example.com + Validity + Not Before: Jan 14 15:42:00 2025 GMT + Not After : Jan 12 15:42:00 2035 GMT + Subject: C = UK, ST = Some-State, L = Cambridge, O = Citrix, OU = XenServer, CN = example.com + Subject Public Key Info: + Public Key Algorithm: rsaEncryption + Public-Key: (2048 bit) + Modulus: + 00:bb:a8:a6:22:09:fb:9c:83:32:c8:5f:bf:3f:35: + 30:2d:15:70:3d:ec:2a:77:3d:f9:d0:c2:98:bd:d2: + d1:74:62:65:94:39:b3:9d:55:dc:4f:d8:51:ef:51: + 3c:8c:84:8b:69:be:29:ac:bf:3b:57:e7:4d:c3:0b: + 44:3b:94:8f:7f:a2:62:b7:01:b3:cf:cb:9d:65:85: + 10:8a:4c:c8:b3:f2:27:36:7e:68:87:53:d9:5e:3e: + 69:19:31:92:6f:d2:9f:de:1e:00:08:70:e9:88:97: + 92:9c:ba:fa:0a:bc:eb:ad:2e:71:53:44:aa:d8:85: + 44:0c:bb:67:b2:07:3d:1f:f2:bc:d8:ff:8c:a1:2c: + b3:5f:96:44:14:27:7c:dc:dd:6d:23:78:cb:80:51: + e8:bb:66:6b:73:8e:98:fe:b3:72:e5:e6:bc:33:55: + 81:b7:c4:b6:e7:77:3a:42:47:b3:5a:3f:9b:99:71: + c8:41:ca:1b:22:ae:88:51:f7:49:b7:75:0b:6b:15: + db:4b:4e:48:83:27:cb:c9:85:6e:f3:dc:0c:c0:03: + 40:6d:c3:f0:ad:1f:5f:c4:7f:fa:c7:b7:75:c7:28: + 63:09:a0:9d:e7:43:6c:d1:bd:2b:ad:76:b4:52:02: + 49:cd:a9:83:8d:7b:48:72:ac:bb:f2:31:11:a7:a3: + b4:a3 + Exponent: 65537 (0x10001) + X509v3 extensions: + X509v3 Subject Key Identifier: + 2B:7A:2B:08:7B:AC:52:39:3F:7A:17:8A:1F:3E:89:32:E6:10:06:40 + X509v3 Authority Key Identifier: + 2B:7A:2B:08:7B:AC:52:39:3F:7A:17:8A:1F:3E:89:32:E6:10:06:40 + X509v3 Basic Constraints: critical + CA:TRUE + Signature Algorithm: sha256WithRSAEncryption + Signature Value: + 4e:ae:eb:84:74:04:df:14:a4:35:4b:03:d5:d2:05:53:0c:fb: + 34:9d:5e:21:b7:4d:43:c9:09:1b:26:dc:4e:42:2c:05:8f:4f: + ad:47:2b:9d:71:68:cc:41:34:e5:d6:5a:66:2c:c2:2b:f1:74: + 4e:8d:ef:f7:4d:e4:54:0c:1a:05:ed:38:b1:9b:88:a8:05:43: + 1c:08:de:c0:7d:b2:7c:20:08:46:48:00:e9:13:e7:48:78:a8: + e8:d4:c2:2c:c8:b7:52:4a:ab:86:3e:5b:20:51:b2:7a:a7:00: + 2b:2d:1a:91:77:95:de:e2:c8:28:a6:3f:65:d3:69:3d:13:f9: + 81:6d:94:66:90:be:a7:d6:41:11:c5:43:34:a0:16:10:af:86: + 54:b0:da:af:53:0b:77:22:29:5f:20:a9:e3:08:a6:c7:88:8a: + f9:3c:97:11:82:91:2b:b1:b9:fb:f1:cf:b5:83:94:d8:ea:c7: + b6:e5:05:9e:9a:73:e0:6e:7f:42:ec:ae:0c:ee:f2:0c:02:5a: + 2b:c5:ff:f6:12:2e:47:8b:5c:c7:3b:77:15:d0:4c:55:78:ee: + e4:f5:62:32:92:9b:a7:0e:57:b2:56:c6:c5:d0:05:14:24:ab: + 91:24:6f:cd:8c:3d:f2:da:bb:1e:45:01:e4:8c:95:3a:08:e3: + 2c:d1:dd:26 +-----BEGIN CERTIFICATE----- +MIIDwzCCAqugAwIBAgIUZeSD7KNhTFOoqpI7cWxxWcN417EwDQYJKoZIhvcNAQEL +BQAwcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNVBAcM +CUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2ZXIx +FDASBgNVBAMMC2V4YW1wbGUuY29tMB4XDTI1MDExNDE1NDIwMFoXDTM1MDExMjE1 +NDIwMFowcTELMAkGA1UEBhMCVUsxEzARBgNVBAgMClNvbWUtU3RhdGUxEjAQBgNV +BAcMCUNhbWJyaWRnZTEPMA0GA1UECgwGQ2l0cml4MRIwEAYDVQQLDAlYZW5TZXJ2 +ZXIxFDASBgNVBAMMC2V4YW1wbGUuY29tMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEAu6imIgn7nIMyyF+/PzUwLRVwPewqdz350MKYvdLRdGJllDmznVXc +T9hR71E8jISLab4prL87V+dNwwtEO5SPf6JitwGzz8udZYUQikzIs/InNn5oh1PZ +Xj5pGTGSb9Kf3h4ACHDpiJeSnLr6CrzrrS5xU0Sq2IVEDLtnsgc9H/K82P+MoSyz +X5ZEFCd83N1tI3jLgFHou2Zrc46Y/rNy5ea8M1WBt8S253c6QkezWj+bmXHIQcob +Iq6IUfdJt3ULaxXbS05IgyfLyYVu89wMwANAbcPwrR9fxH/6x7d1xyhjCaCd50Ns +0b0rrXa0UgJJzamDjXtIcqy78jERp6O0owIDAQABo1MwUTAdBgNVHQ4EFgQUK3or +CHusUjk/eheKHz6JMuYQBkAwHwYDVR0jBBgwFoAUK3orCHusUjk/eheKHz6JMuYQ +BkAwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEATq7rhHQE3xSk +NUsD1dIFUwz7NJ1eIbdNQ8kJGybcTkIsBY9PrUcrnXFozEE05dZaZizCK/F0To3v +903kVAwaBe04sZuIqAVDHAjewH2yfCAIRkgA6RPnSHio6NTCLMi3Ukqrhj5bIFGy +eqcAKy0akXeV3uLIKKY/ZdNpPRP5gW2UZpC+p9ZBEcVDNKAWEK+GVLDar1MLdyIp +XyCp4wimx4iK+TyXEYKRK7G5+/HPtYOU2OrHtuUFnppz4G5/QuyuDO7yDAJaK8X/ +9hIuR4tcxzt3FdBMVXju5PViMpKbpw5XslbGxdAFFCSrkSRvzYw98tq7HkUB5IyV +OgjjLNHdJg== +-----END CERTIFICATE----- + + +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC7qKYiCfucgzLI +X78/NTAtFXA97Cp3PfnQwpi90tF0YmWUObOdVdxP2FHvUTyMhItpvimsvztX503D +C0Q7lI9/omK3AbPPy51lhRCKTMiz8ic2fmiHU9lePmkZMZJv0p/eHgAIcOmIl5Kc +uvoKvOutLnFTRKrYhUQMu2eyBz0f8rzY/4yhLLNflkQUJ3zc3W0jeMuAUei7Zmtz +jpj+s3Ll5rwzVYG3xLbndzpCR7NaP5uZcchByhsirohR90m3dQtrFdtLTkiDJ8vJ +hW7z3AzAA0Btw/CtH1/Ef/rHt3XHKGMJoJ3nQ2zRvSutdrRSAknNqYONe0hyrLvy +MRGno7SjAgMBAAECggEANHjKw1fRQAk7aOXE3xKrPt/wu4/Oq/rrYGEZPnK1WHqu +9oxP2d2JNdZBys4HRS9GoDGpC4GJQWIOz0vWL2ax3Tl1qsBSG/dOMnXLkzA3KoG6 +TzV3WueqLvz6fC3tSVE2nG/9CF8yHZxsRWDOy7PZnloPG/5mWxagWYMJUrFNeSH2 +nXd40Rff5uM43OzKtiOOzoKv2bKlKReyJVcI98MkyqSbUiie6qO1/NqrOUhq7rsV +zFmbtjy8UL4gXR2VVz0itb/w/iV/SDVHdMQ36obo8EM9eyxUFu4QPscrbK0FvjHV +lsKTnzu1zj/fm68NafXDy/KL5I9jethsj8ReNaQzoQKBgQDLkaIxBtNtAZfcFK7S +dXtR7fIQfUTtgDrxznYXPqCkCy/0wp53hj7aShX2C/rfFQVElBUPkf2E/P6v7Xnf +b+M/Zj6TH7XYbScoVu+8cqfIm1ySd3evK4GoqGIUiJeuSYEfeLqZSTp1XxO05lGb +ZmAEtZUHor24Co9HIV/3P86EcwKBgQDr/fqn6b6V1O64r7/cnOmWhW1+5MjoWO2K ++y0fSutrPMOFK4ItJIk4Q5JbHA42cwyYRMe+oElGXzWJXGbqxyorFhW0Er/+roTa +6GXwNrRkdA3S0rgPAE7IS42WLDsAO9/muiZJ4heXtk8i0xDoyy3Y8UQ/6hR4h1px +jtn9Bs4zEQKBgBdW+TuZxr/mwNyQ2oJyydLY7zoIwtBgNWHoBA4iNhTY24S6k6Ss +laQ9fksZkIfnRxVXzRpd6K1IvIK7PY/qqilotZ/0sMrBqQ2s+gunMamEdpasb+J7 +oIAP3j7wckOfVdif5PUSOkuevQmupoiksjmYACBB/nKNc2P6ZaBZhnoVAoGBAJuc +4z777BeCzFNuWJaRxZniq9wj4rMLiL+/dvaOgYQ6EjdrBDDeSbmXHRgE/P48iQ6T +NB9oNEk6GORV0Ot5nz3AF1mhj4bR73smCaoHeJZQzJi7KHGD429CGr/utI0n7jGH +iB3p/2Kj7bTp9tl6uOW32ihHI26C2knNR8MITMnxAoGAZ+Dpg1a6u2ZMTSgOn9Vc +pECwENGtOQP4RKyXmnq3ET5ykx1hMMCf9uoA09TXDRuJ/20hVfsAGvLZdbQq/9DL +C3bckcoalhy8RXC/OV9c6SC/xgoYiggxmZtzV34wnQSLM4Cr+Q/lhOaj7sop6iJi +apYRps2sXbUdu3pDTub/zSI= +-----END PRIVATE KEY----- diff --git a/ocaml/gencert/test_data/reformat.sh b/ocaml/gencert/test_data/reformat.sh new file mode 100755 index 00000000000..67bb040f08c --- /dev/null +++ b/ocaml/gencert/test_data/reformat.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash +# parse a PEM file for certificate and key and emit them again as a PEM +# to stdout. This is in response to XSI-1781. + +set -o errexit +set -o pipefail +if [[ -n "$TRACE" ]]; then set -o xtrace; fi +set -o nounset + +if [[ "${1-}" =~ ^-*h(elp)?$ ]]; then + cat < Date: Tue, 14 Jan 2025 15:24:43 +0000 Subject: [PATCH 69/73] CA-404640 XSI-1781 bring back fail-06.pem Add back a unit test. Signed-off-by: Christian Lindig --- ocaml/gencert/test_data/pems/fail-06.pem | 93 +----------------------- 1 file changed, 2 insertions(+), 91 deletions(-) diff --git a/ocaml/gencert/test_data/pems/fail-06.pem b/ocaml/gencert/test_data/pems/fail-06.pem index 05a638c7a02..6b63e248c1b 100644 --- a/ocaml/gencert/test_data/pems/fail-06.pem +++ b/ocaml/gencert/test_data/pems/fail-06.pem @@ -1,74 +1,4 @@ -This fails because we have two keys (rather than just one). - ------BEGIN CERTIFICATE----- -MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE -AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx -MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN -BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e -gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH -+vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG -hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS -WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx -ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB -oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN -AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb -LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF -GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl -erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ -/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA -JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= ------END CERTIFICATE----- - ------BEGIN CERTIFICATE----- -MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE -AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx -MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN -BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e -gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH -+vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG -hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS -WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx -ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB -oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN -AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb -LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF -GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl -erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ -/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA -JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= ------END CERTIFICATE----- - ------BEGIN PRIVATE KEY----- -MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH -tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI -r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 -eniepJw4K+SMqAaGUvdwWfe44pYjOsmAS3IWLERdpjxcupgvHLwEnk+4zheypp93 -iVvmqwrX8okLiJJZap1ew6EgKzeK2mw9HUed4d0AGKCkAhghzGTl/IsLz4QOOFes -rY4awQwzK1SwBvF49xAuOiRbURdzt+K7GsoN0lm5P8CxZmrDSGpGR1BICrMSatSG -N0NuOCJ9AgMBAAECggEATgm51VKZ0+Kew5Twjzo9bqGawPVHsiYDK9H+yL5+inij -gTWrhTWxxvq/KDwoS//6n3ipAd2UQNmfo5qQIsIJtawUsaw4V4Fh6BrIcGUUV3KK -8lG/bHoZOz0cfFCKewv5mJH4z/q9awk6ypVG3yb+kmoDHiJsy7Pmr0IpFn+qxMg1 -EYZU91G10DguXekciRtNcZJRL0wCQR3s2OwDdQUC+XIotvAsKiuhWl++MLwn42ad -EwhzLuLd312qWg58ByCcNq8/XJkHJUbKDTWmBRGopWRliduP+Kb6vJZ16KL0G2B+ -OKuTQxMOzVVmumXdEVj3kH54cjpn7kCq9jwhhSJiQQKBgQD94ZFOzsUzZfmNlDZ3 -hFmkFuFpQCacH58FQX/vD6JQ84HwEHJx69aHYI6olCNaKcNwMhsOw+0KqBRWZnCf -A6oMWUf3pkogV5JZJy7DyHNOmkfI/w8NcWtqJ03pCoA237f5RH0sul2ady9BVzsJ -/8rb3B5uDw8+XesnG8Ryj6BCsQKBgQD9rhKfHxJgsZUzyassIumYcLTefgdoeCq5 -awd+YaM9jrGGN1ty8dTEzo3rbovnz8y+ZJMzaDRbCUeNTQjKDox8mWffRTpjxcks -rJzImY7coBdnZT8K4C5OMoeCAr30FI1veXBk/XFfr56h1X8QbmM2kuJwpsf5bOaf -CTfL2q2XjQKBgHem4pvYuXoC2n1OV+k2GCVMn0nCcS/tez234/qgTKiISzoAFl/4 -fW/qIvHyd0LcIf7zrmrkDgiStJsPxo465N7TCSb/WToq649W9yRQiX+HGMPy6X41 -cSFjisWFLG4wO/2fuLrmzoypFT1fRjTtOAcsk67dLBsBmn0hChHP/QDRAoGASXS7 -XaogpzEk1A8kaq5dV8/i/74cpQqOzIwKanUZULzd+NBUwa72/loVTEQBbQmF7ueu -nCcjae0A9BCHaALYeUfuhP9Fzhg6jZ4Z9BhK/uW4gS8XFy4dGnWVOXdTy7ab0din -TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH -ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT -6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo -FIPEq03cDKVNDCgABw4mkw== ------END PRIVATE KEY----- - - ------BEGIN PRIVATE KEY----- +-----BEGIN RSA PRIVATE KEY----- MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQD7lI5jUArCqncH tzcSFK+OJgXMv16Ai0sjsLKmxUVCnlElen/0VEIyTWwsHeB+oxxDluGE8zhB9bSI r3C1xHEUgtgj+gf6/A0Qnl/fIGkhuOFsPoholxXXGk2QkPQlGrE9FRxFNGQpIur0 @@ -95,26 +25,8 @@ TAb7akqvM4tftMFSJz5XJWmV5Eq9aPXBW10iAQ0CgYBl6PsdqWBjvPnqX3NCyAGH ZO4iUcrqODdeTcKpILgqBmh9/IepClgCtwW1Iluna7QTDtVqotKcft1BtHJzeKWT 6TvCgje2k0RWo6TkzroaF74lyAojzWOrmuq+skVbWTiebc4bCA1KtLMLaQHIEtdo FIPEq03cDKVNDCgABw4mkw== ------END PRIVATE KEY----- +-----END EC PRIVATE KEY----- ------BEGIN CERTIFICATE----- -MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE -AwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMB4XDTIwMTAxNDE1NTc1MloXDTMwMTAx -MjE1NTc1MlowIDEeMBwGA1UEAwwVbGN5Mi1kdDExMC54ZW5ydGNsb3VkMIIBIjAN -BgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA+5SOY1AKwqp3B7c3EhSvjiYFzL9e -gItLI7CypsVFQp5RJXp/9FRCMk1sLB3gfqMcQ5bhhPM4QfW0iK9wtcRxFILYI/oH -+vwNEJ5f3yBpIbjhbD6IaJcV1xpNkJD0JRqxPRUcRTRkKSLq9Hp4nqScOCvkjKgG -hlL3cFn3uOKWIzrJgEtyFixEXaY8XLqYLxy8BJ5PuM4Xsqafd4lb5qsK1/KJC4iS -WWqdXsOhICs3itpsPR1HneHdABigpAIYIcxk5fyLC8+EDjhXrK2OGsEMMytUsAbx -ePcQLjokW1EXc7fiuxrKDdJZuT/AsWZqw0hqRkdQSAqzEmrUhjdDbjgifQIDAQAB -oyQwIjAgBgNVHREEGTAXghVsY3kyLWR0MTEwLnhlbnJ0Y2xvdWQwDQYJKoZIhvcN -AQELBQADggEBAHEkeEjHilXdVgQhD/z46prXObB26uO97yFUcUIalzhb/P3zmfjb -LFatTFn5jgienMmdP90uj7Ly1R6VOa+tX/o+XtSJaZwuNMtixv9qwo3nrFZdw8yF -GgsmbAR+1hu0TG3RNpDIiES4D3JmVP8MgmwLw1kN3cBVptx73lE3uc8vZnNtIDOl -erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ -/a2+BGYjCWJZyoLgmHcXEU8fOxe9yUWbFQf0wnqsLJIqzaQU1w2w6mkh4+xsI/nA -JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= ------END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIIC5jCCAc6gAwIBAgIIaYRSm3Q7zc8wDQYJKoZIhvcNAQELBQAwIDEeMBwGA1UE @@ -135,4 +47,3 @@ erJb9fD3IOv/RZ78mxMnajZTHY5kg2e96d/a6HgY39vXMwycjp8wIE/+4g94fIc/ JwFfXQKd3fzsvgmufpAbXt/AHljFvC/qjTI= -----END CERTIFICATE----- - From 5b86063ccfc77c49e82b097b6b0608bf41025e66 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 14 Jan 2025 15:32:18 +0000 Subject: [PATCH 70/73] Log proper names for POSIX signals The integer values that OCaml uses for signals should never be printed as they are. They can cause confusion because they don't match the C POSIX values. Change the unixext function that converts them to string to stop building a list and finding a value in the list to instead use pattern-matching. Also added some more values that got introduced in OCaml 4.03, and return a more compact value for unknown signals, following the same format as Fmt.Dump.signal Signed-off-by: Pau Ruiz Safont --- doc/content/design/coverage/index.md | 39 +++++---- .../lib/xapi-stdext-unix/unixext.ml | 86 ++++++++++++------- ocaml/nbd/src/cleanup.ml | 8 +- ocaml/nbd/src/dune | 2 +- ocaml/networkd/bin/network_server.ml | 3 +- ocaml/xapi-guard/lib/server_interface.ml | 3 +- ocaml/xapi/helpers.ml | 5 +- ocaml/xcp-rrdd/bin/rrdd/dune | 2 - ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml | 2 +- ocaml/xcp-rrdd/lib/plugin/utils.ml | 5 +- ocaml/xenopsd/lib/cancellable_subprocess.ml | 11 +-- ocaml/xenopsd/lib/xenopsd.ml | 7 +- 12 files changed, 107 insertions(+), 66 deletions(-) diff --git a/doc/content/design/coverage/index.md b/doc/content/design/coverage/index.md index 3b3f6ec3ec7..fae989b4867 100644 --- a/doc/content/design/coverage/index.md +++ b/doc/content/design/coverage/index.md @@ -8,7 +8,7 @@ revision: 2 We would like to add optional coverage profiling to existing [OCaml] projects in the context of [XenServer] and [XenAPI]. This article -presents how we do it. +presents how we do it. Binaries instrumented for coverage profiling in the XenServer project need to run in an environment where several services act together as @@ -21,7 +21,7 @@ isolation. To build binaries with coverage profiling, do: ./configure --enable-coverage - make + make Binaries will log coverage data to `/tmp/bisect*.out` from which a coverage report can be generated in `coverage/`: @@ -38,7 +38,7 @@ and logs during execution data to in-memory data structures. Before an instrumented binary terminates, it writes the logged data to a file. This data can then be analysed with the `bisect-ppx-report` tool, to produce a summary of annotated code that highlights what part of a -codebase was executed. +codebase was executed. [BisectPPX] has several desirable properties: @@ -65,13 +65,13 @@ abstracted by OCamlfind (OCaml's library manager) and OCamlbuild # build it with instrumentation from bisect_ppx ocamlbuild -use-ocamlfind -pkg bisect_ppx -pkg unix example.native - + # execute it - generates files ./bisect*.out ./example.native - + # generate report bisect-ppx-report -I _build -html coverage bisect000* - + # view coverage/index.html Summary: @@ -86,7 +86,7 @@ will be instrumented during compilation. Behind the scenes `ocamlfind` makes sure that the compiler uses a preprocessing step that instruments the code. -## Signal Handling +## Signal Handling During execution the code instrumentation leads to the collection of data. This code registers a function with `at_exit` that writes the data @@ -98,7 +98,8 @@ terminated by receiving the `TERM` signal, a signal handler must be installed: let stop signal = - printf "caught signal %d\n" signal; + let name = Xapi_stdext_unix.Unixext.string_of_signal signal in + printf "caught signal %s\n" name; exit 0 Sys.set_signal Sys.sigterm (Sys.Signal_handle stop) @@ -149,8 +150,8 @@ environment variable. This can happen on the command line: BISECT_FILE=/tmp/example ./example.native -In the context of XenServer we could do this in startup scripts. -However, we added a bit of code +In the context of XenServer we could do this in startup scripts. +However, we added a bit of code val Coverage.init: string -> unit @@ -176,12 +177,12 @@ Goals for instrumentation are: * what files are instrumented should be obvious and easy to manage * instrumentation must be optional, yet easy to activate -* avoid methods that require to keep several files in sync like multiple +* avoid methods that require to keep several files in sync like multiple `_oasis` files * avoid separate Git branches for instrumented and non-instrumented code -In the ideal case, we could introduce a configuration switch +In the ideal case, we could introduce a configuration switch `./configure --enable-coverage` that would prepare compilation for coverage instrumentation. While [Oasis] supports the creation of such switches, they cannot be used to control build dependencies like @@ -196,7 +197,7 @@ rules in file `_tags.coverage` that cause files to be instrumented: leads to the execution of this code during preparation: - coverage: _tags _tags.coverage + coverage: _tags _tags.coverage test ! -f _tags.orig && mv _tags _tags.orig || true cat _tags.coverage _tags.orig > _tags @@ -207,7 +208,7 @@ could be tweaked to instrument only some files: <**/*.native>: pkg_bisect_ppx When `make coverage` is not called, these rules are not active and -hence, code is not instrumented for coverage. We believe that this +hence, code is not instrumented for coverage. We believe that this solution to control instrumentation meets the goals from above. In particular, what files are instrumented and when is controlled by very few lines of declarative code that lives in the main repository of a @@ -226,14 +227,14 @@ coverage analysis are: The `_oasis` file bundles the files under `profiling/` into an internal library which executables then depend on: - # Support files for profiling + # Support files for profiling Library profiling CompiledObject: best Path: profiling Install: false Findlibname: profiling Modules: Coverage - BuildDepends: + BuildDepends: Executable set_domain_uuid CompiledObject: best @@ -243,8 +244,8 @@ library which executables then depend on: MainIs: set_domain_uuid.ml Install: false BuildDepends: - xenctrl, - uuidm, + xenctrl, + uuidm, cmdliner, profiling # <-- here @@ -252,7 +253,7 @@ The `Makefile` target `coverage` primes the project for a profiling build: # make coverage - prepares for building with coverage analysis - coverage: _tags _tags.coverage + coverage: _tags _tags.coverage test ! -f _tags.orig && mv _tags _tags.orig || true cat _tags.coverage _tags.orig > _tags diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index 4a8dc687989..caa5e620b4a 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -371,35 +371,63 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = raise Process_still_alive ) -let string_of_signal x = - let table = - [ - (Sys.sigabrt, "SIGABRT") - ; (Sys.sigalrm, "SIGALRM") - ; (Sys.sigfpe, "SIGFPE") - ; (Sys.sighup, "SIGHUP") - ; (Sys.sigill, "SIGILL") - ; (Sys.sigint, "SIGINT") - ; (Sys.sigkill, "SIGKILL") - ; (Sys.sigpipe, "SIGPIPE") - ; (Sys.sigquit, "SIGQUIT") - ; (Sys.sigsegv, "SIGSEGV") - ; (Sys.sigterm, "SIGTERM") - ; (Sys.sigusr1, "SIGUSR1") - ; (Sys.sigusr2, "SIGUSR2") - ; (Sys.sigchld, "SIGCHLD") - ; (Sys.sigcont, "SIGCONT") - ; (Sys.sigstop, "SIGSTOP") - ; (Sys.sigttin, "SIGTTIN") - ; (Sys.sigttou, "SIGTTOU") - ; (Sys.sigvtalrm, "SIGVTALRM") - ; (Sys.sigprof, "SIGPROF") - ] - in - if List.mem_assoc x table then - List.assoc x table - else - Printf.sprintf "(ocaml signal %d with an unknown name)" x +let string_of_signal = function + | s when s = Sys.sigabrt -> + "SIGABRT" + | s when s = Sys.sigalrm -> + "SIGALRM" + | s when s = Sys.sigfpe -> + "SIGFPE" + | s when s = Sys.sighup -> + "SIGHUP" + | s when s = Sys.sigill -> + "SIGILL" + | s when s = Sys.sigint -> + "SIGINT" + | s when s = Sys.sigkill -> + "SIGKILL" + | s when s = Sys.sigpipe -> + "SIGPIPE" + | s when s = Sys.sigquit -> + "SIGQUIT" + | s when s = Sys.sigsegv -> + "SIGSEGV" + | s when s = Sys.sigterm -> + "SIGTERM" + | s when s = Sys.sigusr1 -> + "SIGUSR1" + | s when s = Sys.sigusr2 -> + "SIGUSR2" + | s when s = Sys.sigchld -> + "SIGCHLD" + | s when s = Sys.sigcont -> + "SIGCONT" + | s when s = Sys.sigstop -> + "SIGSTOP" + | s when s = Sys.sigttin -> + "SIGTTIN" + | s when s = Sys.sigttou -> + "SIGTTOU" + | s when s = Sys.sigvtalrm -> + "SIGVTALRM" + | s when s = Sys.sigprof -> + "SIGPROF" + | s when s = Sys.sigbus -> + "SIGBUS" + | s when s = Sys.sigpoll -> + "SIGPOLL" + | s when s = Sys.sigsys -> + "SIGSYS" + | s when s = Sys.sigtrap -> + "SIGTRAP" + | s when s = Sys.sigurg -> + "SIGURG" + | s when s = Sys.sigxcpu -> + "SIGXCPU" + | s when s = Sys.sigxfsz -> + "SIGXFSZ" + | s -> + Printf.sprintf "SIG(%d)" s let with_polly f = let polly = Polly.create () in diff --git a/ocaml/nbd/src/cleanup.ml b/ocaml/nbd/src/cleanup.ml index a3c0fd60d35..15294e3a02d 100644 --- a/ocaml/nbd/src/cleanup.ml +++ b/ocaml/nbd/src/cleanup.ml @@ -218,6 +218,11 @@ module Runtime = struct Printf.eprintf "SIGINT received - exiting" ; flush stderr ; exit 0 + | Signal n -> + Printf.eprintf "unexpected signal %s in signal handler - exiting" + (Xapi_stdext_unix.Unixext.string_of_signal n) ; + flush stderr ; + exit 1 | e -> Printf.eprintf "unexpected exception %s in signal handler - exiting" (Printexc.to_string e) ; @@ -225,8 +230,9 @@ module Runtime = struct exit 1 let cleanup_resources signal = + let name = Xapi_stdext_unix.Unixext.string_of_signal signal in let cleanup () = - Lwt_log.warning_f "Caught signal %d, cleaning up" signal >>= fun () -> + Lwt_log.warning_f "Caught signal %s, cleaning up" name >>= fun () -> (* First we have to close the open file descriptors corresponding to the VDIs we plugged to dom0. Otherwise the VDI.unplug call would hang. *) ignore_exn_log_error "Caught exception while closing open block devices" diff --git a/ocaml/nbd/src/dune b/ocaml/nbd/src/dune index 076e6884786..6c8c576295f 100644 --- a/ocaml/nbd/src/dune +++ b/ocaml/nbd/src/dune @@ -4,7 +4,6 @@ (libraries cmdliner consts - local_xapi_session lwt lwt.unix @@ -20,6 +19,7 @@ xapi-consts xapi-inventory xapi-types + xapi-stdext-unix xen-api-client-lwt ) ) diff --git a/ocaml/networkd/bin/network_server.ml b/ocaml/networkd/bin/network_server.ml index b398ca93b8c..8c3b78946f3 100644 --- a/ocaml/networkd/bin/network_server.ml +++ b/ocaml/networkd/bin/network_server.ml @@ -53,7 +53,8 @@ let on_shutdown signal = let dbg = "shutdown" in Debug.with_thread_associated dbg (fun () -> - debug "xcp-networkd caught signal %d; performing cleanup actions." signal ; + debug "xcp-networkd caught signal %s; performing cleanup actions." + (Xapi_stdext_unix.Unixext.string_of_signal signal) ; write_config () ) () diff --git a/ocaml/xapi-guard/lib/server_interface.ml b/ocaml/xapi-guard/lib/server_interface.ml index c6f70769313..fc09c32c520 100644 --- a/ocaml/xapi-guard/lib/server_interface.ml +++ b/ocaml/xapi-guard/lib/server_interface.ml @@ -38,7 +38,8 @@ let shutdown = Lwt_switch.create () let () = let cleanup n = - debug "Triggering cleanup on signal %d, and waiting for servers to stop" n ; + let n = Fmt.(to_to_string Dump.signal n) in + debug "Triggering cleanup on signal %s, and waiting for servers to stop" n ; Lwt.async (fun () -> let* () = Lwt_switch.turn_off shutdown in info "Cleanup complete, exiting" ; diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 68dde2a1c48..3323788a856 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -104,14 +104,15 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = (ExnHelper.string_of_exn e) ; raise e | Forkhelpers.Spawn_internal_error (stderr, stdout, status) as e -> + let signal = Unixext.string_of_signal in let message = match status with | Unix.WEXITED n -> Printf.sprintf "exited with code %d" n | Unix.WSIGNALED n -> - Printf.sprintf "was killed by signal %d" n + Printf.sprintf "was killed by signal %s" (signal n) | Unix.WSTOPPED n -> - Printf.sprintf "was stopped by signal %d" n + Printf.sprintf "was stopped by signal %s" (signal n) in if should_log_output_on_failure then debug "%s %s %s [stdout = '%s'; stderr = '%s']" script diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index c31182e4142..b8419b12fb8 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -5,7 +5,6 @@ (modules (:standard \ xcp_rrdd)) (libraries astring - ezxenstore gzip http_lib @@ -41,7 +40,6 @@ (modules xcp_rrdd) (libraries astring - ezxenstore.core ezxenstore.watch forkexec diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index bb0285b4b18..4cdc21a289f 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -735,7 +735,7 @@ let configure_writers () = (** we need to make sure we call exit on fatal signals to make sure profiling data is dumped *) let stop err writers signal = - debug "caught signal %d" signal ; + debug "caught signal %s" (Xapi_stdext_unix.Unixext.string_of_signal signal) ; List.iter (fun (_, writer) -> writer.Rrd_writer.cleanup ()) writers ; exit err diff --git a/ocaml/xcp-rrdd/lib/plugin/utils.ml b/ocaml/xcp-rrdd/lib/plugin/utils.ml index d647c25fd67..a0db8d6269f 100644 --- a/ocaml/xcp-rrdd/lib/plugin/utils.ml +++ b/ocaml/xcp-rrdd/lib/plugin/utils.ml @@ -59,12 +59,13 @@ let exec_cmd (module D : Debug.DEBUG) ~cmdstring ~(f : string -> 'a option) = (try loop () with End_of_file -> ()) ; Unix.close out_readme ; let pid, status = Forkhelpers.waitpid pid in + let signal = Xapi_stdext_unix.Unixext.string_of_signal in ( match status with | Unix.WEXITED n -> D.debug "Process %d exited normally with code %d" pid n | Unix.WSIGNALED s -> - D.debug "Process %d was killed by signal %d" pid s + D.debug "Process %d was killed by signal %s" pid (signal s) | Unix.WSTOPPED s -> - D.debug "Process %d was stopped by signal %d" pid s + D.debug "Process %d was stopped by signal %s" pid (signal s) ) ; List.rev !vals diff --git a/ocaml/xenopsd/lib/cancellable_subprocess.ml b/ocaml/xenopsd/lib/cancellable_subprocess.ml index 0ba4edeb71c..097be7d3014 100644 --- a/ocaml/xenopsd/lib/cancellable_subprocess.ml +++ b/ocaml/xenopsd/lib/cancellable_subprocess.ml @@ -76,16 +76,17 @@ let run (task : Xenops_task.task_handle) ?env ?stdin fds raise (Spawn_internal_error (err, out, Unix.WEXITED n)) | Unix.WSTOPPED n -> raise (Spawn_internal_error (err, out, Unix.WSTOPPED n)) - | Unix.WSIGNALED n -> + | Unix.WSIGNALED s -> + let signal = Unixext.string_of_signal s in if !cancelled then ( debug - "Subprocess %s exited with signal %d and cancel requested; \ + "Subprocess %s exited with signal %s and cancel requested; \ raising Cancelled" - cmd n ; + cmd signal ; Xenops_task.raise_cancelled task ) else ( - debug "Subprocess %s exited with signal %d" cmd n ; - raise (Spawn_internal_error (err, out, Unix.WSIGNALED n)) + debug "Subprocess %s exited with signal %s" cmd signal ; + raise (Spawn_internal_error (err, out, Unix.WSIGNALED s)) ) ) | Success (_, Failure (_, exn)) | Failure (_, exn) -> diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index a0b192e6824..6f3b2bff058 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -459,8 +459,11 @@ let main backend = ~rpc_fn () in (* we need to catch this to make sure at_exit handlers are triggered. In - particuar, triggers for the bisect_ppx coverage profiling *) - let signal_handler n = debug "caught signal %d" n ; exit 0 in + particular, triggers for the bisect_ppx coverage profiling *) + let signal_handler n = + debug "caught signal %s" (Unixext.string_of_signal n) ; + exit 0 + in Sys.set_signal Sys.sigpipe Sys.Signal_ignore ; Sys.set_signal Sys.sigterm (Sys.Signal_handle signal_handler) ; Xenops_utils.set_fs_backend From c0fbb69d391b2d2341ba9e50dc04d7c02611e234 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 14 Jan 2025 16:46:48 +0000 Subject: [PATCH 71/73] Debug: add pretty-printing function for signals When signals are are written to logs, the POSIX name should be used to minimize confusion. It makes sense that the function that does this is in the logging library instead of the unix one, as most users will be already be using the logging library, but not all the unix one. Moving it there also allows for a more ergonomic usage with the logging functions. Signed-off-by: Pau Ruiz Safont --- doc/content/design/coverage/index.md | 3 +- ocaml/forkexecd/src/child.ml | 4 +- ocaml/libs/log/debug.ml | 6 +- ocaml/libs/log/debug.mli | 4 ++ .../libs/xapi-compression/xapi_compression.ml | 9 +-- .../lib/xapi-stdext-unix/unixext.ml | 58 ------------------- .../lib/xapi-stdext-unix/unixext.mli | 4 -- ocaml/nbd/src/cleanup.ml | 4 +- ocaml/nbd/src/dune | 2 +- ocaml/networkd/bin/network_server.ml | 4 +- ocaml/xapi-guard/lib/server_interface.ml | 4 +- ocaml/xapi/helpers.ml | 5 +- ocaml/xapi/sm_exec.ml | 2 +- ocaml/xapi/xapi_extensions.ml | 3 +- ocaml/xapi/xapi_plugins.ml | 7 +-- ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml | 2 +- ocaml/xcp-rrdd/lib/plugin/utils.ml | 5 +- ocaml/xenopsd/lib/cancellable_subprocess.ml | 7 +-- ocaml/xenopsd/lib/suspend_image.ml | 8 +-- ocaml/xenopsd/lib/xenopsd.ml | 2 +- 20 files changed, 37 insertions(+), 106 deletions(-) diff --git a/doc/content/design/coverage/index.md b/doc/content/design/coverage/index.md index fae989b4867..27ccd0d469a 100644 --- a/doc/content/design/coverage/index.md +++ b/doc/content/design/coverage/index.md @@ -98,8 +98,7 @@ terminated by receiving the `TERM` signal, a signal handler must be installed: let stop signal = - let name = Xapi_stdext_unix.Unixext.string_of_signal signal in - printf "caught signal %s\n" name; + printf "caught signal %a\n" Debug.Pp.signal signal; exit 0 Sys.set_signal Sys.sigterm (Sys.Signal_handle stop) diff --git a/ocaml/forkexecd/src/child.ml b/ocaml/forkexecd/src/child.ml index 1512e3af851..5f79f2fb6c9 100644 --- a/ocaml/forkexecd/src/child.ml +++ b/ocaml/forkexecd/src/child.ml @@ -111,11 +111,11 @@ let report_child_exit comms_sock args child_pid status = Fe.WEXITED n | Unix.WSIGNALED n -> log_failure args child_pid - (Printf.sprintf "exited with signal: %s" (Unixext.string_of_signal n)) ; + (Printf.sprintf "exited with signal: %a" Debug.Pp.signal n) ; Fe.WSIGNALED n | Unix.WSTOPPED n -> log_failure args child_pid - (Printf.sprintf "stopped with signal: %s" (Unixext.string_of_signal n)) ; + (Printf.sprintf "stopped with signal: %a" Debug.Pp.signal n) ; Fe.WSTOPPED n in let result = Fe.Finished pr in diff --git a/ocaml/libs/log/debug.ml b/ocaml/libs/log/debug.ml index 5e63bc2b008..2f73cd47aca 100644 --- a/ocaml/libs/log/debug.ml +++ b/ocaml/libs/log/debug.ml @@ -353,4 +353,8 @@ functor with e -> log_backtrace_internal ~level:Syslog.Debug ~msg:"debug" e () end -module Pp = struct let mtime_span () = Fmt.str "%a" Mtime.Span.pp end +module Pp = struct + let mtime_span () = Fmt.to_to_string Mtime.Span.pp + + let signal () = Fmt.(to_to_string Dump.signal) +end diff --git a/ocaml/libs/log/debug.mli b/ocaml/libs/log/debug.mli index f6301c3d587..4ba72886ce6 100644 --- a/ocaml/libs/log/debug.mli +++ b/ocaml/libs/log/debug.mli @@ -91,4 +91,8 @@ val is_disabled : string -> Syslog.level -> bool module Pp : sig val mtime_span : unit -> Mtime.Span.t -> string + + val signal : unit -> int -> string + (** signal pretty-prints an ocaml signal number as its POSIX name, see + {Fmt.Dump.signal} *) end diff --git a/ocaml/libs/xapi-compression/xapi_compression.ml b/ocaml/libs/xapi-compression/xapi_compression.ml index a0ca8bdc6d5..7349cdef732 100644 --- a/ocaml/libs/xapi-compression/xapi_compression.ml +++ b/ocaml/libs/xapi-compression/xapi_compression.ml @@ -123,7 +123,6 @@ module Make (Algorithm : ALGORITHM) = struct error "%s" msg ; failwith msg in Unixfd.safe_close close_later ; - let open Xapi_stdext_unix in match snd (Forkhelpers.waitpid pid) with | Unix.WEXITED 0 -> () @@ -131,14 +130,10 @@ module Make (Algorithm : ALGORITHM) = struct failwith_error (Printf.sprintf "exit code %d" i) | Unix.WSIGNALED i -> failwith_error - (Printf.sprintf "killed by signal: %s" - (Unixext.string_of_signal i) - ) + (Printf.sprintf "killed by signal: %a" Debug.Pp.signal i) | Unix.WSTOPPED i -> failwith_error - (Printf.sprintf "stopped by signal: %s" - (Unixext.string_of_signal i) - ) + (Printf.sprintf "stopped by signal: %a" Debug.Pp.signal i) ) let compress fd f = go Compress Active fd f diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml index caa5e620b4a..111599f89d5 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml @@ -371,64 +371,6 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid = raise Process_still_alive ) -let string_of_signal = function - | s when s = Sys.sigabrt -> - "SIGABRT" - | s when s = Sys.sigalrm -> - "SIGALRM" - | s when s = Sys.sigfpe -> - "SIGFPE" - | s when s = Sys.sighup -> - "SIGHUP" - | s when s = Sys.sigill -> - "SIGILL" - | s when s = Sys.sigint -> - "SIGINT" - | s when s = Sys.sigkill -> - "SIGKILL" - | s when s = Sys.sigpipe -> - "SIGPIPE" - | s when s = Sys.sigquit -> - "SIGQUIT" - | s when s = Sys.sigsegv -> - "SIGSEGV" - | s when s = Sys.sigterm -> - "SIGTERM" - | s when s = Sys.sigusr1 -> - "SIGUSR1" - | s when s = Sys.sigusr2 -> - "SIGUSR2" - | s when s = Sys.sigchld -> - "SIGCHLD" - | s when s = Sys.sigcont -> - "SIGCONT" - | s when s = Sys.sigstop -> - "SIGSTOP" - | s when s = Sys.sigttin -> - "SIGTTIN" - | s when s = Sys.sigttou -> - "SIGTTOU" - | s when s = Sys.sigvtalrm -> - "SIGVTALRM" - | s when s = Sys.sigprof -> - "SIGPROF" - | s when s = Sys.sigbus -> - "SIGBUS" - | s when s = Sys.sigpoll -> - "SIGPOLL" - | s when s = Sys.sigsys -> - "SIGSYS" - | s when s = Sys.sigtrap -> - "SIGTRAP" - | s when s = Sys.sigurg -> - "SIGURG" - | s when s = Sys.sigxcpu -> - "SIGXCPU" - | s when s = Sys.sigxfsz -> - "SIGXFSZ" - | s -> - Printf.sprintf "SIG(%d)" s - let with_polly f = let polly = Polly.create () in let finally () = Polly.close polly in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli index bec31c222a6..047935b475c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli @@ -122,10 +122,6 @@ exception Process_still_alive val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit -val string_of_signal : int -> string -(** [string_of_signal x] translates an ocaml signal number into - * a string suitable for logging. *) - val proxy : Unix.file_descr -> Unix.file_descr -> unit val really_read : Unix.file_descr -> bytes -> int -> int -> unit diff --git a/ocaml/nbd/src/cleanup.ml b/ocaml/nbd/src/cleanup.ml index 15294e3a02d..c4affe38628 100644 --- a/ocaml/nbd/src/cleanup.ml +++ b/ocaml/nbd/src/cleanup.ml @@ -220,7 +220,7 @@ module Runtime = struct exit 0 | Signal n -> Printf.eprintf "unexpected signal %s in signal handler - exiting" - (Xapi_stdext_unix.Unixext.string_of_signal n) ; + Fmt.(to_to_string Dump.signal n) ; flush stderr ; exit 1 | e -> @@ -230,7 +230,7 @@ module Runtime = struct exit 1 let cleanup_resources signal = - let name = Xapi_stdext_unix.Unixext.string_of_signal signal in + let name = Fmt.(to_to_string Dump.signal signal) in let cleanup () = Lwt_log.warning_f "Caught signal %s, cleaning up" name >>= fun () -> (* First we have to close the open file descriptors corresponding to the diff --git a/ocaml/nbd/src/dune b/ocaml/nbd/src/dune index 6c8c576295f..02c9dc6a0ed 100644 --- a/ocaml/nbd/src/dune +++ b/ocaml/nbd/src/dune @@ -4,6 +4,7 @@ (libraries cmdliner consts + fmt local_xapi_session lwt lwt.unix @@ -19,7 +20,6 @@ xapi-consts xapi-inventory xapi-types - xapi-stdext-unix xen-api-client-lwt ) ) diff --git a/ocaml/networkd/bin/network_server.ml b/ocaml/networkd/bin/network_server.ml index 8c3b78946f3..8cc5e9ea908 100644 --- a/ocaml/networkd/bin/network_server.ml +++ b/ocaml/networkd/bin/network_server.ml @@ -53,8 +53,8 @@ let on_shutdown signal = let dbg = "shutdown" in Debug.with_thread_associated dbg (fun () -> - debug "xcp-networkd caught signal %s; performing cleanup actions." - (Xapi_stdext_unix.Unixext.string_of_signal signal) ; + debug "xcp-networkd caught signal %a; performing cleanup actions." + Debug.Pp.signal signal ; write_config () ) () diff --git a/ocaml/xapi-guard/lib/server_interface.ml b/ocaml/xapi-guard/lib/server_interface.ml index fc09c32c520..8a64a576897 100644 --- a/ocaml/xapi-guard/lib/server_interface.ml +++ b/ocaml/xapi-guard/lib/server_interface.ml @@ -38,8 +38,8 @@ let shutdown = Lwt_switch.create () let () = let cleanup n = - let n = Fmt.(to_to_string Dump.signal n) in - debug "Triggering cleanup on signal %s, and waiting for servers to stop" n ; + debug "Triggering cleanup on signal %a, and waiting for servers to stop" + Debug.Pp.signal n ; Lwt.async (fun () -> let* () = Lwt_switch.turn_off shutdown in info "Cleanup complete, exiting" ; diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 3323788a856..4d1ede48abd 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -104,15 +104,14 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = (ExnHelper.string_of_exn e) ; raise e | Forkhelpers.Spawn_internal_error (stderr, stdout, status) as e -> - let signal = Unixext.string_of_signal in let message = match status with | Unix.WEXITED n -> Printf.sprintf "exited with code %d" n | Unix.WSIGNALED n -> - Printf.sprintf "was killed by signal %s" (signal n) + Printf.sprintf "was killed by signal %a" Debug.Pp.signal n | Unix.WSTOPPED n -> - Printf.sprintf "was stopped by signal %s" (signal n) + Printf.sprintf "was stopped by signal %a" Debug.Pp.signal n in if should_log_output_on_failure then debug "%s %s %s [stdout = '%s'; stderr = '%s']" script diff --git a/ocaml/xapi/sm_exec.ml b/ocaml/xapi/sm_exec.ml index 28cdd11e07b..d97e8f41e9b 100644 --- a/ocaml/xapi/sm_exec.ml +++ b/ocaml/xapi/sm_exec.ml @@ -393,7 +393,7 @@ let exec_xmlrpc ~dbg ?context:_ ?(needs_session = true) (driver : string) (Backend_error ( Api_errors.sr_backend_failure , [ - "received signal: " ^ Unixext.string_of_signal i + Printf.sprintf "received signal: %a" Debug.Pp.signal i ; output ; log ] diff --git a/ocaml/xapi/xapi_extensions.ml b/ocaml/xapi/xapi_extensions.ml index dbc38349bdc..301a0a5e686 100644 --- a/ocaml/xapi/xapi_extensions.ml +++ b/ocaml/xapi/xapi_extensions.ml @@ -50,8 +50,7 @@ let call_extension rpc = ( Api_errors.internal_error , [ path - ; Printf.sprintf "signal: %s" - (Xapi_stdext_unix.Unixext.string_of_signal i) + ; Printf.sprintf "signal: %a" Debug.Pp.signal i ; output ; log ] diff --git a/ocaml/xapi/xapi_plugins.ml b/ocaml/xapi/xapi_plugins.ml index 68447081136..3d9b7f0a2d0 100644 --- a/ocaml/xapi/xapi_plugins.ml +++ b/ocaml/xapi/xapi_plugins.ml @@ -49,12 +49,7 @@ let call_plugin session_id plugin_name fn_name args = raise (Api_errors.Server_error ( Api_errors.xenapi_plugin_failure - , [ - Printf.sprintf "signal: %s" - (Xapi_stdext_unix.Unixext.string_of_signal i) - ; output - ; log - ] + , [Printf.sprintf "signal: %a" Debug.Pp.signal i; output; log] ) ) | Forkhelpers.Spawn_internal_error (log, output, Unix.WEXITED _) -> diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 4cdc21a289f..afca11c3ced 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -735,7 +735,7 @@ let configure_writers () = (** we need to make sure we call exit on fatal signals to make sure profiling data is dumped *) let stop err writers signal = - debug "caught signal %s" (Xapi_stdext_unix.Unixext.string_of_signal signal) ; + debug "caught signal %a" Debug.Pp.signal signal ; List.iter (fun (_, writer) -> writer.Rrd_writer.cleanup ()) writers ; exit err diff --git a/ocaml/xcp-rrdd/lib/plugin/utils.ml b/ocaml/xcp-rrdd/lib/plugin/utils.ml index a0db8d6269f..1f0f6f153e9 100644 --- a/ocaml/xcp-rrdd/lib/plugin/utils.ml +++ b/ocaml/xcp-rrdd/lib/plugin/utils.ml @@ -59,13 +59,12 @@ let exec_cmd (module D : Debug.DEBUG) ~cmdstring ~(f : string -> 'a option) = (try loop () with End_of_file -> ()) ; Unix.close out_readme ; let pid, status = Forkhelpers.waitpid pid in - let signal = Xapi_stdext_unix.Unixext.string_of_signal in ( match status with | Unix.WEXITED n -> D.debug "Process %d exited normally with code %d" pid n | Unix.WSIGNALED s -> - D.debug "Process %d was killed by signal %s" pid (signal s) + D.debug "Process %d was killed by signal %a" pid Debug.Pp.signal s | Unix.WSTOPPED s -> - D.debug "Process %d was stopped by signal %s" pid (signal s) + D.debug "Process %d was stopped by signal %a" pid Debug.Pp.signal s ) ; List.rev !vals diff --git a/ocaml/xenopsd/lib/cancellable_subprocess.ml b/ocaml/xenopsd/lib/cancellable_subprocess.ml index 097be7d3014..4e80c34ac28 100644 --- a/ocaml/xenopsd/lib/cancellable_subprocess.ml +++ b/ocaml/xenopsd/lib/cancellable_subprocess.ml @@ -77,15 +77,14 @@ let run (task : Xenops_task.task_handle) ?env ?stdin fds | Unix.WSTOPPED n -> raise (Spawn_internal_error (err, out, Unix.WSTOPPED n)) | Unix.WSIGNALED s -> - let signal = Unixext.string_of_signal s in if !cancelled then ( debug - "Subprocess %s exited with signal %s and cancel requested; \ + "Subprocess %s exited with signal %a and cancel requested; \ raising Cancelled" - cmd signal ; + cmd Debug.Pp.signal s ; Xenops_task.raise_cancelled task ) else ( - debug "Subprocess %s exited with signal %s" cmd signal ; + debug "Subprocess %s exited with signal %a" cmd Debug.Pp.signal s ; raise (Spawn_internal_error (err, out, Unix.WSIGNALED s)) ) ) diff --git a/ocaml/xenopsd/lib/suspend_image.ml b/ocaml/xenopsd/lib/suspend_image.ml index e08cb53c268..8733b9155cf 100644 --- a/ocaml/xenopsd/lib/suspend_image.ml +++ b/ocaml/xenopsd/lib/suspend_image.ml @@ -275,15 +275,15 @@ let with_conversion_script task name hvm fd f = | Unix.WSIGNALED n -> Error (Failure - (Printf.sprintf "Conversion script exited with signal %s" - (Unixext.string_of_signal n) + (Printf.sprintf "Conversion script exited with signal %a" + Debug.Pp.signal n ) ) | Unix.WSTOPPED n -> Error (Failure - (Printf.sprintf "Conversion script stopped with signal %s" - (Unixext.string_of_signal n) + (Printf.sprintf "Conversion script stopped with signal %a" + Debug.Pp.signal n ) ) ) diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 6f3b2bff058..cb79fd20991 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -461,7 +461,7 @@ let main backend = (* we need to catch this to make sure at_exit handlers are triggered. In particular, triggers for the bisect_ppx coverage profiling *) let signal_handler n = - debug "caught signal %s" (Unixext.string_of_signal n) ; + debug "caught signal %a" Debug.Pp.signal n ; exit 0 in Sys.set_signal Sys.sigpipe Sys.Signal_ignore ; From 0326d2785b0b643492e9d42b42a44f4c8a01ee7e Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 15 Jan 2025 16:01:45 +0000 Subject: [PATCH 72/73] CA-404597: rrd/lib_test - Verify that RRD handles non-rate data sources correctly Other unit tests only verify the interoperability of the RRDs - dumping them to JSON/XML and reading back in, verifying that the same data was decoded. We're now seeing a problem where Gauge data sources, which should be absolute values provided by the plugin, fluctuate wildly when processed by the RRD library. Ensure we have an easy way to test this for both Gauge and Absolute data sources - these values should be passed as-is by the RRD library, without any time-based transformations. This test currently fails and will be passing with the fix commits. Signed-off-by: Andrii Sultanov --- ocaml/libs/xapi-rrd/lib_test/unit_tests.ml | 109 ++++++++++++++++++++- 1 file changed, 108 insertions(+), 1 deletion(-) diff --git a/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml index f9cb5765b9f..1bcd65ad7d3 100644 --- a/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml +++ b/ocaml/libs/xapi-rrd/lib_test/unit_tests.ml @@ -107,6 +107,110 @@ let test_length_invariants rrd () = let check_length dss rra = check_length_of_fring dss rra.rra_data in Array.iter (check_length rrd.rrd_dss) rrd.rrd_rras +let absolute_rrd = + let rra = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Average 100 10 0.5 in + let rra3 = rra_create CF_Average 100 100 0.5 in + let rra4 = rra_create CF_Average 100 1000 0.5 in + let ts = 1000000000.0 in + let ds = ds_create "foo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds2 = ds_create "bar" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds3 = ds_create "baz" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds4 = ds_create "boo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let rrd = rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L ts in + let id = Identity in + for i = 1 to 100000 do + let t = 1000000.0 +. (0.7 *. float_of_int i) in + let v1 = + (0, {value= VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))); transform= id}) + in + let v2 = + (1, {value= VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))); transform= id}) + in + let v3 = + (2, {value= VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))); transform= id}) + in + let v4 = + (3, {value= VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))); transform= id}) + in + ds_update rrd t [|v1; v2; v3; v4|] false + done ; + rrd + +let absolute_rrd_CA_404597 () = + let rra = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Average 100 10 0.5 in + let rra3 = rra_create CF_Average 100 100 0.5 in + let rra4 = rra_create CF_Average 100 1000 0.5 in + let ts = 1000000000.0 in + let ds = ds_create "foo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds2 = ds_create "bar" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds3 = ds_create "baz" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let ds4 = ds_create "boo" Absolute ~mrhb:10.0 (VT_Float 0.0) in + let rrd = rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L ts in + let id = Identity in + for i = 1 to 100000 do + let t = 1000000.0 +. (0.7 *. float_of_int i) in + let ((_, val1) as v1) = + (0, {value= VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))); transform= id}) + in + let ((_, val2) as v2) = + (1, {value= VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))); transform= id}) + in + let ((_, val3) as v3) = + (2, {value= VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))); transform= id}) + in + let ((_, val4) as v4) = + (3, {value= VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))); transform= id}) + in + ds_update rrd t [|v1; v2; v3; v4|] false ; + + Array.iter2 + (fun ds value -> + compare_float __LOC__ ds.ds_value + (float_of_string (ds_value_to_string value.value)) + ) + rrd.rrd_dss [|val1; val2; val3; val4|] + done + +(** Verify that Gauge data soruce values are correctly handled by the RRD lib + and that timestamps do not cause absolute values to fluctuate *) +let gauge_rrd_CA_404597 () = + let rra = rra_create CF_Average 100 1 0.5 in + let rra2 = rra_create CF_Average 100 10 0.5 in + let rra3 = rra_create CF_Average 100 100 0.5 in + let rra4 = rra_create CF_Average 100 1000 0.5 in + let ts = 1000000000.0 in + let ds = ds_create "foo" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds2 = ds_create "bar" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds3 = ds_create "baz" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let ds4 = ds_create "boo" Gauge ~mrhb:10.0 (VT_Float 0.0) in + let rrd = rrd_create [|ds; ds2; ds3; ds4|] [|rra; rra2; rra3; rra4|] 1L ts in + let id = Identity in + for i = 1 to 100000 do + let t = 1000000.0 +. (0.7 *. float_of_int i) in + let ((_, val1) as v1) = + (0, {value= VT_Float (0.5 +. (0.5 *. sin (t /. 10.0))); transform= id}) + in + let ((_, val2) as v2) = + (1, {value= VT_Float (1.5 +. (0.5 *. cos (t /. 80.0))); transform= id}) + in + let ((_, val3) as v3) = + (2, {value= VT_Float (3.5 +. (0.5 *. sin (t /. 700.0))); transform= id}) + in + let ((_, val4) as v4) = + (3, {value= VT_Float (6.5 +. (0.5 *. cos (t /. 5000.0))); transform= id}) + in + ds_update rrd t [|v1; v2; v3; v4|] false ; + + Array.iter2 + (fun ds value -> + compare_float __LOC__ ds.ds_value + (float_of_string (ds_value_to_string value.value)) + ) + rrd.rrd_dss [|val1; val2; val3; val4|] + done + let gauge_rrd = let rra = rra_create CF_Average 100 1 0.5 in let rra2 = rra_create CF_Average 100 10 0.5 in @@ -328,12 +432,15 @@ let regression_suite = ; ("CA-329043 (1)", `Quick, test_ranges ca_329043_rrd_1) ; ("CA-329043 (2)", `Quick, test_ranges ca_329043_rrd_2) ; ("CA-329813", `Quick, test_ranges ca_329813_rrd) + ; ("CA-404597 (1)", `Quick, gauge_rrd_CA_404597) + ; ("CA-404597 (2)", `Quick, absolute_rrd_CA_404597) ] let () = Alcotest.run "Test RRD library" [ - ("Gauge RRD", rrd_suite gauge_rrd) + ("Absolute RRD", rrd_suite absolute_rrd) + ; ("Gauge RRD", rrd_suite gauge_rrd) ; ("RRD for CA-322008", rrd_suite ca_322008_rrd) ; ("RRD for CA-329043", rrd_suite ca_329043_rrd_1) ; ("RRD for CA-329813", rrd_suite ca_329813_rrd) From 73ca3cca49fd604a2cd408c332078535f0f694fe Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Thu, 16 Jan 2025 13:08:45 +0000 Subject: [PATCH 73/73] CA-404597: rrd - Pass Gauge and Absolute data source values as-is Some recent changes related to RRDs likely exposed a long-standing latent issue where the RRD library would process the passed-in values for Gauge and Absolute data sources incorrectly leading to constant values changing from update to update, for example: ``` $ rrd2csv memory_total_kib timestamp, AVERAGE:host:8b533333-91e1-4698-bd17-95b9732ffbb6:memory_total_kib 2025-01-15T08:41:40Z, 33351000 2025-01-15T08:41:45Z, 33350000 2025-01-15T08:41:50Z, 33346000 2025-01-15T08:41:55Z, 33352000 ``` Instead of treating Gauge and Absolute data sources as a variation on the rate-based Derive data source type, expecting time-based calculations to cancel each other out, do not undertake any calculations on non-rate data sources at all. This makes the unit test added in the previous commit pass. Signed-off-by: Andrii Sultanov --- ocaml/libs/xapi-rrd/lib/rrd.ml | 36 ++++++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index 75610964fc1..6667f2a4f5c 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -341,9 +341,10 @@ let rra_update rrd proc_pdp_st elapsed_pdp_st pdps = Array.iter updatefn rrd.rrd_rras (* We assume that the data being given is of the form of a rate; that is, - it's dependent on the time interval between updates. To be able to - deal with gauge DSs, we multiply by the interval so that it cancels - the subsequent divide by interval later on *) + it's dependent on the time interval between updates. + Gauge and Absolute data sources are simply kept as is without any + time-based calculations, while Derive data sources will be changed according + to the time passed since the last measurement. (see CA-404597) *) let process_ds_value ds value interval new_rrd = if interval > ds.ds_mrhb then nan @@ -360,10 +361,8 @@ let process_ds_value ds value interval new_rrd = let rate = match (ds.ds_ty, new_rrd) with - | Absolute, _ | Derive, true -> + | Absolute, _ | Derive, true | Gauge, _ -> value_raw - | Gauge, _ -> - value_raw *. interval | Derive, false -> ( match (ds.ds_last, value) with | VT_Int64 x, VT_Int64 y -> @@ -433,7 +432,14 @@ let ds_update rrd timestamp valuesandtransforms new_rrd = if Utils.isnan value then ds.ds_unknown_sec <- pre_int else - ds.ds_value <- ds.ds_value +. (pre_int *. value /. interval) + (* CA-404597 - Gauge and Absolute values should be passed as-is, + without being involved in time-based calculations at all. + This applies to calculations below as well *) + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value <- value + | Derive -> + ds.ds_value <- ds.ds_value +. (pre_int *. value /. interval) ) v2s ; @@ -450,7 +456,13 @@ let ds_update rrd timestamp valuesandtransforms new_rrd = let raw = let proc_pdp_st = get_float_time last_updated rrd.timestep in let occu_pdp_st = get_float_time timestamp rrd.timestep in - ds.ds_value /. (occu_pdp_st -. proc_pdp_st -. ds.ds_unknown_sec) + + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value + | Derive -> + ds.ds_value + /. (occu_pdp_st -. proc_pdp_st -. ds.ds_unknown_sec) in (* Apply the transform after the raw value has been calculated *) let raw = apply_transform_function transform raw in @@ -473,8 +485,12 @@ let ds_update rrd timestamp valuesandtransforms new_rrd = ds.ds_value <- 0.0 ; ds.ds_unknown_sec <- post_int ) else ( - ds.ds_value <- post_int *. value /. interval ; - ds.ds_unknown_sec <- 0.0 + ds.ds_unknown_sec <- 0.0 ; + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value <- value + | Derive -> + ds.ds_value <- post_int *. value /. interval ) ) v2s