From 87ddfe6051baaa88b9bd097f85074098186a30ff Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 Apr 2026 17:00:25 +0100 Subject: [PATCH 01/34] attach_helpers: only control domains can leak VBDs Gate the checks done for the other_config keys task_id and related_to to VBDs associated with control domains Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/attach_helpers.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi/attach_helpers.ml b/ocaml/xapi/attach_helpers.ml index ed3e32bada5..94634bc5a1a 100644 --- a/ocaml/xapi/attach_helpers.ml +++ b/ocaml/xapi/attach_helpers.ml @@ -49,10 +49,12 @@ let safe_unplug rpc session_id self = frontend (if so it will be linked to another frontend) *) let has_vbd_leaked __context vbd = let other_config = Db.VBD.get_other_config ~__context ~self:vbd in + let vm = Db.VBD.get_VM ~__context ~self:vbd in + let can_leak = Db.VM.get_is_control_domain ~__context ~self:vm in let device = Db.VBD.get_device ~__context ~self:vbd in let has_task = List.mem_assoc Xapi_globs.vbd_task_key other_config in let has_related = List.mem_assoc Xapi_globs.related_to_key other_config in - if (not has_task) && not has_related then ( + if (not can_leak) || ((not has_task) && not has_related) then ( info "Ignoring orphaned disk attached to control domain (device = %s)" device ; false From d78f9434ddcd0d47b4d9583083d07e3936178555 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 24 Apr 2026 17:10:07 +0100 Subject: [PATCH 02/34] xapi/attach_helpers: remove useless check for leaked vbds Looks like this mechanism was used in the past, and only one vestigial check on VBD creation was used. It does not make sense to create a VBD associated with a task and immediately check whether it has leaked. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/attach_helpers.ml | 51 +----------------------------------- ocaml/xapi/xapi_globs.ml | 5 ---- 2 files changed, 1 insertion(+), 55 deletions(-) diff --git a/ocaml/xapi/attach_helpers.ml b/ocaml/xapi/attach_helpers.ml index 94634bc5a1a..403590f56bf 100644 --- a/ocaml/xapi/attach_helpers.ml +++ b/ocaml/xapi/attach_helpers.ml @@ -44,52 +44,8 @@ let safe_unplug rpc session_id self = raise e ) -(** For a VBD attached to a control domain, it may correspond to a running task - (if so the task will be linked via an other_config key) or it may be a qemu - frontend (if so it will be linked to another frontend) *) -let has_vbd_leaked __context vbd = - let other_config = Db.VBD.get_other_config ~__context ~self:vbd in - let vm = Db.VBD.get_VM ~__context ~self:vbd in - let can_leak = Db.VM.get_is_control_domain ~__context ~self:vm in - let device = Db.VBD.get_device ~__context ~self:vbd in - let has_task = List.mem_assoc Xapi_globs.vbd_task_key other_config in - let has_related = List.mem_assoc Xapi_globs.related_to_key other_config in - if (not can_leak) || ((not has_task) && not has_related) then ( - info "Ignoring orphaned disk attached to control domain (device = %s)" - device ; - false - ) else - let has_valid_task = - has_task - && - let task_id = - Ref.of_string (List.assoc Xapi_globs.vbd_task_key other_config) - in - (* check if the task record still exists and is pending *) - try - let status = Db.Task.get_status ~__context ~self:task_id in - List.mem status [`pending; `cancelling] - (* pending and cancelling => not leaked *) - with _ -> false - (* task record gone *) - in - let has_valid_related = - has_related - && - let related = - Ref.of_string (List.assoc Xapi_globs.related_to_key other_config) - in - (* check if the VBD still exists and is currently_attached *) - try Db.VBD.get_currently_attached ~__context ~self:related - with _ -> false - (* VBD record gone *) - in - (* leaked if neither of the two keys are still valid *) - (not has_valid_task) && not has_valid_related - (** Execute a function with a list of VBDs after attaching a bunch of VDIs to an vm *) let with_vbds rpc session_id __context vm vdis mode f = - let task_id = Context.get_task_id __context in let vbds = ref [] in finally (fun () -> @@ -99,13 +55,8 @@ let with_vbds rpc session_id __context vm vdis mode f = Client.VBD.create ~rpc ~session_id ~vM:vm ~empty:false ~vDI:vdi ~userdevice:"autodetect" ~bootable:false ~mode ~_type:`Disk ~unpluggable:true ~qos_algorithm_type:"" ~qos_algorithm_params:[] - ~other_config:[(Xapi_globs.vbd_task_key, Ref.string_of task_id)] - ~device:"" ~currently_attached:false + ~other_config:[] ~device:"" ~currently_attached:false in - (* sanity-check *) - if has_vbd_leaked __context vbd then - error "Attach_helpers.with_vbds new VBD has leaked: %s" - (Ref.string_of vbd) ; let vbd_uuid = Client.VBD.get_uuid ~rpc ~session_id ~self:vbd in let uuid = Client.VM.get_uuid ~rpc ~session_id ~self:vm in debug "created VBD (uuid %s); attempting to hotplug to VM (uuid: %s)" diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 8b59b254b00..ec3aad77671 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -274,11 +274,6 @@ let default_template_key = "default_template" let base_template_name_key = "base_template_name" -(* Keys to explain the presence of dom0 block-attached VBDs: *) -let vbd_task_key = "task_id" - -let related_to_key = "related_to" - let get_nbd_extents = "/opt/xensource/libexec/get_nbd_extents.py" (* other-config keys to sync over when mirroring/remapping/importing a VDI *) From 8edf963d6b6d337a8fac9da44efcf416a9584fcc Mon Sep 17 00:00:00 2001 From: Seb Hinderer Date: Thu, 28 May 2026 13:54:37 +0200 Subject: [PATCH 03/34] Enhancements to the XAPI documentation Signed-off-by: Seb Hinderer --- doc/content/xapi/_index.md | 41 +++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/doc/content/xapi/_index.md b/doc/content/xapi/_index.md index 4e185809f9f..0e1c2d278c9 100644 --- a/doc/content/xapi/_index.md +++ b/doc/content/xapi/_index.md @@ -36,8 +36,8 @@ The following diagram shows the internals of Xapi: The top of the diagram shows the XenAPI clients: XenCenter, XenOrchestra, OpenStack and CloudStack using XenAPI and HTTP GET/PUT over ports 80 and 443 to -talk to xapi. These XenAPI (JSON-RPC or XML-RPC over HTTP POST) and HTTP -GET/PUT are always authenticated using either PAM (by default using the local +talk to xapi. These XenAPI communications (JSON-RPC or XML-RPC over HTTP +POST and HTTP GET/PUT) are always authenticated using either PAM (by default using the local passwd and group files) or through Active Directory. The APIs are classified into categories: @@ -50,9 +50,9 @@ The APIs are classified into categories: hosts which have the most efficient access to the data. - emergency: these deal with scenarios where the coordinator is offline -If the incoming API call should be resent to the coordinator than a XenAPI -`HOST_IS_SLAVE` error message containing the coordinator's IP is sent to the -client. +If the incoming API call should be resent to the coordinator then a XenAPI +`HOST_IS_SLAVE` error message containing the coordinator's IP is sent +back to the client. Once past the initial checks, API calls enter the "message forwarding" layer which @@ -62,9 +62,9 @@ Once past the initial checks, API calls enter the "message forwarding" layer whi If the request should run locally then a direct function call is used; otherwise the message forwarding code makes a synchronous API call to a specific other host. Note: Xapi currently employs a "thread per request" model -which causes one full POSIX thread to be created for every request. Even when a -request is forwarded the full thread persists, blocking for the result to -become available. +which causes one POSIX thread to be created for each request. Even when a +request is forwarded its thread persists, blocking until the result +becomes available. If the XenAPI call is a VM lifecycle operation then it is converted into a Xenopsd API call and forwarded over a Unix domain socket. Xapi and Xenopsd have @@ -74,8 +74,8 @@ cancellation is passed through and progress updates are received. If the XenAPI call is a storage operation then the "storage access" layer -- verifies that the storage objects are in the correct state (SR - attached/detached; VDI attached/activated read-only/read-write) +- verifies that the storage objects are in the correct state (SR + attached/detached; VDI attached/activated; read-only/read-write) - invokes the relevant operation in the Storage Manager API (SMAPI) v2 interface; - depending on the type of SR: @@ -95,21 +95,22 @@ to other clients. The SMAPIv1 plugins also rely on Xapi for - safely executing code on other hosts via the "Xapi plugin" mechanism The Xapi database contains Host and VM metadata and is shared pool-wide. The -coordinator keeps a copy in memory, and all other nodes remote queries to the +coordinator keeps a copy in memory, and all other nodes send remote queries to the coordinator. The database associates each object with a generation count which is used to implement the XenAPI `event.next` and `event.from` APIs. The database is routinely asynchronously flushed to disk in XML format. If the -"redo-log" is enabled then all database writes are made synchronously as deltas -to a shared block device. Without the redo-log, recent updates may be lost if +"redo-log" is enabled then all database writes are written synchronously as deltas +to a shared block device. Without the "redo-log", recent updates may be lost if Xapi is killed before a flush. -High-Availability refers to planning for host failure, monitoring host liveness -and then following-through on the plans. Xapi defers to an external host -liveness monitor called `xhad`. When `xhad` confirms that a host has failed -- -and has been isolated from the storage -- then Xapi will restart any VMs which -have failed and which have been marked as "protected" by HA. Xapi can also -impose admission control to prevent the pool becoming too overloaded to cope -with `n` arbitrary host failures. +High-Availability refers to planning for host failure, monitoring host +liveness and then following-through on the plans. Xapi defers HA to an +external host liveness monitor called `xhad`. When `xhad` confirms that +a host has failed -- and has been isolated from the storage -- then Xapi +will restart any VMs which have failed and which have been marked as +"protected" by HA. Xapi can also impose admission control to prevent the +pool from becoming overloaded and thus unable to cope with an arbitrary +number of host failures. The `xe` CLI is implemented in terms of the XenAPI, but for efficiency the implementation is linked directly into Xapi. The `xe` program remotes its From 1e06a7c0faaf27029c6b87694a0ab533602657e4 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 19 May 2026 14:13:28 +0100 Subject: [PATCH 04/34] gitignore: ignore _mock directory used for running dune in a build root without conflicting with the normal _build that is used by editors or other tools This separate directory can be used by setting an environment variable: DUNE_BUILD_DIR=_mock dune build ocaml/quicktest/ --profile=release -w Signed-off-by: Pau Ruiz Safont (cherry picked from commit dc1779be6e3b6ea740d291e944ccd8d49cdf335e) --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 3ff92f6e274..22eaacafd4e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ _build/ +_mock/ *.bak *.native .merlin From d5e414f8ff60d96ef092802b0171aa01adbdcf51 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 8 May 2026 17:10:27 +0100 Subject: [PATCH 05/34] record_util: move to a new private library This module can help with printing API types, so move it to a new private library so it can be used without compiling the cli server. This is especially interesting for unit tests. Signed-off-by: Pau Ruiz Safont (cherry picked from commit 369adb495a5af6bf98a74fd18afc6726c36609cc) --- ocaml/tests/dune | 2 ++ ocaml/tests/record_util/dune | 16 ++++++++++++---- ocaml/xapi-cli-server/dune | 9 ++++++++- ocaml/xapi/dune | 2 ++ 4 files changed, 24 insertions(+), 5 deletions(-) diff --git a/ocaml/tests/dune b/ocaml/tests/dune index 545e0f748bb..dcdfb53b87c 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -23,6 +23,7 @@ mirage-crypto mtime pam + record_util result rpclib.core rpclib.json @@ -99,6 +100,7 @@ pam ptime result + record_util rpclib.core rpclib.json rresult diff --git a/ocaml/tests/record_util/dune b/ocaml/tests/record_util/dune index a91a104da5c..0bce8316d67 100644 --- a/ocaml/tests/record_util/dune +++ b/ocaml/tests/record_util/dune @@ -1,6 +1,14 @@ (test - (name test_record_util) - (package xapi) - (libraries alcotest xapi_cli_server rpclib.core xapi_consts xapi_types astring fmt) - (action (run %{test} --show-errors)) + (name test_record_util) + (package xapi) + (libraries + alcotest + astring + fmt + record_util + rpclib.core + xapi_consts + xapi_types + ) + (action (run %{test} --show-errors)) ) diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index d20dfa613ca..3f0bdb70f13 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -13,11 +13,17 @@ (modules cli_progress_bar) (libraries mtime mtime.clock.os) ) + +(library + (name record_util) + (modules generated_record_utils record_util) + (libraries rpclib.core xapi-consts xapi-types) +) (library (name xapi_cli_server) (modes best) - (modules (:standard \ cli_progress_bar)) + (modules (:standard \ cli_progress_bar generated_record_utils record_util)) (libraries astring base64 @@ -26,6 +32,7 @@ rpclib.core rpclib.xml re + record_util result rresult sexplib diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 86cc04f6730..9afbe9c27c0 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -170,6 +170,7 @@ rpclib.json rpclib.xml re + record_util result rresult rrd-transport.lib @@ -297,6 +298,7 @@ forkexec http_lib httpsvr + record_util rpclib.core rpclib.json rpclib.xml From adca4ba47ba704f0ae1a6c0d466ab00684df96d6 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 9 Feb 2026 15:40:53 +0100 Subject: [PATCH 06/34] ocaml/tests: separate test_sr_allowed_operations Signed-off-by: Pau Ruiz Safont (cherry picked from commit 390e48463d1f02a3949c73a48c92e33a35fe9b3b) --- ocaml/tests/dune | 7 ++++--- ocaml/tests/suite_alcotest.ml | 1 - ocaml/tests/test_sr_allowed_operations.ml | 5 +++++ ocaml/tests/test_sr_allowed_operations.mli | 0 4 files changed, 9 insertions(+), 4 deletions(-) create mode 100644 ocaml/tests/test_sr_allowed_operations.mli diff --git a/ocaml/tests/dune b/ocaml/tests/dune index dcdfb53b87c..cad68400ccf 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -9,7 +9,7 @@ test_vm_placement test_vm_helpers test_repository test_repository_helpers test_ref test_xapi_helpers test_vm_group test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest test_observer - test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository)) + test_pool_periodic_update_sync test_pkg_mgr test_tar_ext test_pool_repository test_sr_allowed_operations)) (libraries alcotest angstrom @@ -84,14 +84,14 @@ (names test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_bounded_psq test_auth_cache test_clustering test_pusb test_daemon_manager test_repository test_repository_helpers test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr - test_xapi_helpers test_tar_ext test_pool_repository) + test_xapi_helpers test_tar_ext test_pool_repository test_sr_allowed_operations) (package xapi) (modes exe) (modules test_vm_helpers test_vm_placement test_network_sriov test_vdi_cbt test_bounded_psq test_auth_cache test_event test_clustering test_cluster_host test_cluster test_pusb test_daemon_manager test_repository test_repository_helpers test_livepatch test_rpm test_updateinfo test_pool_periodic_update_sync test_pkg_mgr - test_xapi_helpers test_tar_ext test_pool_repository) + test_xapi_helpers test_tar_ext test_pool_repository test_sr_allowed_operations) (libraries alcotest bos @@ -116,6 +116,7 @@ xapi-idl.storage.interface xapi-idl.xen clock + xapi-log xapi-stdext-threads xapi-stdext-threads.scheduler xapi-stdext-unix diff --git a/ocaml/tests/suite_alcotest.ml b/ocaml/tests/suite_alcotest.ml index 62deb8e71ae..74cc129b656 100644 --- a/ocaml/tests/suite_alcotest.ml +++ b/ocaml/tests/suite_alcotest.ml @@ -8,7 +8,6 @@ let () = ("Test_sdn_controller", Test_sdn_controller.test) ; ("Test_pci_helpers", Test_pci_helpers.test) ; ("Test_vdi_allowed_operations", Test_vdi_allowed_operations.test) - ; ("Test_sr_allowed_operations", Test_sr_allowed_operations.test) ; ("Test_vm_migrate", Test_vm_migrate.test) ; ("Test_no_migrate", Test_no_migrate.test) ; ("Test_vm_check_operation_error", Test_vm_check_operation_error.test) diff --git a/ocaml/tests/test_sr_allowed_operations.ml b/ocaml/tests/test_sr_allowed_operations.ml index 8fca69f6717..095597aa4b8 100644 --- a/ocaml/tests/test_sr_allowed_operations.ml +++ b/ocaml/tests/test_sr_allowed_operations.ml @@ -72,3 +72,8 @@ let test_operations_restricted_during_rpu = [("test_check_operation_error", `Quick, test_check_operation_error)] let test = test_operations_restricted_during_rpu + +let () = + Suite_init.harness_init () ; + Debug.log_to_stdout () ; + Alcotest.run "Base suite" [("Test_sr_allowed_operations", test)] diff --git a/ocaml/tests/test_sr_allowed_operations.mli b/ocaml/tests/test_sr_allowed_operations.mli new file mode 100644 index 00000000000..e69de29bb2d From d2f3c812e18100c50ce15d35bca79a2b577507ab Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 10 Feb 2026 09:22:52 +0100 Subject: [PATCH 07/34] xapi_sr_operations: use results for asserting valid ops Makes the distinction between the absence of a value and absence of an error. Signed-off-by: Pau Ruiz Safont (cherry picked from commit dbc6230073d1a276dbef7692fb4ff62a9cd32766) --- ocaml/xapi/xapi_sr_operations.ml | 43 ++++++++++++++++++++------------ quality-gate.sh | 2 +- 2 files changed, 28 insertions(+), 17 deletions(-) diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 8d9d67e5863..a9f3bf7eb57 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -93,7 +93,7 @@ let sm_cap_table : (API.storage_operations * _) list = (`vdi_snapshot, Vdi_snapshot) ] -type table = (API.storage_operations, (string * string list) option) Hashtbl.t +type table = (API.storage_operations, (unit, exn) Result.t) Hashtbl.t let features_of_sr_internal ~__context ~_type = match @@ -113,22 +113,30 @@ let features_of_sr_internal ~__context ~_type = let features_of_sr ~__context record = features_of_sr_internal ~__context ~_type:record.Db_actions.sR_type -(** Returns a table of operations -> API error options (None if the operation would be ok) - * If op is specified, the table may omit reporting errors for ops other than that one. *) +(** Returns a table of operations -> API error options (None if the operation + would be ok) If op is specified, the table may omit reporting errors for + ops other than that one. *) let valid_operations ~__context ?op record _ref' : table = let _ref = Ref.string_of _ref' in let current_ops = record.Db_actions.sR_current_operations in let table : table = Hashtbl.create 10 in - List.iter (fun x -> Hashtbl.replace table x None) all_ops ; + List.iter (fun x -> Hashtbl.replace table x (Ok ())) all_ops ; let set_errors (code : string) (params : string list) (ops : API.storage_operations_set) = List.iter (fun op -> - (* Exception can't be raised since the hash table is - pre-filled for all_ops, and set_errors is applied - to a subset of all_ops (disallowed_during_rpu) *) - if Hashtbl.find table op = None then - Hashtbl.replace table op (Some (code, params)) + match Hashtbl.find_opt table op with + | Some (Ok ()) -> + Hashtbl.replace table op + (Error (Api_errors.Server_error (code, params))) + | Some (Error _) -> + (* Don't replace existing errors *) + () + | None -> + (* Ignore order if the operation is not in table, this is a coding + error, as all calls to set_errors should be a subset of all_ops + *) + () ) ops in @@ -143,7 +151,8 @@ let valid_operations ~__context ?op record _ref' : table = let open Smint.Feature in (* First consider the backend SM features *) let sm_features = features_of_sr ~__context record in - (* Then filter out the operations we don't want to see for the magic tools SR *) + (* Then filter out the operations we don't want to see for the magic tools + SR *) let sm_features = if record.Db_actions.sR_is_tools_sr then List.filter @@ -163,7 +172,8 @@ let valid_operations ~__context ?op record _ref' : table = set_errors Api_errors.sr_operation_not_supported [_ref] forbidden_by_backend in let check_any_attached_pbds ~__context _record = - (* CA-70294: if the SR has any attached PBDs, destroy and forget operations are not allowed.*) + (* CA-70294: if the SR has any attached PBDs, destroy and forget operations + are not allowed.*) let all_pbds_attached_to_this_sr = Db.PBD.get_records_where ~__context ~expr: @@ -237,7 +247,8 @@ let valid_operations ~__context ?op record _ref' : table = Cluster_stack_constraints.assert_cluster_stack_compatible ~__context _ref' with Api_errors.Server_error (e, args) -> set_errors e args [`plug] in - (* List of (operations * function which checks for errors relevant to those operations) *) + (* List of (operations * function which checks for errors relevant to those + operations) *) let relevant_functions = [ (all_ops, check_sm_features) @@ -264,9 +275,9 @@ let throw_error (table : table) op = Helpers.internal_error "xapi_sr.assert_operation_valid unknown operation: %s" (sr_operation_to_string op) - | Some (Some (code, params)) -> - raise (Api_errors.Server_error (code, params)) - | Some None -> + | Some (Error ex) -> + raise ex + | Some (Ok ()) -> () let assert_operation_valid ~__context ~self ~(op : API.storage_operations) = @@ -280,7 +291,7 @@ let update_allowed_operations ~__context ~self : unit = let keys = Hashtbl.fold (fun k v acc -> - if v = None then + if v = Ok () then k :: acc else acc diff --git a/quality-gate.sh b/quality-gate.sh index 6315d7dae60..348d71bb940 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -110,7 +110,7 @@ unixgetenv () { } hashtblfind () { - N=33 + N=32 # Looks for all .ml files except the ones using Core.Hashtbl.find, # which already returns Option HASHTBLFIND=$(git grep -P -r --count 'Hashtbl.find(?!_opt)' -- '**/*.ml' ':!ocaml/xapi-storage-script/main.ml' | cut -d ':' -f 2 | paste -sd+ - | bc) From 2a492ad44750ffb8176075c44cd9890bb5a64e61 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 9 Feb 2026 10:31:47 +0100 Subject: [PATCH 08/34] xapi_sr_operations: ensure the properties on ops lists always hold The lists of operations used in the module need to be a subset of all_ops, otherwise spurious errors can be thrown on runtime. Ensuring these properties allows to drop the runtime check Also add an interface file for the module Signed-off-by: Pau Ruiz Safont (cherry picked from commit 9edae935b11b1967ed05ac493bf600a66e5479bb) --- ocaml/tests/dune | 14 +++++--- ocaml/tests/test_xapi_sr_operations.ml | 44 +++++++++++++++++++++++++ ocaml/tests/test_xapi_sr_operations.mli | 0 ocaml/xapi/xapi_sr_operations.ml | 6 +--- ocaml/xapi/xapi_sr_operations.mli | 40 ++++++++++++++++++++++ 5 files changed, 95 insertions(+), 9 deletions(-) create mode 100644 ocaml/tests/test_xapi_sr_operations.ml create mode 100644 ocaml/tests/test_xapi_sr_operations.mli create mode 100644 ocaml/xapi/xapi_sr_operations.mli diff --git a/ocaml/tests/dune b/ocaml/tests/dune index cad68400ccf..04671057c5e 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -132,12 +132,18 @@ (preprocess (per_module ((pps ppx_deriving_rpc) Test_cluster_host))) ) -(test -(name test_storage_smapiv1_wrapper) +(tests +(names test_storage_smapiv1_wrapper test_xapi_sr_operations) (modes exe) (package xapi) -(modules test_storage_smapiv1_wrapper) -(libraries alcotest xapi_internal fmt xapi-idl.storage.interface xapi-idl.storage.interface.types)) +(modules test_storage_smapiv1_wrapper test_xapi_sr_operations) +(libraries + alcotest + fmt + record_util + xapi-idl.storage.interface + xapi-idl.storage.interface.types + xapi_internal)) (test (name test_storage_quicktest) diff --git a/ocaml/tests/test_xapi_sr_operations.ml b/ocaml/tests/test_xapi_sr_operations.ml new file mode 100644 index 00000000000..5045c5e8f09 --- /dev/null +++ b/ocaml/tests/test_xapi_sr_operations.ml @@ -0,0 +1,44 @@ +(* + Copyright (C) 2026 Vates. + + 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 Ops = Xapi_sr_operations + +let contained_tables = + [ + (Ops.all_rpu_ops, "all_rpu_ops") + ; (Ops.disallowed_during_rpu, "disallowed_during_rpu") + ; (Ops.sm_cap_table |> List.map fst, "sm_cap_table") + ] + +let not_contained element = + if not (List.mem element Ops.all_ops) then + Some (Record_util.storage_operations_to_string element) + else + None + +let test_tables = + List.map + (fun (input, name) -> + let test () = + let not_contained = List.filter_map not_contained input in + Alcotest.(check @@ list string) + "There cannot be operations missing from all_ops" [] not_contained + in + (Printf.sprintf {|%s is a subset of all_ops|} name, `Quick, test) + ) + contained_tables + +let () = + Alcotest.run "Test XAPI Helpers suite" + [("SR operation tables all are complete ", test_tables)] diff --git a/ocaml/tests/test_xapi_sr_operations.mli b/ocaml/tests/test_xapi_sr_operations.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index a9f3bf7eb57..e74e1986382 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -271,13 +271,9 @@ let valid_operations ~__context ?op record _ref' : table = let throw_error (table : table) op = match Hashtbl.find_opt table op with - | None -> - Helpers.internal_error - "xapi_sr.assert_operation_valid unknown operation: %s" - (sr_operation_to_string op) | Some (Error ex) -> raise ex - | Some (Ok ()) -> + | None | Some (Ok ()) -> () let assert_operation_valid ~__context ~self ~(op : API.storage_operations) = diff --git a/ocaml/xapi/xapi_sr_operations.mli b/ocaml/xapi/xapi_sr_operations.mli new file mode 100644 index 00000000000..e4fce018916 --- /dev/null +++ b/ocaml/xapi/xapi_sr_operations.mli @@ -0,0 +1,40 @@ +type table = (API.storage_operations, (unit, exn) Result.t) Hashtbl.t + +val features_of_sr_internal : + __context:Context.t -> _type:string -> (Smint.Feature.capability * int64) list + +val features_of_sr : + __context:Context.t + -> Db_actions.sR_t + -> (Smint.Feature.capability * int64) list + +val assert_operation_valid : + __context:Context.t + -> self:[`SR] API.Ref.t + -> op:API.storage_operations + -> unit + +val update_allowed_operations : + __context:Context.t -> self:[`SR] API.Ref.t -> unit + +val cancel_tasks : + __context:Context.t + -> self:[`SR] API.Ref.t + -> all_tasks_in_db:[`task] Ref.t list + -> task_ids:string list + -> unit + +val sr_health_check : __context:Context.t -> self:[`SR] API.Ref.t -> unit + +val stop_health_check_thread : + __context:Context.t -> self:[`SR] API.Ref.t -> unit + +(**/**) + +val all_ops : API.storage_operations_set + +val all_rpu_ops : API.storage_operations_set + +val disallowed_during_rpu : API.storage_operations_set + +val sm_cap_table : (API.storage_operations * Smint.Feature.capability) list From b19a3e6f92c24745c313faf8dc383aba20c2051e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 2 Oct 2025 10:12:15 +0100 Subject: [PATCH 09/34] xapi-storage: add interface to common avoids having unused bindings Signed-off-by: Pau Ruiz Safont (cherry picked from commit 2a937959a4f5e6853e4dd7de8d421f8b8c244e12) --- ocaml/xapi-storage/generator/lib/common.ml | 13 +--------- ocaml/xapi-storage/generator/lib/common.mli | 28 +++++++++++++++++++++ quality-gate.sh | 2 +- 3 files changed, 30 insertions(+), 13 deletions(-) create mode 100644 ocaml/xapi-storage/generator/lib/common.mli diff --git a/ocaml/xapi-storage/generator/lib/common.ml b/ocaml/xapi-storage/generator/lib/common.ml index 2c144027586..23d0573e5f3 100644 --- a/ocaml/xapi-storage/generator/lib/common.ml +++ b/ocaml/xapi-storage/generator/lib/common.ml @@ -22,18 +22,7 @@ let dbg = let unit = Param.mk Types.unit -let task_id = Param.mk ~name:"task_id" Types.string - -(** A URI representing the means for accessing the volume data. The - interpretation of the URI is specific to the implementation. Xapi will - choose which implementation to use based on the URI scheme. *) type uri = string [@@deriving rpcty] -(** List of blocks for copying. *) -type blocklist = { - blocksize: int (** Size of the individual blocks. *) - ; ranges: (int64 * int64) list - (** List of block ranges, where a range is a (start,length) pair, - measured in units of [blocksize] *) -} +type blocklist = {blocksize: int; ranges: (int64 * int64) list} [@@deriving rpcty] diff --git a/ocaml/xapi-storage/generator/lib/common.mli b/ocaml/xapi-storage/generator/lib/common.mli new file mode 100644 index 00000000000..6820a0bf5d7 --- /dev/null +++ b/ocaml/xapi-storage/generator/lib/common.mli @@ -0,0 +1,28 @@ +type exnt = Unimplemented of string + +val typ_of_exnt : exnt Rpc.Types.typ + +val exnt : exnt Rpc.Types.def + +exception DataExn of exnt + +val error : exnt Idl.Error.t + +val dbg : string Idl.Param.t + +val unit : unit Idl.Param.t + +val uri : string Rpc.Types.def +(** A URI representing the means for accessing the volume data. The + interpretation of the URI is specific to the implementation. Xapi will + choose which implementation to use based on the URI scheme. *) + +(** List of blocks for copying. *) +type blocklist = { + blocksize: int (** Size of the individual blocks. *) + ; ranges: (int64 * int64) list + (** List of block ranges, where a range is a (start,length) pair, + measured in units of [blocksize] *) +} + +val blocklist : blocklist Rpc.Types.def diff --git a/quality-gate.sh b/quality-gate.sh index 348d71bb940..e4c6f228844 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=455 + N=454 X="ocaml/tests" X+="|ocaml/quicktest" X+="|ocaml/message-switch/core_test" From d09a074ef976d4b18878f5ecae9d74c9b6c70af4 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 24 Sep 2025 14:13:05 +0100 Subject: [PATCH 10/34] xapi_vdi: removed code commented in the prehistoric times That's pre-2009 in xapi land Signed-off-by: Pau Ruiz Safont (cherry picked from commit 4f7a66e1f996a5bd58db164f53aa5c0644bfa000) --- ocaml/xapi/xapi_vdi.ml | 30 ------------------------------ 1 file changed, 30 deletions(-) diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index 1d4b881c418..7ce251f08c3 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -532,36 +532,6 @@ let cancel_tasks ~__context ~self ~all_tasks_in_db ~task_ids = (**************************************************************************************) -(* Helper function to create a new VDI record with all fields copied from - an original, except ref and *_operations, UUID and others supplied as optional arguments. - If a new UUID is not supplied, a fresh one is generated. - storage_lock defaults to false. - Parent defaults to Ref.null. -*) -(*let clone_record ~uuid ?name_label ?name_description ?sR ?virtual_size ?location - ?physical_utilisation ?_type ?sharable ?read_only ?storage_lock ?other_config ?parent - ?xenstore_data ?sm_config ~current_operations ~__context ~original () = - let a = Db.VDI.get_record_internal ~__context ~self:original in - let r = Ref.make () in - Db.VDI.create ~__context ~ref:r - ~uuid:(Uuidx.to_string uuid) - ~name_label:(default a.Db_actions.vDI_name_label name_label) - ~name_description:(default a.Db_actions.vDI_name_description name_description) - ~allowed_operations:[] ~current_operations - ~sR:(default a.Db_actions.vDI_SR sR) - ~virtual_size:(default a.Db_actions.vDI_virtual_size virtual_size) - ~physical_utilisation:(default a.Db_actions.vDI_physical_utilisation physical_utilisation) - ~_type:(default a.Db_actions.vDI_type _type) - ~sharable:(default a.Db_actions.vDI_sharable sharable) - ~read_only:(default a.Db_actions.vDI_read_only read_only) - ~other_config:(default a.Db_actions.vDI_other_config other_config) - ~storage_lock:(default false storage_lock) - ~location:(default a.Db_actions.vDI_location location) ~managed:true ~missing:false - ~xenstore_data:(default a.Db_actions.vDI_xenstore_data xenstore_data) - ~sm_config:(default a.Db_actions.vDI_sm_config sm_config) - ~parent:(default Ref.null parent); - r*) - (* This function updates xapi's database for a single VDI. The row will be created if it doesn't exist *) let update_vdi_db ~__context ~sr newvdi = let open Xapi_database.Db_filter_types in From b4357005219653ade8360be9909816d1126831c8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 15 May 2026 15:27:31 +0100 Subject: [PATCH 11/34] quicktest: reduce amount of repetition in snapshot tests No change in behaviour Signed-off-by: Pau Ruiz Safont (cherry picked from commit 797bf5ff7b42f0510245118b2ab05cb1b15fd0bf) --- ocaml/quicktest/qt.ml | 18 ++- ocaml/quicktest/qt.mli | 2 + ocaml/quicktest/quicktest_vm_snapshot.ml | 183 +++++++++------------- ocaml/quicktest/quicktest_vm_snapshot.mli | 13 ++ 4 files changed, 100 insertions(+), 116 deletions(-) create mode 100644 ocaml/quicktest/quicktest_vm_snapshot.mli diff --git a/ocaml/quicktest/qt.ml b/ocaml/quicktest/qt.ml index 4b3e7a64ead..9912da56b54 100644 --- a/ocaml/quicktest/qt.ml +++ b/ocaml/quicktest/qt.ml @@ -193,15 +193,14 @@ module VDI = struct let test_vdi_name_description = "VDI for storage quicktest" let make rpc session_id ?(virtual_size = Int64.(mul (mul 4L 1024L) 1024L)) - ?backing_format sR = + ?backing_format ?(name_label = test_vdi_name_label) + ?(name_description = test_vdi_name_description) sR = let sm_config = match backing_format with Some x -> [("image-format", x)] | None -> [] in - Client.Client.VDI.create ~sR ~session_id ~rpc - ~name_label:test_vdi_name_label - ~name_description:test_vdi_name_description ~_type:`user ~sharable:false - ~read_only:false ~virtual_size ~xenstore_data:[] ~other_config:[] ~tags:[] - ~sm_config + Client.Client.VDI.create ~sR ~session_id ~rpc ~name_label ~name_description + ~_type:`user ~sharable:false ~read_only:false ~virtual_size + ~xenstore_data:[] ~other_config:[] ~tags:[] ~sm_config let with_destroyed rpc session_id self f = Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> @@ -209,8 +208,11 @@ module VDI = struct ) let with_new rpc session_id ?(virtual_size = Int64.(mul (mul 4L 1024L) 1024L)) - ?backing_format sr f = - let self = make rpc session_id ~virtual_size ?backing_format sr in + ?backing_format ?name_label ?name_description sr f = + let self = + make rpc session_id ~virtual_size ?backing_format ?name_label + ?name_description sr + in with_destroyed rpc session_id self (fun () -> f self) let with_any rpc session_id sr_info f = diff --git a/ocaml/quicktest/qt.mli b/ocaml/quicktest/qt.mli index 48939e58c5b..4bead98cadb 100644 --- a/ocaml/quicktest/qt.mli +++ b/ocaml/quicktest/qt.mli @@ -76,6 +76,8 @@ module VDI : sig -> API.ref_session -> ?virtual_size:int64 -> ?backing_format:string + -> ?name_label:string + -> ?name_description:string -> API.ref_SR -> (API.ref_VDI -> 'a) -> 'a diff --git a/ocaml/quicktest/quicktest_vm_snapshot.ml b/ocaml/quicktest/quicktest_vm_snapshot.ml index 54c0489f375..2af0cb79c5e 100644 --- a/ocaml/quicktest/quicktest_vm_snapshot.ml +++ b/ocaml/quicktest/quicktest_vm_snapshot.ml @@ -1,125 +1,95 @@ +(* Copyright (C) 2026 Vates. + + 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. +*) +let ( let@ ) f x = f x + +let create_vbd_disk rpc session_id vm vdi n = + Client.Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi ~userdevice:n + ~bootable:false ~mode:`RW ~_type:`Disk ~unpluggable:true ~empty:false + ~other_config:[] ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~device:"" + ~currently_attached:true + (** Set up snapshot test: create a small VM with a selection of VBDs *) let with_setup rpc session_id sr vm_template f = print_endline "Setting up test VM" ; let uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:vm_template in print_endline (Printf.sprintf "Template has uuid: %s%!" uuid) ; - let vdi = - Client.Client.VDI.create ~rpc ~session_id ~name_label:"small" - ~name_description:__LOC__ ~sR:sr + let@ vm = Qt.VM.with_new rpc session_id ~template:vm_template ~sr in + print_endline (Printf.sprintf "Installed new VM") ; + print_endline + (Printf.sprintf "Using SR: %s" + (Client.Client.SR.get_name_label ~rpc ~session_id ~self:sr) + ) ; + let@ vdi = + Qt.VDI.with_new rpc session_id ~name_label:"small" ~name_description:__LOC__ ~virtual_size:Int64.(mul (mul 4L 1024L) 1024L) - ~_type:`user ~sharable:false ~read_only:false ~other_config:[] - ~xenstore_data:[] ~sm_config:[] ~tags:[] + sr in - let vdi2 = - Client.Client.VDI.create ~rpc ~session_id ~name_label:"small2" - ~name_description:__LOC__ ~sR:sr + ignore (create_vbd_disk rpc session_id vm vdi "0") ; + let@ vdi2 = + Qt.VDI.with_new rpc session_id ~name_label:"small2" + ~name_description:__LOC__ ~virtual_size:Int64.(mul (mul 4L 1024L) 1024L) - ~_type:`user ~sharable:false ~read_only:false ~other_config:[] - ~xenstore_data:[] ~sm_config:[] ~tags:[] + sr in - Qt.VM.with_new rpc session_id ~template:vm_template (fun vm -> - print_endline (Printf.sprintf "Installed new VM") ; - print_endline - (Printf.sprintf "Using SR: %s" - (Client.Client.SR.get_name_label ~rpc ~session_id ~self:sr) - ) ; - ignore - (Client.Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi - ~userdevice:"0" ~bootable:false ~mode:`RW ~_type:`Disk - ~unpluggable:true ~empty:false ~other_config:[] - ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~device:"" - ~currently_attached:true - ) ; - ignore - (Client.Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi2 - ~userdevice:"1" ~bootable:false ~mode:`RW ~_type:`Disk - ~unpluggable:true ~empty:false ~other_config:[] - ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~device:"" - ~currently_attached:true - ) ; - f rpc session_id vm vdi vdi2 ; - Client.Client.VDI.destroy ~rpc ~session_id ~self:vdi ; - Client.Client.VDI.destroy ~rpc ~session_id ~self:vdi2 - ) + ignore (create_vbd_disk rpc session_id vm vdi2 "1") ; + f rpc session_id vm vdi vdi2 -let test_snapshot rpc session_id vm vdi vdi2 = - let snapshot = - Client.Client.VM.snapshot ~rpc ~session_id ~vm ~new_name:"Snapshot" - ~ignore_vdis:[] - in - let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:snapshot in - let snap_vbd = - match - List.find_opt - (fun vbd -> - Client.Client.VBD.get_userdevice ~rpc ~session_id ~self:vbd = "0" - ) - vbds - with - | None -> - Alcotest.fail "Couldn't find VBD on snapshot" - | Some vbd -> - vbd - in - let snap_vbd2 = - match - List.find_opt - (fun vbd -> - Client.Client.VBD.get_userdevice ~rpc ~session_id ~self:vbd = "1" - ) - vbds - with +let take_snapshot ?(ignore_vdis = []) rpc session_id vm ~origin = + Client.Client.VM.snapshot ~rpc ~session_id ~vm + ~new_name:(Printf.sprintf "Snapshot:%s" origin) + ~ignore_vdis + +let is_user_device rpc session_id n vbd = + Client.Client.VBD.get_userdevice ~rpc ~session_id ~self:vbd = n + +let get_vdi_with_user_device rpc session_id vbds n = + let vbd = + match List.find_opt (is_user_device rpc session_id n) vbds with | None -> - Alcotest.fail "Couldn't find VBD on snapshot" + Alcotest.fail (Printf.sprintf "Couldn't find VBD on snapshot %s" n) | Some vbd -> vbd in - let snap_vdi = Client.Client.VBD.get_VDI ~rpc ~session_id ~self:snap_vbd in - let snap_vdi2 = Client.Client.VBD.get_VDI ~rpc ~session_id ~self:snap_vbd2 in - let orig_vdi = - Client.Client.VDI.get_snapshot_of ~rpc ~session_id ~self:snap_vdi - in - let orig_vdi2 = - Client.Client.VDI.get_snapshot_of ~rpc ~session_id ~self:snap_vdi2 - in - assert (orig_vdi = vdi) ; - assert (orig_vdi2 = vdi2) + Client.Client.VBD.get_VDI ~rpc ~session_id ~self:vbd + +let get_snapshot_of_vdi rpc session_id vbds n = + let snap = get_vdi_with_user_device rpc session_id vbds n in + Client.Client.VDI.get_snapshot_of ~rpc ~session_id ~self:snap + +let check_vdi_snapshot_of rpc session_id vbds ~vdi n = + let snapshot_of = get_snapshot_of_vdi rpc session_id vbds n in + assert (snapshot_of = vdi) + +let test_snapshot rpc session_id vm vdi vdi2 = + let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in + let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:snapshot in + + check_vdi_snapshot_of rpc session_id vbds ~vdi "0" ; + check_vdi_snapshot_of rpc session_id vbds ~vdi:vdi2 "1" let test_snapshot_ignore_vdi rpc session_id vm vdi vdi2 = let snapshot = - Client.Client.VM.snapshot ~rpc ~session_id ~vm ~new_name:"Snapshot" - ~ignore_vdis:[vdi2] + take_snapshot rpc session_id vm ~origin:__FUNCTION__ ~ignore_vdis:[vdi2] in let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:snapshot in - let snap_vbd = - match - List.find_opt - (fun vbd -> - Client.Client.VBD.get_userdevice ~rpc ~session_id ~self:vbd = "0" - ) - vbds - with - | None -> - Alcotest.fail "Couldn't find VBD on snapshot" - | Some vbd -> - vbd - in - assert ( - not - (List.exists - (fun vbd -> - Client.Client.VBD.get_userdevice ~rpc ~session_id ~self:vbd = "1" - ) - vbds - ) - ) ; - let snap_vdi = Client.Client.VBD.get_VDI ~rpc ~session_id ~self:snap_vbd in - let orig_vdi = - Client.Client.VDI.get_snapshot_of ~rpc ~session_id ~self:snap_vdi + let has_been_snapshot n = + List.exists (is_user_device rpc session_id n) vbds in - assert (orig_vdi = vdi) -let test rpc session_id sr_info vm_template () = + assert (not (has_been_snapshot "1")) ; + check_vdi_snapshot_of rpc session_id vbds ~vdi "0" + +let test_snapshots rpc session_id sr_info vm_template () = let sr = sr_info.Qt.sr in List.iter (with_setup rpc session_id sr vm_template) @@ -127,10 +97,7 @@ let test rpc session_id sr_info vm_template () = let tests () = let open Qt_filter in - [ - [("VM snapshot tests", `Slow, test)] - |> conn - |> sr SR.(all |> allowed_operations [`vdi_create]) - |> vm_template Qt.VM.Template.other - ] - |> List.concat + [("VM snapshot tests", `Slow, test_snapshots)] + |> conn + |> sr SR.(all |> allowed_operations [`vdi_create]) + |> vm_template Qt.VM.Template.other diff --git a/ocaml/quicktest/quicktest_vm_snapshot.mli b/ocaml/quicktest/quicktest_vm_snapshot.mli new file mode 100644 index 00000000000..5cbc39b9ee2 --- /dev/null +++ b/ocaml/quicktest/quicktest_vm_snapshot.mli @@ -0,0 +1,13 @@ +(* Copyright (C) 2026 Vates. + + 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. +*) +val tests : unit -> (unit -> unit) Qt_filter.test_case list From 9193fac9a28780bbe4311603f2d917b191988285 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 15 May 2026 15:58:23 +0100 Subject: [PATCH 12/34] quicktest: switch asserts with alcotest's check in snapshot tests Signed-off-by: Pau Ruiz Safont (cherry picked from commit 58b88f241a95eca56624ce158afae1d8b1c8d93c) --- ocaml/quicktest/quicktest_vm_snapshot.ml | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/ocaml/quicktest/quicktest_vm_snapshot.ml b/ocaml/quicktest/quicktest_vm_snapshot.ml index 2af0cb79c5e..30302b84eeb 100644 --- a/ocaml/quicktest/quicktest_vm_snapshot.ml +++ b/ocaml/quicktest/quicktest_vm_snapshot.ml @@ -66,14 +66,27 @@ let get_snapshot_of_vdi rpc session_id vbds n = let snap = get_vdi_with_user_device rpc session_id vbds n in Client.Client.VDI.get_snapshot_of ~rpc ~session_id ~self:snap -let check_vdi_snapshot_of rpc session_id vbds ~vdi n = - let snapshot_of = get_snapshot_of_vdi rpc session_id vbds n in - assert (snapshot_of = vdi) +let vm_ref : [`VM] Ref.t Alcotest.testable = Alcotest.testable Ref.pp ( = ) + +let vdi_ref : [`VDI] Ref.t Alcotest.testable = Alcotest.testable Ref.pp ( = ) + +let check_vm_snapshot_of rpc session_id ~snapshot ~vm = + let snapshot_of = + Client.Client.VM.get_snapshot_of ~rpc ~session_id ~self:snapshot + in + Alcotest.(check vm_ref) + "The expected VM is different from the one in snapshot_of" vm snapshot_of + +let check_vdi_snapshot_of rpc session vbds ~vdi n = + let snapshot_of = get_snapshot_of_vdi rpc session vbds n in + Alcotest.(check vdi_ref) + "The expected vdi is different from the one in snapshot_of" vdi snapshot_of let test_snapshot rpc session_id vm vdi vdi2 = let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:snapshot in + check_vm_snapshot_of rpc session_id ~snapshot ~vm ; check_vdi_snapshot_of rpc session_id vbds ~vdi "0" ; check_vdi_snapshot_of rpc session_id vbds ~vdi:vdi2 "1" @@ -85,8 +98,9 @@ let test_snapshot_ignore_vdi rpc session_id vm vdi vdi2 = let has_been_snapshot n = List.exists (is_user_device rpc session_id n) vbds in - - assert (not (has_been_snapshot "1")) ; + Alcotest.(check bool) + "The vbd with user_device 1 cannot be present in the snapshot" false + (has_been_snapshot "1") ; check_vdi_snapshot_of rpc session_id vbds ~vdi "0" let test_snapshots rpc session_id sr_info vm_template () = From bb097b29cade3082ccbff452f1bd311bde8d0c63 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 15 May 2026 16:36:33 +0100 Subject: [PATCH 13/34] quicktest: test reverting snapshots Signed-off-by: Pau Ruiz Safont (cherry picked from commit 44366b76f4d354f2e1f743a6a3a31d12a96c28fe) --- ocaml/quicktest/qt.ml | 4 ++- ocaml/quicktest/quicktest_vm_snapshot.ml | 37 +++++++++++++++++++----- 2 files changed, 33 insertions(+), 8 deletions(-) diff --git a/ocaml/quicktest/qt.ml b/ocaml/quicktest/qt.ml index 9912da56b54..6a3e409aa56 100644 --- a/ocaml/quicktest/qt.ml +++ b/ocaml/quicktest/qt.ml @@ -204,7 +204,9 @@ module VDI = struct let with_destroyed rpc session_id self f = Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> - Client.Client.VDI.destroy ~rpc ~session_id ~self + try Client.Client.VDI.destroy ~rpc ~session_id ~self + with Api_errors.Server_error ("HANDLE_INVALID", _) -> + (* Already destroyed, ignore *) () ) let with_new rpc session_id ?(virtual_size = Int64.(mul (mul 4L 1024L) 1024L)) diff --git a/ocaml/quicktest/quicktest_vm_snapshot.ml b/ocaml/quicktest/quicktest_vm_snapshot.ml index 30302b84eeb..b3d6c9c8d51 100644 --- a/ocaml/quicktest/quicktest_vm_snapshot.ml +++ b/ocaml/quicktest/quicktest_vm_snapshot.ml @@ -82,6 +82,10 @@ let check_vdi_snapshot_of rpc session vbds ~vdi n = Alcotest.(check vdi_ref) "The expected vdi is different from the one in snapshot_of" vdi snapshot_of +let check_vdis_different expected result = + Alcotest.(check @@ neg vdi_ref) + "The VDIs after a reverting a snapshot must not be the same" expected result + let test_snapshot rpc session_id vm vdi vdi2 = let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:snapshot in @@ -103,15 +107,34 @@ let test_snapshot_ignore_vdi rpc session_id vm vdi vdi2 = (has_been_snapshot "1") ; check_vdi_snapshot_of rpc session_id vbds ~vdi "0" -let test_snapshots rpc session_id sr_info vm_template () = +let test_revert rpc session_id vm vdi vdi2 = + let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in + Client.Client.VM.revert ~rpc ~session_id ~snapshot ; + + let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:vm in + let vdi_after = get_vdi_with_user_device rpc session_id vbds "0" in + let vdi_after2 = get_vdi_with_user_device rpc session_id vbds "1" in + + (* Xapi forces VDI clones, the VDIs' IDs will always change *) + check_vdis_different vdi vdi_after ; + check_vdis_different vdi2 vdi_after2 + +let a_test with_setup tests rpc session_id sr_info vm_template () = let sr = sr_info.Qt.sr in - List.iter - (with_setup rpc session_id sr vm_template) - [test_snapshot; test_snapshot_ignore_vdi] + List.iter (with_setup rpc session_id sr vm_template) tests -let tests () = +let suite name with_setup tests sr_ops = let open Qt_filter in - [("VM snapshot tests", `Slow, test_snapshots)] + [(name, `Slow, a_test with_setup tests)] |> conn - |> sr SR.(all |> allowed_operations [`vdi_create]) + |> sr SR.(all |> allowed_operations sr_ops) |> vm_template Qt.VM.Template.other + +let tests () = + List.concat + [ + suite "VM snapshot tests" with_setup + [test_snapshot; test_snapshot_ignore_vdi] + [`vdi_create] + ; suite "VM revert tests" with_setup [test_revert] [`vdi_create; `vdi_clone] + ] From c45ba9c77cc204a916132c360a474d6ce8f1273f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Thu, 28 May 2026 15:40:33 +0100 Subject: [PATCH 14/34] quicktest: test snapshot revert with CDs VDIs containing only CDs are immutable and are prevented from being cloned. Signed-off-by: Pau Ruiz Safont (cherry picked from commit 625226b14669b702a4485f5adfec26952f93d9b2) --- ocaml/quicktest/quicktest_vm_snapshot.ml | 50 ++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/ocaml/quicktest/quicktest_vm_snapshot.ml b/ocaml/quicktest/quicktest_vm_snapshot.ml index b3d6c9c8d51..eb758fb3548 100644 --- a/ocaml/quicktest/quicktest_vm_snapshot.ml +++ b/ocaml/quicktest/quicktest_vm_snapshot.ml @@ -44,6 +44,38 @@ let with_setup rpc session_id sr vm_template f = ignore (create_vbd_disk rpc session_id vm vdi2 "1") ; f rpc session_id vm vdi vdi2 +let create_vbd_cd rpc session_id vm vdi n = + Client.Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi ~userdevice:n + ~bootable:false ~mode:`RO ~_type:`CD ~unpluggable:true ~empty:false + ~other_config:[] ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~device:"" + ~currently_attached:true + +let with_cd_setup rpc session_id sr vm_template f = + print_endline (Printf.sprintf "%s: Setting up VM" __FUNCTION__) ; + let uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:vm_template in + print_endline (Printf.sprintf "Template has uuid: %s%!" uuid) ; + let@ vm = Qt.VM.with_new rpc session_id ~template:vm_template ~sr in + print_endline (Printf.sprintf "Installed new VM") ; + print_endline + (Printf.sprintf "Using SR: %s" + (Client.Client.SR.get_name_label ~rpc ~session_id ~self:sr) + ) ; + let@ vdi = + Qt.VDI.with_new rpc session_id ~name_label:"small CD" + ~name_description:__LOC__ + ~virtual_size:Int64.(mul (mul 4L 1024L) 1024L) + sr + in + ignore (create_vbd_cd rpc session_id vm vdi "0") ; + let@ vdi2 = + Qt.VDI.with_new rpc session_id ~name_label:"small CD 2" + ~name_description:__LOC__ + ~virtual_size:Int64.(mul (mul 4L 1024L) 1024L) + sr + in + ignore (create_vbd_cd rpc session_id vm vdi2 "1") ; + f rpc session_id vm vdi vdi2 + let take_snapshot ?(ignore_vdis = []) rpc session_id vm ~origin = Client.Client.VM.snapshot ~rpc ~session_id ~vm ~new_name:(Printf.sprintf "Snapshot:%s" origin) @@ -86,6 +118,10 @@ let check_vdis_different expected result = Alcotest.(check @@ neg vdi_ref) "The VDIs after a reverting a snapshot must not be the same" expected result +let check_vdis_same expected result = + Alcotest.(check vdi_ref) + "The VDIs after a reverting a snapshot must unchanged" expected result + let test_snapshot rpc session_id vm vdi vdi2 = let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:snapshot in @@ -119,6 +155,18 @@ let test_revert rpc session_id vm vdi vdi2 = check_vdis_different vdi vdi_after ; check_vdis_different vdi2 vdi_after2 +let test_revert_cds rpc session_id vm vdi vdi2 = + let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in + Client.Client.VM.revert ~rpc ~session_id ~snapshot ; + + let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:vm in + let vdi_after = get_vdi_with_user_device rpc session_id vbds "0" in + let vdi_after2 = get_vdi_with_user_device rpc session_id vbds "1" in + + (* CD VDIs are considered immutable and the clone code ignores them *) + check_vdis_same vdi vdi_after ; + check_vdis_same vdi2 vdi_after2 + let a_test with_setup tests rpc session_id sr_info vm_template () = let sr = sr_info.Qt.sr in List.iter (with_setup rpc session_id sr vm_template) tests @@ -137,4 +185,6 @@ let tests () = [test_snapshot; test_snapshot_ignore_vdi] [`vdi_create] ; suite "VM revert tests" with_setup [test_revert] [`vdi_create; `vdi_clone] + ; suite "VM revert with CD tests" with_cd_setup [test_revert_cds] + [`vdi_create; `vdi_clone] ] From 11aab0c20230bc7f5107fcf623d9005625c394b7 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 8 Oct 2025 10:46:15 +0100 Subject: [PATCH 15/34] xapi_vm_snapshot: Plug out destroying and cloning disks into a function This is preparation for using VDI.revert. No change in behaviour Signed-off-by: Pau Ruiz Safont (cherry picked from commit 0fdaf743e5c6a136ebe1f5f21dfbd686b027aeee) --- ocaml/xapi/xapi_vm_snapshot.ml | 130 ++++++++++++++++++--------------- 1 file changed, 70 insertions(+), 60 deletions(-) diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index cf578baa88c..743987c28df 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -208,7 +208,13 @@ let safe_destroy_vusb ~__context ~rpc ~session_id vusb = (* Copy the VBDs and VIFs from a source VM to a dest VM and then delete the old disks. This operation destroys the data of the dest VM. *) -let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = +type cloned = { + disks: ([`VBD] Ref.t * API.ref_VDI * bool) list + ; cds: ([`VBD] Ref.t * API.ref_VDI * bool) list + ; suspend_VDI: [`VDI] Ref.t +} + +let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm = let snap_VBDs = Db.VM.get_VBDs ~__context ~self:snapshot in let snap_VBDs_disk, snap_VBDs_CD = List.partition @@ -221,9 +227,8 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = let snap_disks_snapshot_of = List.map (fun vdi -> Db.VDI.get_snapshot_of ~__context ~self:vdi) snap_disks in - let snap_VIFs = Db.VM.get_VIFs ~__context ~self:snapshot in - let snap_VGPUs = Db.VM.get_VGPUs ~__context ~self:snapshot in let snap_suspend_VDI = Db.VM.get_suspend_VDI ~__context ~self:snapshot in + let vm_VBDs = Db.VM.get_VBDs ~__context ~self:vm in (* Filter VBDs to ensure that we don't read empty CDROMs *) let vm_VBDs_disk = @@ -231,80 +236,85 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = (fun vbd -> Db.VBD.get_type ~__context ~self:vbd = `Disk) vm_VBDs in + (* Filter out VM disks for which the snapshot does not have a corresponding + disk - these disks will be left unattached after the revert is complete. *) let vm_disks = List.map (fun vbd -> Db.VBD.get_VDI ~__context ~self:vbd) vm_VBDs_disk in - (* Filter out VM disks for which the snapshot does not have a corresponding - disk - these disks will be left unattached after the revert is complete. *) let vm_disks_with_snapshot = List.filter (fun vdi -> List.mem vdi snap_disks_snapshot_of) vm_disks in + let vm_suspend_VDI = Db.VM.get_suspend_VDI ~__context ~self:vm in + + debug "Cleaning up the old VBDs and VDIs to have more free space" ; + List.iter (safe_destroy_vbd ~__context ~rpc ~session_id) vm_VBDs ; + List.iter + (safe_destroy_vdi ~__context ~rpc ~session_id) + (vm_suspend_VDI :: vm_disks_with_snapshot) ; + TaskHelper.set_progress ~__context 0.2 ; + debug "Cloning the snapshotted disks" ; + let driver_params = Xapi_vm_clone.make_driver_params () in + let cloned_disks = + Xapi_vm_clone.safe_clone_disks rpc session_id Xapi_vm_clone.Disk_op_clone + ~__context snap_VBDs_disk driver_params + in + let cloned_CDs = + Xapi_vm_clone.safe_clone_disks rpc session_id Xapi_vm_clone.Disk_op_clone + ~__context snap_VBDs_CD driver_params + in + TaskHelper.set_progress ~__context 0.5 ; + debug "Updating the snapshot_of fields for relevant VDIs" ; + List.iter2 + (fun snap_disk (_, cloned_disk, _) -> + (* For each snapshot disk which was just cloned: + 1) Find the value of snapshot_of + 2) Find all snapshots with the same snapshot_of + 3) Update each of these snapshots so that their snapshot_of points + to the new cloned disk. *) + let open Xapi_database.Db_filter_types in + let snapshot_of = Db.VDI.get_snapshot_of ~__context ~self:snap_disk in + let all_snaps_in_tree = + Db.VDI.get_refs_where ~__context + ~expr:(Eq (Field "snapshot_of", Literal (Ref.string_of snapshot_of))) + in + List.iter + (fun snapshot -> + Db.VDI.set_snapshot_of ~__context ~self:snapshot ~value:cloned_disk + ) + all_snaps_in_tree + ) + snap_disks cloned_disks ; + debug "Cloning the suspend VDI if needed" ; + let cloned_suspend_VDI = + if snap_suspend_VDI = Ref.null then + Ref.null + else + Xapi_vm_clone.clone_single_vdi rpc session_id Xapi_vm_clone.Disk_op_clone + ~__context snap_suspend_VDI driver_params + in + TaskHelper.set_progress ~__context 0.6 ; + {disks= cloned_disks; cds= cloned_CDs; suspend_VDI= cloned_suspend_VDI} + +let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = + let snap_VIFs = Db.VM.get_VIFs ~__context ~self:snapshot in + let snap_VGPUs = Db.VM.get_VGPUs ~__context ~self:snapshot in let vm_VIFs = Db.VM.get_VIFs ~__context ~self:vm in let vm_VGPUs = Db.VM.get_VGPUs ~__context ~self:vm in - let vm_suspend_VDI = Db.VM.get_suspend_VDI ~__context ~self:vm in let vm_VUSBs = Db.VM.get_VUSBs ~__context ~self:vm in + (* clone all the disks of the snapshot *) Helpers.call_api_functions ~__context (fun rpc session_id -> - debug "Cleaning up the old VBDs and VDIs to have more free space" ; - List.iter (safe_destroy_vbd ~__context ~rpc ~session_id) vm_VBDs ; - List.iter - (safe_destroy_vdi ~__context ~rpc ~session_id) - (vm_suspend_VDI :: vm_disks_with_snapshot) ; - TaskHelper.set_progress ~__context 0.2 ; - debug "Cloning the snapshotted disks" ; - let driver_params = Xapi_vm_clone.make_driver_params () in - let cloned_disks = - Xapi_vm_clone.safe_clone_disks rpc session_id - Xapi_vm_clone.Disk_op_clone ~__context snap_VBDs_disk driver_params - in - let cloned_CDs = - Xapi_vm_clone.safe_clone_disks rpc session_id - Xapi_vm_clone.Disk_op_clone ~__context snap_VBDs_CD driver_params - in - TaskHelper.set_progress ~__context 0.5 ; - debug "Updating the snapshot_of fields for relevant VDIs" ; - List.iter2 - (fun snap_disk (_, cloned_disk, _) -> - (* For each snapshot disk which was just cloned: - 1) Find the value of snapshot_of - 2) Find all snapshots with the same snapshot_of - 3) Update each of these snapshots so that their snapshot_of points - to the new cloned disk. *) - let open Xapi_database.Db_filter_types in - let snapshot_of = Db.VDI.get_snapshot_of ~__context ~self:snap_disk in - let all_snaps_in_tree = - Db.VDI.get_refs_where ~__context - ~expr: - (Eq (Field "snapshot_of", Literal (Ref.string_of snapshot_of))) - in - List.iter - (fun snapshot -> - Db.VDI.set_snapshot_of ~__context ~self:snapshot - ~value:cloned_disk - ) - all_snaps_in_tree - ) - snap_disks cloned_disks ; - debug "Cloning the suspend VDI if needed" ; - let cloned_suspend_VDI = - if snap_suspend_VDI = Ref.null then - Ref.null - else - Xapi_vm_clone.clone_single_vdi rpc session_id - Xapi_vm_clone.Disk_op_clone ~__context snap_suspend_VDI - driver_params - in - TaskHelper.set_progress ~__context 0.6 ; + let cloned = revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm in try debug "Copying the VBDs" ; let (_ : [`VBD] Ref.t list) = List.map (fun (vbd, vdi, _) -> Xapi_vbd_helpers.copy ~__context ~vm ~vdi vbd) - (cloned_disks @ cloned_CDs) + (cloned.disks @ cloned.cds) in TaskHelper.set_progress ~__context 0.7 ; debug "Update the suspend_VDI" ; - Db.VM.set_suspend_VDI ~__context ~self:vm ~value:cloned_suspend_VDI ; + Db.VM.set_suspend_VDI ~__context ~self:vm ~value:cloned.suspend_VDI ; debug "Cleaning up the old VIFs" ; List.iter (safe_destroy_vif ~__context ~rpc ~session_id) vm_VIFs ; debug "Setting up the new VIFs" ; @@ -332,7 +342,7 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = "Error while updating the new VBD, VDI, VIF and VGPU records. \ Cleaning up the cloned VDIs." ; let vdis = - cloned_suspend_VDI + cloned.suspend_VDI :: List.fold_left (fun acc (_, vdi, on_error_delete) -> if on_error_delete then @@ -340,7 +350,7 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = else acc ) - [] cloned_disks + [] cloned.disks in List.iter (safe_destroy_vdi ~__context ~rpc ~session_id) vdis ; raise e From c050c9114401b358370fc084a3d0563d4c0f17cc Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 8 Oct 2025 15:14:57 +0100 Subject: [PATCH 16/34] xapi_vm_snapshot: move VDI-related DB operations inside revert_vbds This moves them outside of the try catch that destroys newly-cloned disks, but this is safe since these don't change the state of the host like the destroy vifs. This allows to simplify the type needed to be able to clean up the new VDIs in case of failure. Signed-off-by: Pau Ruiz Safont (cherry picked from commit 37f15f88d22850418a32d170ccedc1cbf952cd5f) --- ocaml/xapi/xapi_vm_snapshot.ml | 46 +++++++++++++++++----------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index 743987c28df..a4b4918771b 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -293,7 +293,24 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm = ~__context snap_suspend_VDI driver_params in TaskHelper.set_progress ~__context 0.6 ; - {disks= cloned_disks; cds= cloned_CDs; suspend_VDI= cloned_suspend_VDI} + debug "Copying the VBDs" ; + let (_ : [`VBD] Ref.t list) = + List.map + (fun (vbd, vdi, _) -> Xapi_vbd_helpers.copy ~__context ~vm ~vdi vbd) + (cloned_disks @ cloned_CDs) + in + debug "Update the suspend_VDI" ; + Db.VM.set_suspend_VDI ~__context ~self:vm ~value:cloned_suspend_VDI ; + + cloned_suspend_VDI + :: List.fold_left + (fun acc (_, vdi, on_error_delete) -> + if on_error_delete then + vdi :: acc + else + acc + ) + [] cloned_disks let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = let snap_VIFs = Db.VM.get_VIFs ~__context ~self:snapshot in @@ -304,17 +321,11 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = (* clone all the disks of the snapshot *) Helpers.call_api_functions ~__context (fun rpc session_id -> - let cloned = revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm in + let vdis_to_cleanup = + revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm + in + TaskHelper.set_progress ~__context 0.7 ; try - debug "Copying the VBDs" ; - let (_ : [`VBD] Ref.t list) = - List.map - (fun (vbd, vdi, _) -> Xapi_vbd_helpers.copy ~__context ~vm ~vdi vbd) - (cloned.disks @ cloned.cds) - in - TaskHelper.set_progress ~__context 0.7 ; - debug "Update the suspend_VDI" ; - Db.VM.set_suspend_VDI ~__context ~self:vm ~value:cloned.suspend_VDI ; debug "Cleaning up the old VIFs" ; List.iter (safe_destroy_vif ~__context ~rpc ~session_id) vm_VIFs ; debug "Setting up the new VIFs" ; @@ -341,18 +352,7 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = error "Error while updating the new VBD, VDI, VIF and VGPU records. \ Cleaning up the cloned VDIs." ; - let vdis = - cloned.suspend_VDI - :: List.fold_left - (fun acc (_, vdi, on_error_delete) -> - if on_error_delete then - vdi :: acc - else - acc - ) - [] cloned.disks - in - List.iter (safe_destroy_vdi ~__context ~rpc ~session_id) vdis ; + List.iter (safe_destroy_vdi ~__context ~rpc ~session_id) vdis_to_cleanup ; raise e ) From c5ed79110482ed9bc2e7367d2709db52cda6e47e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 8 Oct 2025 17:03:56 +0100 Subject: [PATCH 17/34] xapi_vm_snapshot: cover more code to destroy newly cloned VDIs Previously in some parts of the revert, (rare) failures would not induce the deletion of newly cloned VDIs. Signed-off-by: Pau Ruiz Safont (cherry picked from commit b996de8221067c67cbc3901681133ad0c7b3b58b) --- ocaml/xapi/xapi_vm_snapshot.ml | 57 +++++++++++++++++++++------------- 1 file changed, 35 insertions(+), 22 deletions(-) diff --git a/ocaml/xapi/xapi_vm_snapshot.ml b/ocaml/xapi/xapi_vm_snapshot.ml index a4b4918771b..19c8a55f1c2 100644 --- a/ocaml/xapi/xapi_vm_snapshot.ml +++ b/ocaml/xapi/xapi_vm_snapshot.ml @@ -206,6 +206,10 @@ let safe_destroy_vusb ~__context ~rpc ~session_id vusb = if Db.is_valid_ref __context vusb then Client.VUSB.destroy ~rpc ~session_id ~self:vusb +let with_vdis_on_error ~vdis f = try f () with e -> Error (e, vdis) + +let ( let@ ) f x = f x + (* Copy the VBDs and VIFs from a source VM to a dest VM and then delete the old disks. This operation destroys the data of the dest VM. *) type cloned = { @@ -258,6 +262,17 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm = Xapi_vm_clone.safe_clone_disks rpc session_id Xapi_vm_clone.Disk_op_clone ~__context snap_VBDs_disk driver_params in + let destroy_vdis_on_error = + List.filter_map + (fun (_, vdi, on_error_delete) -> + if on_error_delete then + Some vdi + else + None + ) + cloned_disks + in + let@ () = with_vdis_on_error ~vdis:destroy_vdis_on_error in let cloned_CDs = Xapi_vm_clone.safe_clone_disks rpc session_id Xapi_vm_clone.Disk_op_clone ~__context snap_VBDs_CD driver_params @@ -292,6 +307,8 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm = Xapi_vm_clone.clone_single_vdi rpc session_id Xapi_vm_clone.Disk_op_clone ~__context snap_suspend_VDI driver_params in + let destroy_vdis_on_error = cloned_suspend_VDI :: destroy_vdis_on_error in + let@ () = with_vdis_on_error ~vdis:destroy_vdis_on_error in TaskHelper.set_progress ~__context 0.6 ; debug "Copying the VBDs" ; let (_ : [`VBD] Ref.t list) = @@ -301,16 +318,7 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm = in debug "Update the suspend_VDI" ; Db.VM.set_suspend_VDI ~__context ~self:vm ~value:cloned_suspend_VDI ; - - cloned_suspend_VDI - :: List.fold_left - (fun acc (_, vdi, on_error_delete) -> - if on_error_delete then - vdi :: acc - else - acc - ) - [] cloned_disks + Ok destroy_vdis_on_error let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = let snap_VIFs = Db.VM.get_VIFs ~__context ~self:snapshot in @@ -321,11 +329,11 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = (* clone all the disks of the snapshot *) Helpers.call_api_functions ~__context (fun rpc session_id -> - let vdis_to_cleanup = - revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm - in - TaskHelper.set_progress ~__context 0.7 ; - try + let ( let* ) = Result.bind in + let destroy_error_vdis = + let* new_vdis = revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm in + let@ () = with_vdis_on_error ~vdis:new_vdis in + TaskHelper.set_progress ~__context 0.7 ; debug "Cleaning up the old VIFs" ; List.iter (safe_destroy_vif ~__context ~rpc ~session_id) vm_VIFs ; debug "Setting up the new VIFs" ; @@ -347,13 +355,18 @@ let update_vifs_vbds_vgpus_and_vusbs ~__context ~snapshot ~vm = let (_ : [`VGPU] Ref.t list) = List.map (fun vgpu -> Xapi_vgpu.copy ~__context ~vm vgpu) snap_VGPUs in - TaskHelper.set_progress ~__context 0.9 - with e -> - error - "Error while updating the new VBD, VDI, VIF and VGPU records. \ - Cleaning up the cloned VDIs." ; - List.iter (safe_destroy_vdi ~__context ~rpc ~session_id) vdis_to_cleanup ; - raise e + TaskHelper.set_progress ~__context 0.9 ; + Ok () + in + match destroy_error_vdis with + | Ok () -> + () + | Error (e, vdis) -> + error + "Error while updating the new VBD, VDI, VIF and VGPU records. \ + Cleaning up the cloned VDIs." ; + List.iter (safe_destroy_vdi ~__context ~rpc ~session_id) vdis ; + raise e ) let update_guest_metrics ~__context ~vm ~snapshot = From e3d58e20ebd472a20152eb558905e9e34dbd75f6 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 29 May 2026 10:59:03 +0100 Subject: [PATCH 18/34] quicktest: adapt vm_snapshot tests and quality gate to master The VM creation function was added and the usage needs to be adapted to avoid a partial application. Signed-off-by: Pau Ruiz Safont --- ocaml/quicktest/quicktest_vm_snapshot.ml | 4 ++-- quality-gate.sh | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ocaml/quicktest/quicktest_vm_snapshot.ml b/ocaml/quicktest/quicktest_vm_snapshot.ml index eb758fb3548..10fa82cca7e 100644 --- a/ocaml/quicktest/quicktest_vm_snapshot.ml +++ b/ocaml/quicktest/quicktest_vm_snapshot.ml @@ -23,7 +23,7 @@ let with_setup rpc session_id sr vm_template f = print_endline "Setting up test VM" ; let uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:vm_template in print_endline (Printf.sprintf "Template has uuid: %s%!" uuid) ; - let@ vm = Qt.VM.with_new rpc session_id ~template:vm_template ~sr in + let@ vm = Qt.VM.with_new rpc session_id ~template:vm_template ~sr ?iso:None in print_endline (Printf.sprintf "Installed new VM") ; print_endline (Printf.sprintf "Using SR: %s" @@ -54,7 +54,7 @@ let with_cd_setup rpc session_id sr vm_template f = print_endline (Printf.sprintf "%s: Setting up VM" __FUNCTION__) ; let uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:vm_template in print_endline (Printf.sprintf "Template has uuid: %s%!" uuid) ; - let@ vm = Qt.VM.with_new rpc session_id ~template:vm_template ~sr in + let@ vm = Qt.VM.with_new rpc session_id ~template:vm_template ~sr ?iso:None in print_endline (Printf.sprintf "Installed new VM") ; print_endline (Printf.sprintf "Using SR: %s" diff --git a/quality-gate.sh b/quality-gate.sh index e4c6f228844..228cf58e0e7 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=454 + N=453 X="ocaml/tests" X+="|ocaml/quicktest" X+="|ocaml/message-switch/core_test" From 1e06c819d4d2ab255ff2f97dd20e70cb21c1002b Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 18 Feb 2026 15:28:20 +0000 Subject: [PATCH 19/34] xapi_globs: Add vhd_legacy_blocks_format feature flag This allows to switch on the more efficient interval format later. (QCOW always uses the new format) Signed-off-by: Andrii Sultanov (cherry picked from commit 1aa52ef9d7bf3fba321cfd0a04c405a87d2dde13) --- ocaml/xapi/xapi_globs.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 4d90de5c686..c5e5f938838 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -1146,6 +1146,10 @@ let validate_reusable_pool_session = ref false let vm_sysprep_enabled = ref true (* enable VM.sysprep API *) +let vhd_legacy_blocks_format = ref true +(* If false, uses an interval-based JSON blocks format for VHD instead of the + legacy format which includes all the allocated clusters *) + let vm_sysprep_wait = ref 5.0 (* seconds *) let test_open = ref 0 @@ -1870,6 +1874,12 @@ let other_options = , (fun () -> string_of_float !vm_sysprep_wait) , "Time in seconds to wait for VM to recognise inserted CD" ) + ; ( "vhd-legacy-blocks-format" + , Arg.Set vhd_legacy_blocks_format + , (fun () -> string_of_bool !vhd_legacy_blocks_format) + , "Choose whether legacy/sparse block format will be used for determining \ + allocated VHD clusters" + ) ; ( "proxy_poll_period_timeout" , Arg.Set_float proxy_poll_period_timeout , (fun () -> string_of_float !proxy_poll_period_timeout) From 84479f9bb2c7e944228da1aef0d9a4f57e5e341c Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 18 Feb 2026 15:45:19 +0000 Subject: [PATCH 20/34] vhd-tool: Add read_headers_interval command This command returns a more efficient representation of allocated clusters (when compared to read_headers), utilizing a sparse interval format instead of returning every single allocated cluster. This is the more efficient option, decreasing the filesize and memory usage in vhd-tool, but it's currently under a feature flag, so it's added as a new command instead of replacing read_headers immediately. Cram test for read_headers is still passing, so this refactoring has preserved the legacy format. Signed-off-by: Andrii Sultanov (cherry picked from commit fa4f51614b008df62bb94d015fdfdd80fdb0d1c9) --- ocaml/libs/vhd/vhd_format/f.ml | 64 +++++++++++++++++++++++++-------- ocaml/libs/vhd/vhd_format/f.mli | 2 ++ ocaml/vhd-tool/cli/main.ml | 26 +++++++++++--- ocaml/vhd-tool/src/impl.ml | 8 +++-- ocaml/vhd-tool/src/impl.mli | 2 +- 5 files changed, 79 insertions(+), 23 deletions(-) diff --git a/ocaml/libs/vhd/vhd_format/f.ml b/ocaml/libs/vhd/vhd_format/f.ml index 4285d2fabd4..c3bf4dce4b6 100644 --- a/ocaml/libs/vhd/vhd_format/f.ml +++ b/ocaml/libs/vhd/vhd_format/f.ml @@ -2903,24 +2903,10 @@ functor let raw ?from (vhd : fd Vhd.t) = raw_common ?from vhd - let vhd_blocks_to_json (t : fd Vhd.t) = + let vhd_blocks_to_json_aux (t : fd Vhd.t) blocks = let block_size_sectors_shift = t.Vhd.header.Header.block_size_sectors_shift in - let max_table_entries = Vhd.used_max_table_entries t in - - let include_block = include_block None t in - - let blocks = - Seq.init max_table_entries Fun.id - |> Seq.filter_map (fun i -> - if include_block i then - Some (`Int i) - else - None - ) - |> List.of_seq - in let json = `Assoc [ @@ -2934,6 +2920,52 @@ functor let json_string = Yojson.to_string json in print_string json_string ; return () + let vhd_blocks_to_json (t : fd Vhd.t) = + let max_table_entries = Vhd.used_max_table_entries t in + let blocks = + Seq.init max_table_entries Fun.id + |> Seq.filter_map (fun i -> + if include_block None t i then + Some (`Int i) + else + None + ) + |> List.of_seq + in + vhd_blocks_to_json_aux t blocks + + let vhd_blocks_to_json_interval (t : fd Vhd.t) = + let max_table_entries = Vhd.used_max_table_entries t in + let blocks, last_block = + Seq.init max_table_entries Fun.id + |> Seq.fold_left + (fun (acc, left_block) i -> + if include_block None t i then + match left_block with + | Some _ -> + (acc, left_block) + | None -> + (acc, Some i) + else + match left_block with + | Some x -> + (`List [`Int x; `Int (i - 1)] :: acc, None) + | None -> + (acc, None) + ) + ([], None) + in + (* Close off the interval we were tracking we ran off the end of the seq *) + let blocks = + match last_block with + | Some x -> + `List [`Int x; `Int (max_table_entries - 1)] :: blocks + | None -> + blocks + in + let blocks = List.rev blocks in + vhd_blocks_to_json_aux t blocks + let vhd_common ?from ?raw ?(emit_batmap = false) (t : fd Vhd.t) = let block_size_sectors_shift = t.Vhd.header.Header.block_size_sectors_shift @@ -3173,6 +3205,8 @@ functor Vhd_input.vhd_common ?from ~raw vhd let blocks_json = Vhd_input.vhd_blocks_to_json + + let blocks_json_interval = Vhd_input.vhd_blocks_to_json_interval end (* Create a VHD stream from data on t, using `include_block` guide us which blocks have data *) diff --git a/ocaml/libs/vhd/vhd_format/f.mli b/ocaml/libs/vhd/vhd_format/f.mli index a4b4e976183..fdeca3ad15e 100644 --- a/ocaml/libs/vhd/vhd_format/f.mli +++ b/ocaml/libs/vhd/vhd_format/f.mli @@ -470,6 +470,8 @@ module From_file : functor (F : S.FILE) -> sig [from] into [t] *) val blocks_json : fd Vhd.t -> unit t + + val blocks_json_interval : fd Vhd.t -> unit t end module Raw_input : sig diff --git a/ocaml/vhd-tool/cli/main.ml b/ocaml/vhd-tool/cli/main.ml index a4043b52b3c..e131879c4ed 100644 --- a/ocaml/vhd-tool/cli/main.ml +++ b/ocaml/vhd-tool/cli/main.ml @@ -385,19 +385,34 @@ let stream_cmd = , Cmd.info "stream" ~sdocs:_common_options ~doc ~man ) +let vhd_source = + let doc = Printf.sprintf "Path to the VHD file" in + Arg.(required & pos 0 (some file) None & info [] ~doc) + let read_headers_cmd = let doc = {|Parse VHD headers and output allocated blocks information in JSON format \ like: {"virtual_size": X, "cluster_bits": X, "data_clusters": [1,2,3]}|} in - let source = - let doc = Printf.sprintf "Path to the VHD file" in - Arg.(required & pos 0 (some file) None & info [] ~doc) - in - ( Term.(ret (const Impl.read_headers $ common_options_t $ source)) + ( Term.( + ret + (const (Impl.read_headers ~legacy:true) $ common_options_t $ vhd_source) + ) , Cmd.info "read_headers" ~sdocs:_common_options ~doc ) +let read_headers_interval_cmd = + let doc = + {|Parse VHD headers and output allocated blocks intervals information in JSON format \ + like: {"virtual_size": X, "cluster_bits": X, "data_clusters": [[1,13],[17,17],[19,272]]|} + in + ( Term.( + ret + (const (Impl.read_headers ~legacy:false) $ common_options_t $ vhd_source) + ) + , Cmd.info "read_headers_interval" ~sdocs:_common_options ~doc + ) + let cmds = [ info_cmd @@ -408,6 +423,7 @@ let cmds = ; serve_cmd ; stream_cmd ; read_headers_cmd + ; read_headers_interval_cmd ] |> List.map (fun (t, i) -> Cmd.v i t) diff --git a/ocaml/vhd-tool/src/impl.ml b/ocaml/vhd-tool/src/impl.ml index 530c915b8e3..6c759535176 100644 --- a/ocaml/vhd-tool/src/impl.ml +++ b/ocaml/vhd-tool/src/impl.ml @@ -1168,11 +1168,15 @@ let stream_t common args ?(progress = no_progress_bar) () = args.StreamCommon.tar_filename_prefix args.StreamCommon.good_ciphersuites args.StreamCommon.verify_cert -let read_headers common source = +let read_headers common source ~legacy = let path = [Filename.dirname source] in let thread = retry common 3 (fun () -> Vhd_IO.openchain ~path source false) >>= fun t -> - Vhd_IO.close t >>= fun () -> Hybrid_input.blocks_json t + Vhd_IO.close t >>= fun () -> + if legacy then + Hybrid_input.blocks_json t + else + Hybrid_input.blocks_json_interval t in Lwt_main.run thread ; `Ok () diff --git a/ocaml/vhd-tool/src/impl.mli b/ocaml/vhd-tool/src/impl.mli index 13fe7ba6853..d2adae5a9dc 100644 --- a/ocaml/vhd-tool/src/impl.mli +++ b/ocaml/vhd-tool/src/impl.mli @@ -36,7 +36,7 @@ val stream : Common.t -> StreamCommon.t -> [> `Error of bool * string | `Ok of unit] val read_headers : - Common.t -> string -> [> `Error of bool * string | `Ok of unit] + Common.t -> string -> legacy:bool -> [> `Error of bool * string | `Ok of unit] val serve : Common.t From 65df8234540d76ae8e5adaf9706a703d4d22fe48 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 18 Feb 2026 16:03:38 +0000 Subject: [PATCH 21/34] vhd_qcow_parsing: Add parse_header_interval for interval-based headers Since the runtime feature flag vhd_legacy_blocks_format determines which block format is used to describe allocated VHD clusters, this requires duplicate parse_header_interval functions for VHD and QCOW. The right functions are selected in stream_vdi based on the feature flag. Signed-off-by: Andrii Sultanov (cherry picked from commit 5457512630cecd0fa148a765906014d1177fcb5b) --- ocaml/xapi/qcow_tool_wrapper.ml | 4 ++ ocaml/xapi/qcow_tool_wrapper.mli | 2 + ocaml/xapi/stream_vdi.ml | 120 +++++++++++++++++++++++-------- ocaml/xapi/vhd_qcow_parsing.ml | 23 +++++- ocaml/xapi/vhd_qcow_parsing.mli | 2 + ocaml/xapi/vhd_tool_wrapper.ml | 15 +++- 6 files changed, 133 insertions(+), 33 deletions(-) diff --git a/ocaml/xapi/qcow_tool_wrapper.ml b/ocaml/xapi/qcow_tool_wrapper.ml index c04617f4fa6..24f396f0dac 100644 --- a/ocaml/xapi/qcow_tool_wrapper.ml +++ b/ocaml/xapi/qcow_tool_wrapper.ml @@ -45,6 +45,10 @@ let parse_header qcow_path = let pipe_reader = read_header qcow_path in Vhd_qcow_parsing.parse_header pipe_reader +let parse_header_interval qcow_path = + let pipe_reader = read_header qcow_path in + Vhd_qcow_parsing.parse_header_interval pipe_reader + let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr) (path : string) (_size : Int64.t) = let qcow_of_device = diff --git a/ocaml/xapi/qcow_tool_wrapper.mli b/ocaml/xapi/qcow_tool_wrapper.mli index c1c4a6426af..16cede3bbcd 100644 --- a/ocaml/xapi/qcow_tool_wrapper.mli +++ b/ocaml/xapi/qcow_tool_wrapper.mli @@ -25,3 +25,5 @@ val send : -> unit val parse_header : string -> int * int list + +val parse_header_interval : string -> int * (int * int) list diff --git a/ocaml/xapi/stream_vdi.ml b/ocaml/xapi/stream_vdi.ml index 9b4e5bebd7b..4481cb767de 100644 --- a/ocaml/xapi/stream_vdi.ml +++ b/ocaml/xapi/stream_vdi.ml @@ -306,37 +306,99 @@ let send_one ofd (__context : Context.t) rpc session_id progress refresh_session | Ok (Some (driver, path)) when driver = "vhd" || driver = "qcow2" -> ( try - (* Read backing file headers, then only read and write + let last_chunk = Int64.((to_int size - 1) / to_int chunk_size) in + if !Xapi_globs.vhd_legacy_blocks_format then + (* Read backing file headers, then only read and write allocated clusters from the bitmap *) - let cluster_size, cluster_list = - match driver with - | "vhd" -> - Vhd_tool_wrapper.parse_header path - | "qcow2" -> - Qcow_tool_wrapper.parse_header path - | _ -> - failwith (Printf.sprintf "%s: unreachable" __FUNCTION__) - in - let set = - get_allocated_chunks_from_clusters cluster_size cluster_list - in - (* First and last chunks are always written - it's a limitation + let cluster_size, cluster_list = + match driver with + | "vhd" -> + Vhd_tool_wrapper.parse_header path + | "qcow2" -> + Qcow_tool_wrapper.parse_header path + | _ -> + failwith (Printf.sprintf "%s: unreachable" __FUNCTION__) + in + let set = + get_allocated_chunks_from_clusters cluster_size cluster_list + in + (* First and last chunks are always written - it's a limitation of the XVA format *) - let last_chunk = - Int64.((to_int size - to_int chunk_size + 1) / to_int chunk_size) - in - let set = set |> ChunkSet.add 0 |> ChunkSet.add last_chunk in - ChunkSet.iter - (fun this_chunk_no -> - let offset = Int64.(mul (of_int this_chunk_no) chunk_size) in - let _ = - write_chunk this_chunk_no offset - ~write_check:(fun _ _ -> true) - ~seek:true ~timeout_workaround:false - in - () - ) - set + let set = set |> ChunkSet.add 0 |> ChunkSet.add last_chunk in + ChunkSet.iter + (fun this_chunk_no -> + let offset = + Int64.(mul (of_int this_chunk_no) chunk_size) + in + let _ = + write_chunk this_chunk_no offset + ~write_check:(fun _ _ -> true) + ~seek:true ~timeout_workaround:false + in + () + ) + set + else + let cluster_size, cluster_list = + match driver with + | "vhd" -> + Vhd_tool_wrapper.parse_header_interval path + | "qcow2" -> + Qcow_tool_wrapper.parse_header_interval path + | _ -> + failwith (Printf.sprintf "%s: unreachable" __FUNCTION__) + in + let process_chunk chunk_no ~force = + if force || (chunk_no <> 0 && chunk_no <> last_chunk) then + let offset = Int64.(mul (of_int chunk_no) chunk_size) in + let _ = + write_chunk chunk_no offset + ~write_check:(fun _ _ -> true) + ~seek:true ~timeout_workaround:false + in + () + in + + process_chunk 0 ~force:true ; + + let chunk_size = Int64.to_int chunk_size in + let chunks_in_cluster = + (cluster_size + chunk_size - 1) / chunk_size + in + (* Iterate over allocated intervals, copying every cluster inside *) + let _ = + List.fold_left + (fun prev_chunk (cluster_no_left, cluster_no_right) -> + let calc_chunk cluster = + let cluster_offset = cluster * cluster_size in + let chunk_no = cluster_offset / chunk_size in + chunk_no + in + let left_chunk_no = calc_chunk cluster_no_left in + let right_chunk_no = + calc_chunk cluster_no_right + chunks_in_cluster - 1 + in + + (* If a chunk contains multiple clusters, we could have + already copied it. In that case, start with the + following chunk. *) + let left_chunk_no = + if left_chunk_no = prev_chunk then + left_chunk_no + 1 + else + left_chunk_no + in + + for i = left_chunk_no to right_chunk_no do + process_chunk i ~force:false + done ; + + right_chunk_no + ) + (-1) cluster_list + in + + process_chunk last_chunk ~force:true with e -> debug "%s: Falling back to reading the whole raw disk after %s" __FUNCTION__ (Printexc.to_string e) ; diff --git a/ocaml/xapi/vhd_qcow_parsing.ml b/ocaml/xapi/vhd_qcow_parsing.ml index 627f16bb049..0956b4d8f1d 100644 --- a/ocaml/xapi/vhd_qcow_parsing.ml +++ b/ocaml/xapi/vhd_qcow_parsing.ml @@ -44,7 +44,7 @@ let run_tool tool ?(replace_fds = []) ?input_fd ?output_fd error "%s output: %s" tool out ; raise (Api_errors.Server_error (Api_errors.vdi_io_error, [out])) -let parse_header pipe_reader = +let parse_header_aux pipe_reader = let ic = Unix.in_channel_of_descr pipe_reader in let buf = Buffer.create 4096 in let json = Yojson.Basic.from_channel ~buf ~fname:"header.json" ic in @@ -52,7 +52,28 @@ let parse_header pipe_reader = let cluster_size = 1 lsl Yojson.Basic.Util.(member "cluster_bits" json |> to_int) in + (cluster_size, json) + +let parse_header pipe_reader = + let cluster_size, json = parse_header_aux pipe_reader in let cluster_list = Yojson.Basic.Util.(member "data_clusters" json |> to_list |> List.map to_int) in (cluster_size, cluster_list) + +let parse_header_interval pipe_reader = + let cluster_size, json = parse_header_aux pipe_reader in + let cluster_list = + Yojson.Basic.Util.( + member "data_clusters" json + |> to_list + |> List.map (fun x -> + match to_list x with + | x :: y :: _ -> + (to_int x, to_int y) + | _ -> + raise (Invalid_argument "Invalid JSON") + ) + ) + in + (cluster_size, cluster_list) diff --git a/ocaml/xapi/vhd_qcow_parsing.mli b/ocaml/xapi/vhd_qcow_parsing.mli index 25417c0b91c..2df479d921a 100644 --- a/ocaml/xapi/vhd_qcow_parsing.mli +++ b/ocaml/xapi/vhd_qcow_parsing.mli @@ -22,3 +22,5 @@ val run_tool : -> unit val parse_header : Unix.file_descr -> int * int list + +val parse_header_interval : Unix.file_descr -> int * (int * int) list diff --git a/ocaml/xapi/vhd_tool_wrapper.ml b/ocaml/xapi/vhd_tool_wrapper.ml index 64afa6b4522..a2faa5acc09 100644 --- a/ocaml/xapi/vhd_tool_wrapper.ml +++ b/ocaml/xapi/vhd_tool_wrapper.ml @@ -116,9 +116,14 @@ let receive progress_cb format protocol (s : Unix.file_descr) in run_vhd_tool progress_cb args s s' path -let read_vhd_header path = +let read_vhd_header path ~legacy = let vhd_tool = !Xapi_globs.vhd_tool in - let args = ["read_headers"; path] in + let args = + if legacy then + ["read_headers"; path] + else + ["read_headers_interval"; path] + in let pipe_reader, pipe_writer = Unix.pipe ~cloexec:true () in let progress_cb _ = () in @@ -137,9 +142,13 @@ let read_vhd_header path = pipe_reader let parse_header vhd_path = - let pipe_reader = read_vhd_header vhd_path in + let pipe_reader = read_vhd_header vhd_path ~legacy:true in Vhd_qcow_parsing.parse_header pipe_reader +let parse_header_interval vhd_path = + let pipe_reader = read_vhd_header vhd_path ~legacy:false in + Vhd_qcow_parsing.parse_header_interval pipe_reader + let send progress_cb ?relative_to (protocol : string) (dest_format : string) (s : Unix.file_descr) (path : string) (size : Int64.t) (prefix : string) = let __FUN = __FUNCTION__ in From a782783583ed1ccb85b7b969030fd6b39a2c7957 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 4 Feb 2026 13:20:56 +0000 Subject: [PATCH 22/34] python3/qcow2-to-stdout: Implement Interval for checking sparse cluster allocation Instead of using a set with every individual allocated cluster index as a member, use a sorted list of intervals to verify if cluster is allocated - this uses much less memory and directly follows from the JSON format qcow-stream-tool and vhd-tool output now. Signed-off-by: Andrii Sultanov (cherry picked from commit 1fc8ee7524f3c0c665c5f5feafdce78d97f1da99) --- python3/libexec/qcow2-to-stdout.py | 59 ++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) diff --git a/python3/libexec/qcow2-to-stdout.py b/python3/libexec/qcow2-to-stdout.py index 4ce1cc72b56..912314f340f 100755 --- a/python3/libexec/qcow2-to-stdout.py +++ b/python3/libexec/qcow2-to-stdout.py @@ -91,6 +91,65 @@ def write_features(cluster, offset, data_file_name): offset += 48 +class Interval: + """ + Represents the allocated virtual cluster intervals in a sparse file + """ + def __init__(self, lst): + self.intervals = lst + self.intervals.sort(key=lambda x: x[0]) + + + def __contains__(self, cluster): + """ + Checks if cluster is in one of the intervals, removes it from the + interval if true + """ + # Check if cluster is within [min, max] + if (len(self.intervals) == 0 or + (self.intervals[-1][1] < cluster or self.intervals[0][0] > cluster)): + return False + + # Binary search for the interval that could contain the cluster + l = 0 + h = len(self.intervals) - 1 + while l <= h: + mid = (l + h) // 2 + current = self.intervals[mid] + + if cluster >= current[0] and cluster <= current[1]: + if cluster == current[0] and cluster == current[1]: + # Remove the cluster from the interval + del self.intervals[mid] + return True + + if cluster == current[0]: + # Shrink interval from the left + left = current[0] + 1 + right = current[1] + elif cluster == current[1]: + # Shrink interval from the right + left = current[0] + right = current[1] - 1 + else: + # Split the original interval into two + left = current[0] + right = cluster + self.intervals.insert(mid+1, [cluster+1, current[1]]) + + self.intervals[mid] = [left, right] + return True + elif cluster < current[0]: + h = mid - 1 + elif cluster > current[1]: + l = mid + 1 + + return False + + def __iter__(self): + return self.intervals.__iter__() + + def write_qcow2_content(input_file, cluster_size, refcount_bits, data_file_name, data_file_raw, diff_file_name, virtual_size, nonzero_clusters, From 499d7803db7c9d6d25a102147bcb45cb0ddf8db6 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 4 Feb 2026 13:27:05 +0000 Subject: [PATCH 23/34] python3/qcow2-to-stdout: Switch to sparse interval format for nonzero_clusters nonzero_clusters no longer contain every single allocated cluster and instead are intervals of allocated clusters. Signed-off-by: Andrii Sultanov (cherry picked from commit a52b1261e30584a626293e158b0f2c8fa2e47406) --- python3/libexec/qcow2-to-stdout.py | 37 ++++++++++++++++-------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/python3/libexec/qcow2-to-stdout.py b/python3/libexec/qcow2-to-stdout.py index 912314f340f..43bcbc402f2 100755 --- a/python3/libexec/qcow2-to-stdout.py +++ b/python3/libexec/qcow2-to-stdout.py @@ -225,26 +225,29 @@ def check_cluster_allocate(idx, cluster, cluster_to_compare_with): # In case input_file is bigger than diff_file_name, first check # if clusters from diff_file_name differ, and then check if the # rest contain data - diff_nonzero_clusters_set = set(diff_nonzero_clusters) - for cluster in nonzero_clusters: - if cluster >= last_diff_cluster: - allocate_cluster(cluster) - elif cluster in diff_nonzero_clusters_set: - # If a cluster has different data from the original_cluster - # then it must be allocated - cluster_data = os.pread(fd, cluster_size, cluster_size * cluster) - original_cluster = os.pread(diff_fd, cluster_size, cluster_size * cluster) - check_cluster_allocate(cluster, cluster_data, original_cluster) - diff_nonzero_clusters_set.remove(cluster) - else: - allocate_cluster(cluster) + diff_nonzero_clusters_set = Interval(diff_nonzero_clusters) + + for (cluster_left, cluster_right) in nonzero_clusters: + for cluster in range(cluster_left, cluster_right+1): + if cluster >= last_diff_cluster: + allocate_cluster(cluster) + elif cluster in diff_nonzero_clusters_set: + # If a cluster has different data from the original_cluster + # then it must be allocated + cluster_data = os.pread(fd, cluster_size, cluster_size * cluster) + original_cluster = os.pread(diff_fd, cluster_size, cluster_size * cluster) + check_cluster_allocate(cluster, cluster_data, original_cluster) + else: + allocate_cluster(cluster) # These are not present in the original file - for cluster in diff_nonzero_clusters_set: - allocate_cluster(cluster) + for (cluster_left, cluster_right) in diff_nonzero_clusters_set: + for cluster in range(cluster_left, cluster_right+1): + allocate_cluster(cluster) else: - for cluster in nonzero_clusters: - allocate_cluster(cluster) + for (cluster_left, cluster_right) in nonzero_clusters: + for cluster in range(cluster_left, cluster_right+1): + allocate_cluster(cluster) else: zero_cluster = bytes(cluster_size) From 3dc02941b93d3047fd1001e901d3c17b76e0209d Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Fri, 6 Feb 2026 09:05:27 +0000 Subject: [PATCH 24/34] qcow_tool_wrapper: Add note on using header information from VHD files Signed-off-by: Andrii Sultanov (cherry picked from commit f9db34b93968362aec0a963f2ebdcc4115c84ef7) --- ocaml/xapi/qcow_tool_wrapper.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ocaml/xapi/qcow_tool_wrapper.ml b/ocaml/xapi/qcow_tool_wrapper.ml index 24f396f0dac..947c5d2ba53 100644 --- a/ocaml/xapi/qcow_tool_wrapper.ml +++ b/ocaml/xapi/qcow_tool_wrapper.ml @@ -60,6 +60,11 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr) to avoid reading all of the raw disk *) let input_fd = Result.map read_header qcow_path |> Result.to_option in + (* TODO: If VHD headers are to be consulted as well, qcow2-to-stdout + needs to properly account for cluster_bits. Currently QCOW2 export + from VHD-backed VDIs will just revert to raw, without any + allocation accounting. *) + (* Parse the header of the VDI we are diffing against as well *) let relative_to_qcow_path = match relative_to with From 48bf0fcca358e91d5d3024548d6e8ab4f7e3d6a5 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Fri, 27 Mar 2026 14:27:08 +0000 Subject: [PATCH 25/34] qcow_tool_wrapper: Call qemu-img instead of qcow-stream-tool This proves much more reliable than code based on ocaml-qcow. Since qemu-img has a different format (with the needed information spread across two files resulting from calls to 'qemu-img info' and 'qemu-img map'), change the parsing code in vhd_qcow_parsing and qcow2-to-stdout. Signed-off-by: Andrii Sultanov (cherry picked from commit 3f6f6dd2bad13027350b6d95fc5989e2b8619604) --- ocaml/xapi/qcow_tool_wrapper.ml | 87 ++++++++++++++++++++++-------- ocaml/xapi/vhd_qcow_parsing.ml | 32 ++++++++++- ocaml/xapi/vhd_qcow_parsing.mli | 3 ++ ocaml/xapi/xapi_globs.ml | 3 ++ python3/libexec/qcow2-to-stdout.py | 74 +++++++++++++++---------- 5 files changed, 148 insertions(+), 51 deletions(-) diff --git a/ocaml/xapi/qcow_tool_wrapper.ml b/ocaml/xapi/qcow_tool_wrapper.ml index 947c5d2ba53..652db754ac7 100644 --- a/ocaml/xapi/qcow_tool_wrapper.ml +++ b/ocaml/xapi/qcow_tool_wrapper.ml @@ -22,32 +22,43 @@ let receive (progress_cb : int -> unit) (unix_fd : Unix.file_descr) Vhd_qcow_parsing.run_tool qcow_tool progress_cb args ~input_fd:unix_fd let read_header qcow_path = - let args = ["read_headers"; qcow_path] in - let qcow_tool = !Xapi_globs.qcow_stream_tool in - let pipe_reader, pipe_writer = Unix.pipe ~cloexec:true () in - let progress_cb _ = () in - let (_ : Thread.t) = + let run_in_thread tool args pipe_writer replace_fds = Thread.create (fun () -> Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> - Vhd_qcow_parsing.run_tool qcow_tool progress_cb args - ~output_fd:pipe_writer + Vhd_qcow_parsing.run_tool tool progress_cb args + ~output_fd:pipe_writer ~replace_fds ) (fun () -> Unix.close pipe_writer) ) () in - pipe_reader + + let map_pipe_reader, map_pipe_writer = Unix.pipe ~cloexec:true () in + let (_ : Thread.t) = + run_in_thread !Xapi_globs.qemu_img + ["map"; qcow_path; "--output=json"] + map_pipe_writer [] + in + + let info_pipe_reader, info_pipe_writer = Unix.pipe ~cloexec:true () in + let (_ : Thread.t) = + run_in_thread !Xapi_globs.qemu_img + ["info"; qcow_path; "--output=json"] + info_pipe_writer [] + in + + (map_pipe_reader, info_pipe_reader) let parse_header qcow_path = - let pipe_reader = read_header qcow_path in - Vhd_qcow_parsing.parse_header pipe_reader + let pipe, _ = read_header qcow_path in + Vhd_qcow_parsing.parse_header pipe let parse_header_interval qcow_path = - let pipe_reader = read_header qcow_path in - Vhd_qcow_parsing.parse_header_interval pipe_reader + let pipes = read_header qcow_path in + Vhd_qcow_parsing.parse_header_qemu_img pipes let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr) (path : string) (_size : Int64.t) = @@ -58,7 +69,7 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr) (* If VDI is backed by QCOW, parse the header to determine nonzero clusters to avoid reading all of the raw disk *) - let input_fd = Result.map read_header qcow_path |> Result.to_option in + let input_fds = Result.map read_header qcow_path |> Result.to_option in (* TODO: If VHD headers are to be consulted as well, qcow2-to-stdout needs to properly account for cluster_bits. Currently QCOW2 export @@ -73,9 +84,13 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr) | None -> None in - let diff_fd = Option.map read_header relative_to_qcow_path in + let diff_fds = Option.map read_header relative_to_qcow_path in + + let map_fd_string = Uuidx.(to_string (make ())) in + let info_fd_string = Uuidx.(to_string (make ())) in + let diff_map_fd_string = Uuidx.(to_string (make ())) in + let diff_info_fd_string = Uuidx.(to_string (make ())) in - let unique_string = Uuidx.(to_string (make ())) in let args = [path] @ (match relative_to with None -> [] | Some vdi -> ["--diff"; vdi]) @@ -83,18 +98,46 @@ let send ?relative_to (progress_cb : int -> unit) (unix_fd : Unix.file_descr) | None -> [] | Some _ -> - ["--json-header-diff"; unique_string] + [ + "--json-header-diff-map" + ; diff_map_fd_string + ; "--json-header-diff-info" + ; diff_info_fd_string + ] ) - @ match qcow_path with Error _ -> [] | Ok _ -> ["--json-header"] + @ + match qcow_path with + | Error _ -> + [] + | Ok _ -> + [ + "--json-header-map" + ; map_fd_string + ; "--json-header-info" + ; info_fd_string + ] in let qcow_tool = !Xapi_globs.qcow_to_stdout in - let replace_fds = Option.map (fun fd -> [(unique_string, fd)]) diff_fd in + let replace_fds = + Option.map + (fun (map_fd, info_fd) -> + let rfds = [(map_fd_string, map_fd); (info_fd_string, info_fd)] in + match diff_fds with + | Some (diff_map_fd, diff_info_fd) -> + (diff_map_fd_string, diff_map_fd) + :: (diff_info_fd_string, diff_info_fd) + :: rfds + | None -> + rfds + ) + input_fds + in Xapi_stdext_pervasives.Pervasiveext.finally (fun () -> - Vhd_qcow_parsing.run_tool qcow_tool progress_cb args ?input_fd - ~output_fd:unix_fd ?replace_fds + Vhd_qcow_parsing.run_tool qcow_tool progress_cb args ~output_fd:unix_fd + ?replace_fds ) (fun () -> - Option.iter Unix.close input_fd ; - Option.iter Unix.close diff_fd + Option.iter (fun (x, y) -> Unix.close x ; Unix.close y) input_fds ; + Option.iter (fun (x, y) -> Unix.close x ; Unix.close y) diff_fds ) diff --git a/ocaml/xapi/vhd_qcow_parsing.ml b/ocaml/xapi/vhd_qcow_parsing.ml index 0956b4d8f1d..90ed8a7b288 100644 --- a/ocaml/xapi/vhd_qcow_parsing.ml +++ b/ocaml/xapi/vhd_qcow_parsing.ml @@ -44,11 +44,14 @@ let run_tool tool ?(replace_fds = []) ?input_fd ?output_fd error "%s output: %s" tool out ; raise (Api_errors.Server_error (Api_errors.vdi_io_error, [out])) -let parse_header_aux pipe_reader = +let read_json pipe_reader = let ic = Unix.in_channel_of_descr pipe_reader in let buf = Buffer.create 4096 in let json = Yojson.Basic.from_channel ~buf ~fname:"header.json" ic in - In_channel.close ic ; + In_channel.close ic ; json + +let parse_header_aux pipe_reader = + let json = read_json pipe_reader in let cluster_size = 1 lsl Yojson.Basic.Util.(member "cluster_bits" json |> to_int) in @@ -61,6 +64,31 @@ let parse_header pipe_reader = in (cluster_size, cluster_list) +let parse_header_qemu_img (map_pipe_reader, info_pipe_reader) = + let info_json = read_json info_pipe_reader in + let cluster_size = + Yojson.Basic.Util.(member "cluster-size" info_json |> to_int) + in + let map_json = read_json map_pipe_reader in + let cluster_list = + Yojson.Basic.Util.( + map_json + |> to_list + |> List.filter_map (fun i -> + let present = member "data" i |> to_bool in + if present then + let start_cluster = (member "start" i |> to_int) / cluster_size in + let end_cluster = + start_cluster + ((member "length" i |> to_int) / cluster_size) - 1 + in + Some (start_cluster, end_cluster) + else + None + ) + ) + in + (cluster_size, cluster_list) + let parse_header_interval pipe_reader = let cluster_size, json = parse_header_aux pipe_reader in let cluster_list = diff --git a/ocaml/xapi/vhd_qcow_parsing.mli b/ocaml/xapi/vhd_qcow_parsing.mli index 2df479d921a..f43b56dab51 100644 --- a/ocaml/xapi/vhd_qcow_parsing.mli +++ b/ocaml/xapi/vhd_qcow_parsing.mli @@ -24,3 +24,6 @@ val run_tool : val parse_header : Unix.file_descr -> int * int list val parse_header_interval : Unix.file_descr -> int * (int * int) list + +val parse_header_qemu_img : + Unix.file_descr * Unix.file_descr -> int * (int * int) list diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index c5e5f938838..25c76a64a39 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -841,6 +841,8 @@ let qcow_to_stdout = ref "/opt/xensource/libexec/qcow2-to-stdout.py" let qcow_stream_tool = ref "qcow-stream-tool" +let qemu_img = ref "/usr/lib64/xen/bin/qemu-img" + let fence = ref "fence" let host_bugreport_upload = ref "host-bugreport-upload" @@ -2014,6 +2016,7 @@ module Resources = struct ; ("vhd-tool", vhd_tool, "Path to vhd-tool") ; ("qcow_to_stdout", qcow_to_stdout, "Path to qcow-to-stdout script") ; ("qcow_stream_tool", qcow_stream_tool, "Path to qcow-stream-tool") + ; ("qemu-img", qemu_img, "Path to qemu-img") ; ("fence", fence, "Path to fence binary, used for HA host fencing") ; ( "host-bugreport-upload" , host_bugreport_upload diff --git a/python3/libexec/qcow2-to-stdout.py b/python3/libexec/qcow2-to-stdout.py index 43bcbc402f2..00fee7d2f40 100755 --- a/python3/libexec/qcow2-to-stdout.py +++ b/python3/libexec/qcow2-to-stdout.py @@ -489,18 +489,36 @@ def main(): action="store_true", ) parser.add_argument( - "--json-header", - dest="json_header", - help="stdin contains a JSON of pre-parsed QCOW2 information" - "(virtual_size, data_clusters, cluster_bits)", - action="store_true", + "--json-header-map", + dest="json_header_map", + help="File descriptor that contains a JSON of pre-parsed QCOW2" + "data clusters information for input_file", + type=int, + default=None, ) parser.add_argument( - "--json-header-diff", - dest="json_header_diff", - metavar="json_header_diff", - help="File descriptor that contains a JSON of pre-parsed QCOW2 " - "information for the diff_file_name", + "--json-header-info", + dest="json_header_info", + help="File descriptor that contains a JSON of pre-parsed QCOW2" + "virtual size, cluster size information for input_file", + type=int, + default=None, + ) + parser.add_argument( + "--json-header-diff-map", + dest="json_header_diff_map", + metavar="json_header_diff_map", + help="File descriptor that contains a JSON of pre-parsed QCOW2" + "data clusters for diff_file_name", + type=int, + default=None, + ) + parser.add_argument( + "--json-header-diff-info", + dest="json_header_diff_info", + metavar="json_header_diff_info", + help="File descriptor that contains a JSON of pre-parsed QCOW2" + "virtual size, cluster size information for diff_file_name", type=int, default=None, ) @@ -513,29 +531,31 @@ def main(): nonzero_clusters = None diff_virtual_size = None diff_nonzero_clusters = None - if args.json_header: - json_header = json.load(sys.stdin) - try: - virtual_size = json_header['virtual_size'] - source_cluster_size = 2 ** json_header['cluster_bits'] - if source_cluster_size != args.cluster_size: - args.cluster_size = source_cluster_size - nonzero_clusters = json_header['data_clusters'] - except KeyError as e: - raise RuntimeError(f'Incomplete JSON - missing value for {str(e)}') from e - if args.json_header_diff: - f = os.fdopen(args.json_header_diff) - json_header = json.load(f) + + def parse_json_files(info_fd, map_fd): + map_f = os.fdopen(map_fd) + info_f = os.fdopen(info_fd) + map_json = json.load(map_f) + info_json = json.load(info_f) + try: - diff_virtual_size = json_header['virtual_size'] - if 2 ** json_header['cluster_bits'] == args.cluster_size: - diff_nonzero_clusters = json_header['data_clusters'] + virt_size = info_json['virtual-size'] + cluster_size = info_json['cluster-size'] + if cluster_size == args.cluster_size: + clusters = [ [int(el["start"] / cluster_size), int((el["start"] + el["length"]) / cluster_size) - 1] for el in map_json if el["data"] ] else: sys.exit(f"[Error] Cluster size in the files being compared are " - f"different: {2**json_header['cluster_bits']} vs. {args.cluster_size}") + f"different: {info_json['cluster-size']} vs. {args.cluster_size}") + return virt_size, clusters except KeyError as e: raise RuntimeError(f'Incomplete JSON for the diff - missing value for {str(e)}') from e + + if args.json_header_info and args.json_header_map: + virtual_size, nonzero_clusters = parse_json_files(args.json_header_info, args.json_header_map) + if args.json_header_diff_info and args.json_header_diff_map: + diff_virtual_size, diff_nonzero_clusters = parse_json_files(args.json_header_diff_info, args.json_header_diff_map) + if not os.path.exists(args.input_file): sys.exit(f"[Error] {args.input_file} does not exist.") From 5d8a0762030ea42527a5b664814e8ddb9850ab06 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 4 Feb 2026 13:29:40 +0000 Subject: [PATCH 26/34] qcow-stream-tool: Drop read_headers qemu-img is now used to determine allocated clusters, so this command is no longer needed. Signed-off-by: Andrii Sultanov (cherry picked from commit 829c0188c70156115d8ced022f40f11afa45be79) --- ocaml/qcow-stream-tool/qcow_stream_tool.ml | 52 +--------------------- 1 file changed, 1 insertion(+), 51 deletions(-) diff --git a/ocaml/qcow-stream-tool/qcow_stream_tool.ml b/ocaml/qcow-stream-tool/qcow_stream_tool.ml index b8605c2f44e..6228ec46e88 100644 --- a/ocaml/qcow-stream-tool/qcow_stream_tool.ml +++ b/ocaml/qcow-stream-tool/qcow_stream_tool.ml @@ -4,41 +4,6 @@ module Impl = struct let stream_decode output = Qcow_stream.stream_decode Unix.stdin output ; `Ok () - - let read_headers qcow_path = - let open Lwt.Syntax in - let t = - let* fd = Lwt_unix.openfile qcow_path [Unix.O_RDONLY] 0 in - let* virtual_size, cluster_bits, _, data_cluster_map = - Qcow_stream.start_stream_decode fd - in - (* TODO: List.map becomes tail-recursive in OCaml 5.1, and could be used here instead *) - let clusters = - data_cluster_map - |> Qcow_types.Cluster.Map.to_seq - |> Seq.map (fun (_, virt_address) -> - let ( >> ) = Int64.shift_right_logical in - let address = - Int64.to_int (virt_address >> Int32.to_int cluster_bits) - in - `Int address - ) - |> List.of_seq - in - let json = - `Assoc - [ - ("virtual_size", `Int (Int64.to_int virtual_size)) - ; ("cluster_bits", `Int (Int32.to_int cluster_bits)) - ; ("data_clusters", `List clusters) - ] - in - let json_string = Yojson.to_string json in - let* () = Lwt_io.print json_string in - let* () = Lwt_io.flush Lwt_io.stdout in - Lwt.return_unit - in - Lwt_main.run t ; `Ok () end module Cli = struct @@ -46,10 +11,6 @@ module Cli = struct let doc = Printf.sprintf "Path to the output file." in Arg.(value & pos 0 string default & info [] ~doc) - let input = - let doc = Printf.sprintf "Path to the input file." in - Arg.(required & pos 0 (some string) None & info [] ~doc) - let stream_decode_cmd = let doc = "decode qcow2 formatted data from stdin and write a raw image" in let man = @@ -62,18 +23,7 @@ module Cli = struct (Cmd.info "stream_decode" ~doc ~man) Term.(ret (const Impl.stream_decode $ output "test.raw")) - let read_headers_cmd = - let doc = - "Determine allocated clusters by parsing qcow2 file at the provided \ - path. Returns JSON like the following: {'virtual_size': X, \ - 'cluster_bits': Y, 'data_clusters': [1,2,3]}" - in - let man = [`S "DESCRIPTION"; `P doc] in - Cmd.v - (Cmd.info "read_headers" ~doc ~man) - Term.(ret (const Impl.read_headers $ input)) - - let cmds = [stream_decode_cmd; read_headers_cmd] + let cmds = [stream_decode_cmd] end let info = From 76a81287eaea19be215de064c4546e20273f7f88 Mon Sep 17 00:00:00 2001 From: Sebastien Marie Date: Thu, 28 May 2026 11:41:34 +0200 Subject: [PATCH 27/34] VLAN filtering design document With input from changlei-li, minglumlu, and robhoes Signed-off-by: Sebastien Marie --- doc/content/design/vlan-filtering.md | 188 +++++++++++++++++++++++++++ 1 file changed, 188 insertions(+) create mode 100644 doc/content/design/vlan-filtering.md diff --git a/doc/content/design/vlan-filtering.md b/doc/content/design/vlan-filtering.md new file mode 100644 index 00000000000..fcdd4a1ba9f --- /dev/null +++ b/doc/content/design/vlan-filtering.md @@ -0,0 +1,188 @@ +--- +title: VLAN filtering support +layout: default +design_doc: true +revision: 1 +status: proposed +--- + + +- [Overview](#overview) +- [Use Cases](#use-cases) +- [Changes](#changes) + - [Database schema](#database-schema) + - [API](#api) + - [Behavior change](#behavior-change) +- [Possible designs](#possible-designs) + - [Using VIF](#using-vif) + - [Using Network](#using-network) + - [Using PIF](#using-pif) + - [Using new object](#using-new-object) + - [Conclusion](#conclusion) +- [Glossary](#glossary) + + +## Overview + +VLAN filtering is a Layer 2 network segmentation mechanism that controls how Ethernet frames are forwarded across switch ports based on VLAN membership. +It enables a single physical switching infrastructure to support multiple isolated broadcast domains while maintaining traffic separation and policy enforcement. + +When VLAN filtering is enabled, the switch evaluates incoming frames against configured VLAN rules before allowing traffic to traverse the network. +Frames are sent either tagged (IEEE 802.1Q) or untagged depending on port configuration requirements. + +VLAN filtering is commonly used to isolate network segments, and provides only partial view of a trunk link to VM. + +## Use Cases + +The general use case is providing trunk to some VM in multi-tenants configuration. +For example, having a VM firewall with VLAN trunking but seeing only a subset of the VLANs present on the trunk. + +As examples, the following configurations could be considered, +with one host having a PIF interface with the following VLANs \[10,11,12,13\] on it : + +* VM-A with VIF as trunk port in xenbr0 bridge, `trunks=[]` : VM-A sees all tagged packets so from VLANs 10 to 13 (what we are able to do currently) +* VM-B with VIF as access port in xenbr0 bridge, `tag=10` : VM-B sees untagged packets from VLAN 10 (what we are able to do currently) +* VM-C with VIF as trunk port in xenbr0 bridge, `trunks=[10,11]` : VM-C sees tagged packets from VLANs 10 and 11 +* VM-D with VIF as trunk port in xenbr0 bridge, `trunks=[11,12]` : VM-D sees tagged packets from VLANs 11 and 12 +* VM-E with VIF as trunk port in xenbr0 bridge, `trunks=[10]` : VM-E sees tagged packets from VLAN 10 + +## Changes + +### Database schema + +The *VIF* class would be extended with a new attribute: + +* "trunks" (set int, default to empty): the 802.1Q VLANs that this port trunks (if available) ; if it is empty, then the port trunks all VLANs. + +### API + +This is a new API introduced to manage `trunks` attribute. + +* VIF.add_trunks + * self (ref VIF): reference to a valid VIF; + * value (int): The 802.1Q VLAN which will be associated with the VIF. + +* VIF.remove_trunks + * self (ref VIF): reference to a valid VIF; + * value (int): the 802.1Q VLAN which will be removed from the VIF. + +* VIF.set_trunks + * self (ref VIF): reference to a valid VIF; + * value (set int): The 802.1Q VLANs which will be associated with the VIF. + +### Behavior change + +When a VIF is created, *trunks* attribute on VIF is synchronized to `trunks` attribute on `Port` table in OpenvSwitch. +As the empty list is the current default in OpenvSwitch, +it doesn't introduce changes from current behaviour when default value is used. + +The `trunks` attribute on `Port` table is kept synchronized with *trunks* attribute on VIF during all the lifecycle of the port. + +From : + +> **trunks**: set of up to 4,096 integers, in range 0 to 4,095 +> For a trunk, native-tagged, or native-untagged port, the 802.1Q VLAN or VLANs that this port trunks; +> if it is empty, then the port trunks all VLANs. +> Must be empty if this is an access port. + +The type of the port is defined by `vlan_mode` column on the `Port` table. + +As in XAPI we don't set it, we are using the default mode defined as following: + +> * If tag contains a value, the port is an access port. The trunks column should be empty. +> * Otherwise, the port is a trunk port. The trunks column value is honored if it is present. + +The `tag` in OpenvSwitch is derived from the **PIF's VLAN tag** on the VIF's Network. +For consistency with OpenvSwitch, the `trunks` attribute is so expected to be empty if tag is also set. +In XAPI term it means that a VIF with not empty *trunks* attribute could only be associated to not VLAN Network (Network with PIF with VLAN = -1). + +This introduces a validation constraint preventing incompatible configurations: + +* A VIF with non-empty `trunks` cannot be associated with a Network backed by a VLAN-tagged PIF (`PIF.vLAN` ≠ -1). +* If a VIF is already associated with a Network backed by a VLAN-tagged PIF, its `trunks` attribute must remain empty. +* A VLAN-tagged PIF (`PIF.vLAN` ≠ -1) cannot be associated with a Network that contains a VIF with non-empty `trunks`. + +### Impacts + +#### Update from older version + +All VIFs will get a new *trunks* attribute which will be the default value (empty set). +It doesn't introduce any behavior changes. + +#### VM start + +For each created VIF, the value of *trunks* attribute will be set to `trunks` attribute on OpenvSwitch `Port` table. + +#### VM migration + +If the VM is migrated, the `trunks` attribute on OpenvSwitch `Port` table on the new host is keep in synchronization with the value of *trunks* attribute. + +#### VIF attribute changes + +On *trunks* attribute change, the value will be set to `trunks` attribute on OpenvSwitch `Port` table. +The change is effective immediately and transparently (without replugging the VIF). + + +## Possible designs + +The proposed design was chosen after considering the following elements. +They are taken up here to present the possible options and reasons for choosing to use VIF. + +### Using VIF + +* **pros** + * simplest implementation path : only a new attribute on VIF to synchronize with OpenvSwitch `Port` configuration + * per-VIF granularity is a feature here : each VM gets its own filtered view, matching the multi-tenant use case + * no need to change existing XAPI invariants (one PIF, one Network, see below) + * the attribute lives on the object that actually needs the filter — no scaffolding objects required +* **cons** + * doesn't reuse XAPI's existing VLAN model (VLAN -> tagged PIF -> Network chain), so the concept is somewhat duplicated + * configuration is scoped to a single VIF : sharing the same trunk policy across multiple VIFs would require manual duplication + * visibility is more limited than a dedicated Network : admins looking at network-level configuration won't immediately see which VLANs are being filtered + +### Using Network + +* **pros** + * natural scoping : the trunk policy would be easily discoverable + * consistent with how other per-network settings (MTU, locking mode, etc.) are already attached +* **cons** + * a single PIF would need to be a member of several Networks simultaneously, which is conceptually problematic (a PIF normally belongs to exactly one Network) + * would require rethinking or relaxing the "one PIF, one Network" invariant in XAPI + +### Using PIF + +* **pros** + * PIF already has a VLAN-aware model via `vlan-slave-of` (the set of VLANs attached to that PIF) + * could express the "filtered view of available VLANs" at the physical interface level +* **cons** + * we would need several PIF backends on the same physical device (one PIF per trunk view), which contradicts the one-backing-device model + * does not fit well with VLAN tagging or bonding on top of the PIF ; would need additional restrictions (e.g. blocking VLAN or Bond creation on a PIF that already has trunked views) + +### Using new object + +* **pros** + * clean semantic : a dedicated object expresses "a PIF + a subset of VLANs" without overloading existing entities + * could naturally group multiple VIFs under the same trunk policy (like a Network does) +* **cons** + * seems overkill for the use case : adds a new object type, new API surface, and new lifecycle concerns + * would force creating a VLAN PIF / Network for each trunk subset, adding scaffolding noise for what is essentially a per-VIF filter + +### Conclusion + +It was chosen to put `trunks` attribute on VIF as: + +* it is simple design solution +* an installation usage trunks will not have many VIFs sharing the same configuration + +The well suited alternative would be to create a new object (like VLAN or Bond) for holding the trunk information, but it seems overkill for the purpose. + +Other alternatives would need more changes in current XAPI invariants. + +## Glossary + +* **VLAN (Virtual LAN)** : A logical subdivision of a physical network that isolates traffic at Layer 2. VLANs are identified by a 12-bit ID (range 0–4095). +* **VLAN tag** : A 4-byte field inserted into an Ethernet frame by the switch, containing a 12-bit VLAN ID (0–4095). +* **802.1Q** : IEEE standard defining a system of VLAN tagging for Ethernet frames — adds a VLAN identifier to Ethernet frames to segregate traffic at Layer 2. +* **Access port** : An OVS port type that carries traffic for a single VLAN. The `trunks` column must be empty; the `tag` column specifies the VLAN. Packets are untagged. +* **Trunk port** : An OVS port type that carries traffic for multiple VLANs. The `trunks` column specifies which VLANs are allowed; if empty, all VLANs are allowed. Packets are tagged. +* **Trunk link** : A physical or virtual link that carries traffic for multiple VLANs simultaneously. Packets are tagged. From 68ae36705dbe5ef26fe8c8432235fcc7a85e15cc Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Wed, 3 Jun 2026 10:52:45 +0000 Subject: [PATCH 28/34] xapi_pci: Disallow passthrough for boot devices It is currently possible to accidentally pass through a PCI device backing the boot drive, making the system unbootable and requiring manual intervention (since dom0 will no longer be able to access the PCI device). Fix this at least for the drive behind '/', refusing to pass through its PCI device. As an example, for 00:1f.2 SATA controller behind '/': $ /usr/bin/findmnt -no source / /dev/sda1 $ udevadm info -q path -n /dev/sda1 /devices/pci0000:00/0000:00:1f.2/ata5/host4/target4:0:0/4:0:0:0/block/sda/sda1 Disabling dom0 access before this commit: $ xe pci-disable-dom0-access uuid=$UUID disable_on_reboot $ /opt/xensource/libexec/xen-cmdline --get-dom0 xen-pciback.hide xen-pciback.hide=(0000:00:1f.2) After: $ xe pci-disable-dom0-access uuid=$UUID Passing through a PCI device backing a boot disk is disallowed device: /dev/sda1 $ /opt/xensource/libexec/xen-cmdline --get-dom0 xen-pciback.hide Signed-off-by: Andrii Sultanov --- ocaml/idl/datamodel_errors.ml | 3 +++ ocaml/xapi-consts/api_errors.ml | 3 +++ ocaml/xapi/xapi_pci.ml | 9 ++++++++- ocaml/xapi/xapi_pci_helpers.ml | 21 +++++++++++++++++++++ 4 files changed, 35 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index b334b00181a..47838c527a8 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -459,6 +459,9 @@ let _ = error Api_errors.nvidia_sriov_misconfigured ["host"; "device_name"] ~doc:"The NVidia GPU is not configured for SR-IOV as expected" () ; + error Api_errors.boot_device_passthrough_disallowed ["device"] + ~doc:"Passing through a PCI device backing a boot disk is disallowed" () ; + error Api_errors.openvswitch_not_active [] ~doc: "This operation needs the OpenVSwitch networking backend to be enabled \ diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 026faadbbd6..617302c2301 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1462,3 +1462,6 @@ let not_allowed_when_ntp_is_enabled = let not_trusted_certificate = add_error "NOT_TRUSTED_CERTIFICATE" let certificate_lacks_purpose = add_error "CERTIFICATE_LACKS_PURPOSE" + +let boot_device_passthrough_disallowed = + add_error "BOOT_DEVICE_PASSTHROUGH_DISALLOWED" diff --git a/ocaml/xapi/xapi_pci.ml b/ocaml/xapi/xapi_pci.ml index 33f286e621b..6d21db8c770 100644 --- a/ocaml/xapi/xapi_pci.ml +++ b/ocaml/xapi/xapi_pci.ml @@ -323,7 +323,14 @@ let get_system_display_device () = with _ -> None let disable_dom0_access ~__context ~self = - Xapi_pci_helpers.update_dom0_access ~__context ~self ~action:`disable + (* Disallow passing through a dom0 boot device *) + let pci_id = Db.PCI.get_pci_id ~__context ~self in + match Xapi_pci_helpers.find_boot_device () with + | Some (boot_device, path) when pci_id = boot_device -> + raise + Api_errors.(Server_error (boot_device_passthrough_disallowed, [path])) + | _ -> + Xapi_pci_helpers.update_dom0_access ~__context ~self ~action:`disable let enable_dom0_access ~__context ~self = Xapi_pci_helpers.update_dom0_access ~__context ~self ~action:`enable diff --git a/ocaml/xapi/xapi_pci_helpers.ml b/ocaml/xapi/xapi_pci_helpers.ml index 4e7009e2bdb..e86928a491d 100644 --- a/ocaml/xapi/xapi_pci_helpers.ml +++ b/ocaml/xapi/xapi_pci_helpers.ml @@ -240,3 +240,24 @@ let update_dom0_access ~__context ~self ~action = pgpus ; new_access + +let find_boot_device () = + try + let open Forkhelpers in + let source_device, _ = + execute_command_get_output "/usr/bin/findmnt" ["-no"; "source"; "/"] + in + let source_device = String.trim source_device in + let path, _ = + execute_command_get_output !Xapi_globs.udevadm + ["info"; "-q"; "path"; "-n"; source_device] + in + match String.split_on_char '/' path with + | _ :: _ :: _ :: dev :: _ -> + Some (dev, source_device) + | _ -> + None + with e -> + warn "Couldn't find the PCI device behind the root drive: %s" + (Printexc.to_string e) ; + None From 326e32268e8eda925e9954c80051c16422b19e83 Mon Sep 17 00:00:00 2001 From: Lucas RAVAGNIER Date: Wed, 3 Jun 2026 12:11:35 +0200 Subject: [PATCH 29/34] xapi: Improve error reporting when pool join fails on TLS verification When a host joins a pool (pool.join_force), the process has two phases: 1. An unverified TLS connection is used to run pre-join checks and exchange host certificates. The joiner imports the pool bundle. 2. A verified TLS connection (verifyPeer=yes, SNI=pool) is opened using the freshly-generated pool bundle. Previously, any failure at Phase 2 surfaced as: INTERNAL_ERROR(Stunnel.Stunnel_verify_error( This error is opaque and gives no actionable information to the administrator. The idea is to improve error handling in order to obtain something more precise. Signed-off-by: Lucas RAVAGNIER --- ocaml/idl/datamodel_errors.ml | 19 +++++++++++++++++++ ocaml/xapi-consts/api_errors.ml | 6 ++++++ ocaml/xapi/cert_distrib.ml | 24 +++++++++++++++++++++++- ocaml/xapi/xapi_pool.ml | 22 ++++++++++++++++++++++ 4 files changed, 70 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index b334b00181a..5ad5ee3618e 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -904,6 +904,25 @@ let _ = "The host joining the pool must have one and only one IP on the \ clustering network" () ; + error Api_errors.pool_joining_host_tls_verification_mismatch [] + ~doc: + "The TLS verification check failed when the joining host attempted to \ + open a verified connection to the pool coordinator using the imported \ + pool certificate bundle." + () ; + error Api_errors.pool_joining_master_certificate_not_in_pool_bundle + ["master_uuid"] + ~doc: + "The pool coordinator's own certificate is absent from the pool \ + certificate bundle sent to the joining host. Run 'xe \ + pool-certificate-sync' on the coordinator and retry." + () ; + error Api_errors.pool_joining_pool_bundle_empty_after_import ["bundle_path"] + ~doc: + "The pool certificate bundle is empty or missing after import on the \ + joining host. The bundle generation script (update-ca-bundle.sh) likely \ + failed silently." + () ; (* External directory service *) error Api_errors.subject_cannot_be_resolved [] diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 026faadbbd6..270f7f05924 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -748,6 +748,12 @@ let pool_joining_host_has_network_sriovs = let pool_joining_host_tls_verification_mismatch = add_error "POOL_JOINING_HOST_TLS_VERIFICATION_MISMATCH" +let pool_joining_master_certificate_not_in_pool_bundle = + add_error "POOL_JOINING_MASTER_CERTIFICATE_NOT_IN_POOL_BUNDLE" + +let pool_joining_pool_bundle_empty_after_import = + add_error "POOL_JOINING_POOL_BUNDLE_EMPTY_AFTER_IMPORT" + let pool_joining_host_ca_certificates_conflict = add_error "POOL_JOINING_HOST_CA_CERTIFICATES_CONFLICT" diff --git a/ocaml/xapi/cert_distrib.ml b/ocaml/xapi/cert_distrib.ml index b5f9f923b29..4d3891dffb3 100644 --- a/ocaml/xapi/cert_distrib.ml +++ b/ocaml/xapi/cert_distrib.ml @@ -704,7 +704,29 @@ let exchange_certificates_with_joiner ~__context ~uuid ~certificate = let import_joining_pool_certs ~__context ~pool_certs = let pool_certs = List.map WireProtocol.certificate_file_of_pair pool_certs in Worker.local_write_cert_fs ~__context HostPoolCert Merge pool_certs ; - Worker.local_regen_bundle ~__context + Worker.local_regen_bundle ~__context ; + (* update-ca-bundle.sh can fail silently, leaving an empty bundle that would + cause an opaque Stunnel_verify_error when the verified connection is + opened in Phase 2 of the join. *) + let bundle_path = !Xapi_globs.pool_bundle_path in + let bundle_empty_or_missing = + match Unix.stat bundle_path with + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> + true + | stats -> + stats.Unix.st_size = 0 + in + if bundle_empty_or_missing then ( + D.error + "import_joining_pool_certs: pool bundle '%s' is empty or missing after \ + certificate import. The bundle generation script \ + (/opt/xensource/bin/update-ca-bundle.sh) likely failed silently." + bundle_path ; + raise + Api_errors.( + Server_error (pool_joining_pool_bundle_empty_after_import, [bundle_path]) + ) + ) let collect_ca_certs ~__context ~names = Worker.local_collect_certs LegacyRootCert ~__context names diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 8ac3b31a8d8..cdd1eec2173 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -1871,6 +1871,28 @@ let join_common ~__context ~master_address ~master_username ~master_password Client.Pool.exchange_certificates_on_join ~rpc:unverified_rpc ~session_id ~uuid:my_uuid ~certificate:my_certificate in + (* Verify the master included its own certificate in the pool bundle + before importing. If it is absent the verified connection in Phase 2 + will fail with an opaque Stunnel_verify_error. The filename convention + is ".pem" (see Cert_distrib.HostPoolProvider). *) + let master_uuid = + Client.Host.get_uuid ~rpc:unverified_rpc ~session_id + ~self:(get_master ~rpc:unverified_rpc ~session_id) + in + let expected_cert_filename = master_uuid ^ ".pem" in + if not (List.mem_assoc expected_cert_filename pool_certs) then ( + error + "join_common: master certificate file '%s' is absent from the pool's \ + certificate store (/etc/stunnel/certs-pool/). The pool bundle sent \ + to the joiner does not contain the master's own certificate. Run \ + 'xe pool-certificate-sync' on the master and retry." + expected_cert_filename ; + raise + Api_errors.( + Server_error + (pool_joining_master_certificate_not_in_pool_bundle, [master_uuid]) + ) + ) ; Cert_distrib.import_joining_pool_certs ~__context ~pool_certs ) (fun () -> Client.Session.logout ~rpc:unverified_rpc ~session_id) ; From 6b0b2b167eab79eb9f907c06d6db6c6b946faf0a Mon Sep 17 00:00:00 2001 From: Mark Syms Date: Fri, 5 Jun 2026 10:35:45 +0100 Subject: [PATCH 30/34] Make use of losetup conditional on file type Use non-deprecated list operation instead of -a Signed-off-by: Mark Syms --- .../datapath/loop+blkback/datapath.py | 86 +++++++++++-------- .../volume.py | 10 +-- 2 files changed, 57 insertions(+), 39 deletions(-) diff --git a/ocaml/xapi-storage/python/examples/datapath/loop+blkback/datapath.py b/ocaml/xapi-storage/python/examples/datapath/loop+blkback/datapath.py index 10b1959e05c..796d0caf4e6 100755 --- a/ocaml/xapi-storage/python/examples/datapath/loop+blkback/datapath.py +++ b/ocaml/xapi-storage/python/examples/datapath/loop+blkback/datapath.py @@ -2,13 +2,13 @@ # # Copyright (C) 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 +# 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. # -# 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 +# 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. # # You should have received a copy of the GNU Lesser General Public License @@ -17,6 +17,7 @@ import os +import stat import sys import urllib.parse @@ -24,41 +25,65 @@ from xapi.storage.common import call from xapi.storage import log -class Loop(object): + +class BlockDevice: + + def __init__(self, dev): + self.dev = dev + + def destroy(self, dbg): + call(dbg, ["losetup", "-d", self.dev]) + + def block_device(self): + return self.dev + + +class Loop(BlockDevice): """An active loop device""" def __init__(self, path, loop): self.path = path - self.loop = loop + super().__init__(loop) def destroy(self, dbg): - call(dbg, ["losetup", "-d", self.loop]) + call(dbg, ["losetup", "-d", self.block_device()]) - def block_device(self): - return self.loop + @staticmethod + def create_loop_device(dbg, target_path, query): + cmd = ['losetup', '--show', '-f', target_path] + if 'size' in query: + cmd.extend(['--sizelimit', query['size'][0]]) + stdout = call(dbg, cmd) + if stdout == '': + return None + + return Loop(target_path, stdout.decode().strip()) @staticmethod - def from_path(dbg, path): + def from_path(dbg, path, query): path = os.path.realpath(path) - for line in call(dbg, ["losetup", "-a"]).split("\n"): - line = line.strip() + for line in call(dbg, ["losetup", "-n", '--list']).splitlines(): + line = line.strip().decode() if line != "": bits = line.split() - loop = bits[0][0:-1] - open_bracket = line.find('(') - close_bracket = line.find(')') - this_path = line[open_bracket + 1:close_bracket] + loop = bits[0] + this_path = bits[5] if this_path == path: return Loop(path, loop) - return None + return Loop.create_loop_device(dbg, path, query) class Implementation(xapi.storage.api.v5.datapath.Datapath_skeleton): """ Datapath implementation """ - def _find_loop(self, path): - path = os.path.realpath(path) + def get_provider(self, dbg, target_path, query): + statinfo = os.stat(target_path) + + if stat.S_ISBLK(statinfo.st_mode): + return BlockDevice(target_path) + + return Loop.from_path(dbg, target_path, query) def activate(self, dbg, uri, domain): pass @@ -67,30 +92,23 @@ def attach(self, dbg, uri, domain): parsed_url = urllib.parse.urlparse(uri) query = urllib.parse.parse_qs(parsed_url.query) - file_path = os.path.realpath(parsed_url.path) - - cmd = ['losetup', '-f', file_path] - if 'size' in query: - cmd.extend(['--sizelimit', query['size'][0]]) - call(dbg, cmd) + target_path = os.path.realpath(parsed_url.path) - loop = Loop.from_path(dbg, file_path) - if not loop: - return {} + provider = self.get_provider(dbg, target_path, query) return {"implementations": [ [ "XenDisk", { "backend_type": "vbd", - "params": loop.block_device(), + "params": provider.block_device(), "extra": {} } ], [ "BlockDevice", { - "path": loop.block_device() + "path": provider.block_device() } ] ]} @@ -106,10 +124,10 @@ def detach(self, dbg, uri, domain): if not(os.path.exists(file_path)): raise xapi.storage.api.volume.Volume_does_not_exist(file_path) - loop = Loop.from_path(dbg, file_path) - loop.destroy(dbg) + provider = self.get_provider(dbg, file_path, {}) + provider.destroy(dbg) - def open(self, dbg, uri, domain): + def open(self, dbg, uri, persistent): pass def close(self, dbg, uri): diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py index 6593a8fd536..96aec998c10 100755 --- a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py @@ -2,13 +2,13 @@ # # Copyright (C) Cloud Software Group, 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 +# 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. # -# 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 +# 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. # # You should have received a copy of the GNU Lesser General Public License From a73e1d69cafefc0b5b4393c3606928f50ec31dda Mon Sep 17 00:00:00 2001 From: Mark Syms Date: Fri, 5 Jun 2026 10:36:57 +0100 Subject: [PATCH 31/34] Rename to blktap Signed-off-by: Mark Syms --- .../{loop+blkback => blkback}/datapath.py | 0 .../{loop+blkback => blkback}/plugin.py | 21 ++++++++++--------- .../volume.py | 2 +- 3 files changed, 12 insertions(+), 11 deletions(-) rename ocaml/xapi-storage/python/examples/datapath/{loop+blkback => blkback}/datapath.py (100%) rename ocaml/xapi-storage/python/examples/datapath/{loop+blkback => blkback}/plugin.py (82%) diff --git a/ocaml/xapi-storage/python/examples/datapath/loop+blkback/datapath.py b/ocaml/xapi-storage/python/examples/datapath/blkback/datapath.py similarity index 100% rename from ocaml/xapi-storage/python/examples/datapath/loop+blkback/datapath.py rename to ocaml/xapi-storage/python/examples/datapath/blkback/datapath.py diff --git a/ocaml/xapi-storage/python/examples/datapath/loop+blkback/plugin.py b/ocaml/xapi-storage/python/examples/datapath/blkback/plugin.py similarity index 82% rename from ocaml/xapi-storage/python/examples/datapath/loop+blkback/plugin.py rename to ocaml/xapi-storage/python/examples/datapath/blkback/plugin.py index 4cbc9939fbd..819e065c81a 100755 --- a/ocaml/xapi-storage/python/examples/datapath/loop+blkback/plugin.py +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/plugin.py @@ -2,13 +2,13 @@ # # Copyright (C) Cloud Software Group,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 +# 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. # -# 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 +# 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. # # You should have received a copy of the GNU Lesser General Public License @@ -26,13 +26,14 @@ class Implementation(xapi.storage.api.v5.plugin.Plugin_skeleton): def query(self, dbg): return { - "plugin": "loop+blkback", - "name": "Sample loop + blkback datapath", + "plugin": "blkback", + "name": "Sample blkback datapath", "description": ("This plugin is an example using " - "loop devices (from losetup) and " - "blkback to create virtual block devices"), + "blkback to create virtual block devices. " + "If required losetup will be used to " + "create a loop device for a file"), "vendor": "Citrix", - "copyright": "(C) 2019 Citrix Inc", + "copyright": "(C) 2019-2026 Citrix Inc", "version": "3.0", "required_api_version": "5.0", "features": [], diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py index 96aec998c10..acc9ff719c9 100755 --- a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py @@ -53,7 +53,7 @@ def create_volume_data(self, name, description, size, uris, uuid): def volume_uris(self, sr_path, name, size): query = urllib.parse.urlencode({'size': size}, True) return [urllib.parse.urlunparse( - ('loop+blkback', None, os.path.join(sr_path, name), + ('blkback', None, os.path.join(sr_path, name), None, query, None))] def create(self, dbg, sr, name, description, size, sharable): From ee29922bf6caee38565192c9a6ab149d7eb205da Mon Sep 17 00:00:00 2001 From: Mark Syms Date: Fri, 5 Jun 2026 10:55:11 +0100 Subject: [PATCH 32/34] Add operation symlinks Also rename some volume methods that should be internal so that the invalid command handler works as expected. Signed-off-by: Mark Syms --- .../datapath/blkback/Datapath.activate | 1 + .../examples/datapath/blkback/Datapath.attach | 1 + .../examples/datapath/blkback/Datapath.close | 1 + .../datapath/blkback/Datapath.deactivate | 1 + .../examples/datapath/blkback/Datapath.detach | 1 + .../examples/datapath/blkback/Datapath.open | 1 + .../examples/datapath/blkback/Plugin.Query | 1 + .../Plugin.Query | 1 + .../Plugin.diagnostics | 1 + .../SR.attach | 1 + .../SR.create | 1 + .../SR.destroy | 1 + .../SR.detach | 1 + .../org.xen.xapi.storage.simple-file/SR.ls | 1 + .../org.xen.xapi.storage.simple-file/SR.stat | 1 + .../Volume.create | 1 + .../Volume.destroy | 1 + .../Volume.resize | 1 + .../Volume.set_description | 1 + .../Volume.set_name | 1 + .../Volume.stat | 1 + .../volume.py | 26 +++++++++---------- 22 files changed, 34 insertions(+), 13 deletions(-) create mode 120000 ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.activate create mode 120000 ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.attach create mode 120000 ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.close create mode 120000 ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.deactivate create mode 120000 ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.detach create mode 120000 ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.open create mode 120000 ocaml/xapi-storage/python/examples/datapath/blkback/Plugin.Query create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.Query create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.diagnostics create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.attach create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.create create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.destroy create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.detach create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.ls create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.stat create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.create create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.destroy create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.resize create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_description create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_name create mode 120000 ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.stat diff --git a/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.activate b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.activate new file mode 120000 index 00000000000..49314e40d21 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.activate @@ -0,0 +1 @@ +datapath.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.attach b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.attach new file mode 120000 index 00000000000..49314e40d21 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.attach @@ -0,0 +1 @@ +datapath.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.close b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.close new file mode 120000 index 00000000000..49314e40d21 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.close @@ -0,0 +1 @@ +datapath.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.deactivate b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.deactivate new file mode 120000 index 00000000000..49314e40d21 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.deactivate @@ -0,0 +1 @@ +datapath.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.detach b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.detach new file mode 120000 index 00000000000..49314e40d21 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.detach @@ -0,0 +1 @@ +datapath.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.open b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.open new file mode 120000 index 00000000000..49314e40d21 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/Datapath.open @@ -0,0 +1 @@ +datapath.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/datapath/blkback/Plugin.Query b/ocaml/xapi-storage/python/examples/datapath/blkback/Plugin.Query new file mode 120000 index 00000000000..96bd1391c0e --- /dev/null +++ b/ocaml/xapi-storage/python/examples/datapath/blkback/Plugin.Query @@ -0,0 +1 @@ +plugin.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.Query b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.Query new file mode 120000 index 00000000000..96bd1391c0e --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.Query @@ -0,0 +1 @@ +plugin.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.diagnostics b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.diagnostics new file mode 120000 index 00000000000..96bd1391c0e --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Plugin.diagnostics @@ -0,0 +1 @@ +plugin.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.attach b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.attach new file mode 120000 index 00000000000..482eaaf76a5 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.attach @@ -0,0 +1 @@ +sr.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.create b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.create new file mode 120000 index 00000000000..482eaaf76a5 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.create @@ -0,0 +1 @@ +sr.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.destroy b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.destroy new file mode 120000 index 00000000000..482eaaf76a5 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.destroy @@ -0,0 +1 @@ +sr.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.detach b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.detach new file mode 120000 index 00000000000..482eaaf76a5 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.detach @@ -0,0 +1 @@ +sr.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.ls b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.ls new file mode 120000 index 00000000000..482eaaf76a5 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.ls @@ -0,0 +1 @@ +sr.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.stat b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.stat new file mode 120000 index 00000000000..482eaaf76a5 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/SR.stat @@ -0,0 +1 @@ +sr.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.create b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.create new file mode 120000 index 00000000000..1d6acb7b332 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.create @@ -0,0 +1 @@ +volume.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.destroy b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.destroy new file mode 120000 index 00000000000..1d6acb7b332 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.destroy @@ -0,0 +1 @@ +volume.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.resize b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.resize new file mode 120000 index 00000000000..1d6acb7b332 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.resize @@ -0,0 +1 @@ +volume.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_description b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_description new file mode 120000 index 00000000000..1d6acb7b332 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_description @@ -0,0 +1 @@ +volume.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_name b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_name new file mode 120000 index 00000000000..1d6acb7b332 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.set_name @@ -0,0 +1 @@ +volume.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.stat b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.stat new file mode 120000 index 00000000000..1d6acb7b332 --- /dev/null +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/Volume.stat @@ -0,0 +1 @@ +volume.py \ No newline at end of file diff --git a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py index acc9ff719c9..8eac6b7f9a6 100755 --- a/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py +++ b/ocaml/xapi-storage/python/examples/volume/org.xen.xapi.storage.simple-file/volume.py @@ -31,12 +31,12 @@ class Implementation(xapi.storage.api.v5.volume.Volume_skeleton): - def parse_sr(self, sr_uri): + def _parse_sr(self, sr_uri): parsed_url = urllib.parse.urlparse(sr_uri) config = urllib.parse.parse_qs(parsed_url.query) return parsed_url, config - def create_volume_data(self, name, description, size, uris, uuid): + def _create_volume_data(self, name, description, size, uris, uuid): return { 'uuid': uuid, 'key': uuid, @@ -50,7 +50,7 @@ def create_volume_data(self, name, description, size, uris, uuid): 'sharable': False } - def volume_uris(self, sr_path, name, size): + def _volume_uris(self, sr_path, name, size): query = urllib.parse.urlencode({'size': size}, True) return [urllib.parse.urlunparse( ('blkback', None, os.path.join(sr_path, name), @@ -66,7 +66,7 @@ def create(self, dbg, sr, name, description, size, sharable): # No support for shareable mulit-access volumes in this SR assert(not sharable) - parsed_url, config = self.parse_sr(sr) + parsed_url, config = self._parse_sr(sr) volume_uuid = str(uuid.uuid4()) file_path = os.path.join(parsed_url.path, volume_uuid) @@ -82,16 +82,16 @@ def create(self, dbg, sr, name, description, size, sharable): } json.dump(meta, json_f) - return self.create_volume_data( + return self._create_volume_data( name, description, - size, self.volume_uris(parsed_url.path, name, size), + size, self._volume_uris(parsed_url.path, name, size), volume_uuid) def destroy(self, dbg, sr, key): """ [destroy sr volume] removes [volume] from [sr] """ - parsed_url, config = self.parse_sr(sr) + parsed_url, config = self._parse_sr(sr) file_path = os.path.join(parsed_url.path, key) @@ -104,18 +104,18 @@ def _stat_volume(self, sr_path, volume_id): with open(file_path + '.inf', 'r') as json_f: meta = json.load(json_f) - return self.create_volume_data( + return self._create_volume_data( meta['name'], meta['description'], meta['size'], - self.volume_uris(sr_path, volume_id, meta['size']), + self._volume_uris(sr_path, volume_id, meta['size']), volume_id) def stat(self, dbg, sr, key): """ [stat sr volume] returns metadata associated with [volume]. """ - parsed_url, config = self.parse_sr(sr) + parsed_url, config = self._parse_sr(sr) sr_path = parsed_url.path return self._stat_volume(sr_path, key) @@ -123,7 +123,7 @@ def set_name(self, dbg, sr, key, new_name): """ [set_name sr key new_name] changes the name of [volume] """ - parsed_url, config = self.parse_sr(sr) + parsed_url, config = self._parse_sr(sr) file_path = os.path.join(parsed_url.path, key) @@ -139,7 +139,7 @@ def set_description(self, dbg, sr, key, new_description): """ [set_description sr key new_name] changes the description of [volume] """ - parsed_url, config = self.parse_sr(sr) + parsed_url, config = self._parse_sr(sr) file_path = os.path.join(parsed_url.path, key) @@ -164,7 +164,7 @@ def resize(self, dbg, sr, key, new_size): [resize sr volume new_size] enlarges [volume] to be at least [new_size]. """ - parsed_url, config = self.parse_sr(sr) + parsed_url, config = self._parse_sr(sr) file_path = os.path.join(parsed_url.path, key) From 4d73459c1d0dcbd08eed522a40b78f6a5558b649 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 29 May 2026 17:30:31 +0800 Subject: [PATCH 33/34] [design doc] LLDP support Signed-off-by: Ming Lu --- doc/content/design/lldp.md | 233 +++++++++++++++++++++++++++++++++++++ 1 file changed, 233 insertions(+) create mode 100644 doc/content/design/lldp.md diff --git a/doc/content/design/lldp.md b/doc/content/design/lldp.md new file mode 100644 index 00000000000..043eade6b1f --- /dev/null +++ b/doc/content/design/lldp.md @@ -0,0 +1,233 @@ +--- +title: LLDP support +layout: default +design_doc: true +revision: 1 +status: draft +--- + +## Overview + +[LLDP](https://en.wikipedia.org/wiki/Link_Layer_Discovery_Protocol) is a link-layer discovery protocol used by network devices to advertise their identity, capabilities, and neighbor information on a local network. +This design adds supported LLDP capability to XAPI and networkd so that a host can advertise its identity and selected system information to directly connected switches, and can also retrieve selected LLDP neighbor information from those switches. +The primary use case is host-to-switch verification. + +The following are introduced by this design: + +- pool-wide and per-PIF LLDP configuration through XenAPI +- LLDP advertisement on physical NICs +- retrieval of selected received LLDP neighbor fields through `PIF_metrics` +- protection against enabling LLDP by default on NIC drivers known to conflict with storage-related functionality + +The implementation uses XAPI for configuration, networkd for per-host application of configuration, and [`lldpd`](https://github.com/lldpd/lldpd) as the LLDP agent in dom0 user space. +XAPI stores LLDP configuration in the database and exposes LLDP neighbor data through XenAPI. +networkd configures the LLDP agent to apply LLDP configuration for individual physical NICs and queries the LLDP agent for received LLDP TLVs. +`lldpd` runs as a daemon process in dom0 user space. It receives and sends LLDPDUs via PF_PACKET + SOCK_RAW sockets. It is actively maintained by upstream as the time being. + +## XAPI database changes + +The following fields are added to the XAPI database. + +### `pool.lldp_enabled` + +Type: `bool` + +When `true`, LLDP is enabled on the NIC associated with each managed physical PIF on every host in the pool. +When `false`, LLDP is disabled on the NIC associated with each managed physical PIF on every host in the pool. + +This setting does not apply to other types of PIFs, such as non-managed PIFs, bond PIFs, VLAN PIFs, tunnel PIFs, or SR-IOV PIFs. + +`PIF.lldp_mode` determines the final effective state on individul PIF. + +LLDP receiving and advertising are always enabled or disabled together. + +Default after update/RPU from a version/release without LLDP support to a version/release with LLDP support: `false` + +Default after fresh install: `true` + +### `PIF.lldp_mode` + +Type: `enum pif_lldp_mode` + +Values: + +- `default`: follow `pool.lldp_enabled`; +- `enabled`: LLDP is enabled on the NIC associated with the managed physical PIF; +- `disabled`: LLDP is disabled on the NIC associated with the managed physical PIF. + +This setting does not apply to other types of PIFs, such as non-managed PIFs, bond PIFs, VLAN PIFs, tunnel PIFs, or SR-IOV PIFs. + +Default after update/RPU from a version/release without LLDP support to a version/release with LLDP support: `default`. + +Default after fresh install: `default`. + +### `pool.lldp_multicast_address` + +Type: `enum lldp_multicast_address` + +Values: + +- `nearestbridge`: `01:80:C2:00:00:0E` +- `nearestnontpmrbridge`: `01:80:C2:00:00:03` +- `nearestcustomerbridge`: `01:80:C2:00:00:00` + +This value controls the multicast MAC address used for LLDP transmission. +After a change, it is applied when `pool.set_lldp_enabled` or `PIF.set_lldp_mode` is called with `force=true`. +This value is not considered to change often. Changing it does not trigger any application action for simplicity. + +Default after update/RPU from a version/release without LLDP support to a version/release with LLDP support: `nearestbridge`. + +Default after fresh install: `nearestbridge`. + +### `PIF_metrics.lldp_neighbor` + +Type: `map(string, string)` + +Stores the received LLDP TLVs from the corresponding PIF. + +Default: empty + +## XenAPI changes + +The following new APIs are added. + +### `pool.set_lldp_enabled` + +Parameters: + +- `self`: the pool reference; +- `value`: `true` or `false`; +- `force`: `bool`, default `false`. + +Behavior: + +- if `force=false` and `value = pool.lldp_enabled`, do nothing; +- otherwise, set `pool.lldp_enabled` to `value`, apply LLDP configuration to every physical PIF in the pool by calling `PIF.plug` to each host; +- return a map of failed PIFs and error strings. + +### `PIF.set_lldp_mode` + +Parameters: + +- `self`: the PIF reference; +- `value`: `default`, `enabled`, or `disabled`; +- `force`: `bool`, default `false`. + +Behavior: + +- if `force=false` and `value= PIF.lldp_mode`, do nothing; +- otherwise set `PIF.lldp_mode` to `value`, apply LLDP configuration to the physical NIC represented by the PIF by calling `PIF.plug` to the host. + + +## The networkd database + +The `interface_config_t` record in the networkd database is extended with LLDP configuration. networkd can configure LLDP independently using its own database when XAPI is unavailable, for example during host boot. +The default enabled setting is `false` to minimize impact without high-level configuration from XAPI or the user. This database can be updated as XAPI pushes configurtions to networkd through networkd calls. + +```ocaml +type lldp_multicast_address = + | Nearestbridge + | Nearestnontpmrbridge + | Nearestcustomerbridge +[@@deriving rpcty] + +type lldp = { + enabled: bool [@default false]; + address: lldp_multicast_address list [@default [Nearestbridge]]; +} +[@@deriving rpcty] + +type interface_config_t = { + ... + lldp: lldp option [@default None]; +} +``` + +## Safety + +Some NICs share hardware with storage functions such as CNA and hardware FCoE. Enabling LLDP on these NICs may affect those storage functions. +This is especially important when the storage function provides the boot disk of a host. +For safety, LLDP is disabled by default on NICs which are managed by drivers in a known blocking list when enablement comes from the pool-level default. +Users may still enable LLDP on such NICs through per-PIF XenAPI after confirming that it is safe in practice. +The blocking mechanism is based on the NIC driver. Other approaches, such as PCI bus/device location or PCI device ID, are either unreliable or too complex. + +### Blocking list + +networkd uses a per-host NIC-driver blocking list which is persisted under files under `/etc/xensource/lldp-nic-driver-blocklist.d/` with content like: + +```text +bnx2x +enic +qede +``` +It's a directory to allow other components like host install drop custom drivers to avoid impact on installation. + +### Configuration matrix + +The effective LLDP state on a NIC is determined by `pool.lldp_enabled`, `PIF.lldp_mode`, and whether the NIC driver is in the blocking list used by networkd. + +| `pool.lldp_enabled` | `PIF.lldp_mode` | parameter passed to networkd | NIC driver in blocking list | effective LLDP state | +| --- | --- | --- | --- | --- | +| `true` | `default` | `true` | `no` | `enabled` | +| `true` | `default` | `true` | `yes` | `disabled` | +| `false` | `default` | `false` | `*` | `disabled` | +| `*` | `enabled` | `true` | `*` | `enabled` | +| `*` | `disabled` | `false` | `*` | `disabled` | + +### Advertised LLDP TLVs + +When LLDP is enabled on a physical NIC, the LLDP agent advertises the following TLVs. + +| TLV | Value | +| --- | --- | +| Chassis ID | Host UUID (shared by all individual interfaces) | +| Port ID | Interface name | +| Port Description | Interface name | +| System Name | Host name | +| System Description | XAPI host.name_description | +| Management Address | Management IP address | +| System Capabilities | Bridge | +| TTL | Default value from the LLDP agent | + +Some advertised values follow the default behavior of `lldpd`, while others are configured by networkd when preparing the LLDP agent configuration. + +### Report received LLDP TLVs + +networkd periodically queries statistics for individual NICs and writes them to the in-memory file `/dev/shm/network_stats`. The file format is defined in `ocaml/xapi-idl/network/network_stats.ml` and is extended with a new field, `lldp_neighbor`. + +```ocaml +type lldp_rx = { + system_name: string option; + port_id: string option; + port_description: string option; +} +[@@deriving rpcty] + +type iface_stats = { + ... + lldp_neighbor: lldp_rx option; +} +``` +networkd queries `lldpd` for the LLDP TLVs recevied on individual NICs and writes them into `/dev/shm/network_stats`. +Monitor_dbcalls.monitor_dbcall_thread in XAPI reads the in-memory file `/dev/shm/network_stats` periodically, and exposes the data through `PIF_metrics.lldp_neighbor` by storing them in XenAPI map form. + +## Scenarios + +### Fresh install + +During the first host boot, networkd does not enable LLDP on physical interfaces because the default value of `lldp.enabled` in `interface_config_t` is `false`. +After XAPI starts, `network-init` scans physical interfaces (`PIF.scan`), creates PIF objects, and brings them up through `Nm.bring_pif_up`. +During this process, XAPI pushes its built-in configuration to networkd to enable LLDP on individual NICs. networkd may still keep LLDP disabled on some NICs based on the built-in blocking list. + +### Update or RPU + +After update or RPU from a version/release without LLDP support to a version/release with LLDP support, the default values of the new fields (`pool.lldp_enabled` and `PIF.lldp_mode`) cause networkd to keep LLDP disabled on all NICs. + +### Pool join + +The `PIF.lldp_mode` of PIFs on the joining host has the default value. The joining host shares the pool-level `pool.lldp_enabled` setting. +These configurations are pushed to networkd via `PIF.scan` during the first-boot `network-init` service on the joining host. + +### Pool eject + +`pool.lldp_enabled`, `PIF.lldp_mode`, and the networkd database revert to the values used just like after fresh install. From d045710cbe934c49c7021db6d021c32637384b00 Mon Sep 17 00:00:00 2001 From: Tu Dinh Date: Mon, 8 Jun 2026 18:01:14 +0200 Subject: [PATCH 34/34] Add DHCP setting for VIF IP configuration XAPI exposes a VIF.configure_ipv4/v6 message to instruct guest agents to configure the VM's IP settings on the host's behalf. This feature currently works by setting /local/domain//xenserver/ device/vif//static-ip-setting/enabled to one of the following values: enabled=0: None (unconfigured), so IP settings are decided by the VM itself enabled=1: Static, using the address and gateway values in the same key From the modes above, there's no way to go from a static IP config back to DHCP, and therefore, someone wanting to switch back to DHCP would need to log into the VM and make the changes there. Add a new VIF configuration mode that specifies enabled=2. This mode instructs the guest to configure its VIF to use DHCP (on IPv4) or any appropriate method to obtain an IP address automatically (on IPv6). Signed-off-by: Tu Dinh --- ocaml/idl/datamodel.ml | 8 ++++++-- ocaml/idl/datamodel_common.ml | 2 +- ocaml/idl/schematest.ml | 2 +- ocaml/tests/record_util/old_enum_all.ml | 4 ++-- ocaml/tests/record_util/old_record_util.ml | 12 ++++++++++-- ocaml/xapi-idl/xen/xenops_interface.ml | 2 ++ ocaml/xapi/xapi_vif.mli | 4 ++-- ocaml/xapi/xapi_xenops.ml | 4 ++++ ocaml/xe-cli/bash-completion | 4 ++-- ocaml/xenopsd/lib/xenops_server.ml | 16 ++++++++++------ ocaml/xenopsd/xc/xenops_server_xen.ml | 16 ++++++++++++---- 11 files changed, 52 insertions(+), 22 deletions(-) diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index 780f1847e91..bd131b806f3 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -3513,6 +3513,7 @@ module VIF = struct guest-dependent)" ) ; ("Static", "Static IPv4 address configuration") + ; ("DHCP", "Acquire an IP address by DHCP") ] ) @@ -3525,6 +3526,7 @@ module VIF = struct guest-dependent)" ) ; ("Static", "Static IPv6 address configuration") + ; ("Autoconf", "Acquire an IPv6 address automatically") ] ) @@ -3741,6 +3743,7 @@ module VIF = struct , rel_dundee , "Configure IPv4 settings for this virtual interface" ) + ; (Extended, "26.16.0", "Mode extended with 'DHCP' value") ] ~doc:"Configure IPv4 settings for this virtual interface" ~versioned_params: @@ -3755,7 +3758,7 @@ module VIF = struct ; { param_type= ipv4_configuration_mode ; param_name= "mode" - ; param_doc= "Whether to use static or no IPv4 assignment" + ; param_doc= "Whether to use DHCP, static or no IPv4 assignment" ; param_release= dundee_release ; param_default= None } @@ -3788,6 +3791,7 @@ module VIF = struct , rel_dundee , "Configure IPv6 settings for this virtual interface" ) + ; (Extended, "26.16.0", "Mode extended with 'Autoconf' value") ] ~doc:"Configure IPv6 settings for this virtual interface" ~versioned_params: @@ -3802,7 +3806,7 @@ module VIF = struct ; { param_type= ipv6_configuration_mode ; param_name= "mode" - ; param_doc= "Whether to use static or no IPv6 assignment" + ; param_doc= "Whether to use autoconf, static or no IPv6 assignment" ; param_release= dundee_release ; param_default= None } diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 0367714cd1a..5ae045f8bf6 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -10,7 +10,7 @@ open Datamodel_roles to leave a gap for potential hotfixes needing to increment the schema version.*) let schema_major_vsn = 5 -let schema_minor_vsn = 904 +let schema_minor_vsn = 905 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 03ef819fae6..f438ba234ad 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex (* BEWARE: if this changes, check that schema has been bumped accordingly in ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *) -let last_known_schema_hash = "13dfcc8ba21d122ba59de9c6c03c5236" +let last_known_schema_hash = "62c803c7341a736eef8293337105206f" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/tests/record_util/old_enum_all.ml b/ocaml/tests/record_util/old_enum_all.ml index f58cdc7542f..bd2bdd8d6d3 100644 --- a/ocaml/tests/record_util/old_enum_all.ml +++ b/ocaml/tests/record_util/old_enum_all.ml @@ -121,9 +121,9 @@ let all_ip_configuration_mode = [`None; `DHCP; `Static] let all_pif_igmp_status = [`enabled; `disabled; `unknown] -let all_vif_ipv6_configuration_mode = [`None; `Static] +let all_vif_ipv6_configuration_mode = [`None; `Static; `Autoconf] -let all_vif_ipv4_configuration_mode = [`None; `Static] +let all_vif_ipv4_configuration_mode = [`None; `Static; `DHCP] let all_vif_locking_mode = [`network_default; `locked; `unlocked; `disabled] diff --git a/ocaml/tests/record_util/old_record_util.ml b/ocaml/tests/record_util/old_record_util.ml index 855a2b74b7e..95fc1c5c4ad 100644 --- a/ocaml/tests/record_util/old_record_util.ml +++ b/ocaml/tests/record_util/old_record_util.ml @@ -872,6 +872,8 @@ let vif_ipv4_configuration_mode_to_string = function "None" | `Static -> "Static" + | `DHCP -> + "DHCP" let vif_ipv4_configuration_mode_of_string m = match String.lowercase_ascii m with @@ -879,8 +881,10 @@ let vif_ipv4_configuration_mode_of_string m = `None | "static" -> `Static + | "dhcp" -> + `DHCP | s -> - record_failure "Expected 'none' or 'static', got %s" s + record_failure "Expected 'dhcp','none' or 'static', got %s" s let ipv6_configuration_mode_to_string = function | `None -> @@ -910,6 +914,8 @@ let vif_ipv6_configuration_mode_to_string = function "None" | `Static -> "Static" + | `Autoconf -> + "Autoconf" let vif_ipv6_configuration_mode_of_string m = match String.lowercase_ascii m with @@ -917,8 +923,10 @@ let vif_ipv6_configuration_mode_of_string m = `None | "static" -> `Static + | "autoconf" -> + `Autoconf | s -> - record_failure "Expected 'none' or 'static', got %s" s + record_failure "Expected 'none', 'autoconf' or 'static', got %s" s let primary_address_type_to_string = function | `IPv4 -> diff --git a/ocaml/xapi-idl/xen/xenops_interface.ml b/ocaml/xapi-idl/xen/xenops_interface.ml index f27b4ec00b8..2e93d2c2afe 100644 --- a/ocaml/xapi-idl/xen/xenops_interface.ml +++ b/ocaml/xapi-idl/xen/xenops_interface.ml @@ -322,6 +322,7 @@ module Vif = struct type ipv4_configuration = | Unspecified4 | Static4 of string list * string option + | DHCP4 [@@deriving rpcty] (* a list of CIDRs and optionally a gateway *) @@ -331,6 +332,7 @@ module Vif = struct type ipv6_configuration = | Unspecified6 | Static6 of string list * string option + | Autoconf6 [@@deriving rpcty] (* a list of CIDRs and optionally a gateway *) diff --git a/ocaml/xapi/xapi_vif.mli b/ocaml/xapi/xapi_vif.mli index 782bab11992..2d98a7dc342 100644 --- a/ocaml/xapi/xapi_vif.mli +++ b/ocaml/xapi/xapi_vif.mli @@ -115,7 +115,7 @@ val remove_ipv6_allowed : val configure_ipv4 : __context:Context.t -> self:[`VIF] Ref.t - -> mode:[`None | `Static] + -> mode:[`None | `Static | `DHCP] -> address:string -> gateway:string -> unit @@ -124,7 +124,7 @@ val configure_ipv4 : val configure_ipv6 : __context:Context.t -> self:[`VIF] Ref.t - -> mode:[`None | `Static] + -> mode:[`None | `Static | `Autoconf] -> address:string -> gateway:string -> unit diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 017e3a1b4b2..9d2ee7437d0 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -852,6 +852,8 @@ module MD = struct Some vif.API.vIF_ipv4_gateway in Vif.Static4 (vif.API.vIF_ipv4_addresses, gateway) + | `DHCP -> + Vif.DHCP4 in let ipv6_configuration = match vif.API.vIF_ipv6_configuration_mode with @@ -865,6 +867,8 @@ module MD = struct Some vif.API.vIF_ipv6_gateway in Vif.Static6 (vif.API.vIF_ipv6_addresses, gateway) + | `Autoconf -> + Vif.Autoconf6 in let extra_private_keys = [("vif-uuid", vif.API.vIF_uuid); ("network-uuid", net.API.network_uuid)] diff --git a/ocaml/xe-cli/bash-completion b/ocaml/xe-cli/bash-completion index d11195c667c..1e2e6c72f7f 100644 --- a/ocaml/xe-cli/bash-completion +++ b/ocaml/xe-cli/bash-completion @@ -161,10 +161,10 @@ _xe() suggested_modes="dhcp,static,none,autoconf" elif [ "${COMP_WORDS[1]}" == "vif-configure-ipv4" ]; then IFS=$'\n,' - suggested_modes="static,none" + suggested_modes="dhcp,static,none" elif [ "${COMP_WORDS[1]}" == "vif-configure-ipv6" ]; then IFS=$'\n,' - suggested_modes="static,none" + suggested_modes="static,none,autoconf" elif [ "${OLDSTYLE_WORDS[1]}" == "bond-set-mode" ] || [ "${OLDSTYLE_WORDS[1]}" == "bond-create" ]; then IFS=$'\n,' suggested_modes="balance-slb,active-backup,lacp" diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 92fd8d55c16..8de1296c931 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -1592,16 +1592,18 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) let setting = match ipv4_configuration with | Vif.Unspecified4 -> - "" + "None" | Vif.Static4 (address, gateway) -> ( match gateway with | None -> - Printf.sprintf "address:%s" (String.concat "; " address) + Printf.sprintf "Static: address:%s" (String.concat "; " address) | Some value -> - Printf.sprintf "address:%s gateway:%s" + Printf.sprintf "Static: address:%s gateway:%s" (String.concat "; " address) value ) + | Vif.DHCP4 -> + "DHCP" in debug "VIF.set_ipv4_configuration %s %s" (VIF_DB.string_of_id id) setting ; finally @@ -1616,16 +1618,18 @@ let rec perform_atomic ~progress_callback ?result (op : atomic) let setting = match ipv6_configuration with | Vif.Unspecified6 -> - "" + "None" | Vif.Static6 (address6, gateway6) -> ( match gateway6 with | None -> - Printf.sprintf "address6:%s" (String.concat "; " address6) + Printf.sprintf "Static: address6:%s" (String.concat "; " address6) | Some value -> - Printf.sprintf "address6:%s gateway6:%s" + Printf.sprintf "Static: address6:%s gateway6:%s" (String.concat "; " address6) value ) + | Vif.Autoconf6 -> + "Autoconf" in debug "VIF.set_ipv6_configuration %s %s" (VIF_DB.string_of_id id) setting ; finally diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index facdee7845d..5835edf79ed 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -4884,6 +4884,8 @@ module VIF = struct | Static4 ([], _) -> internal_error "Static IPv4 configuration selected, but no address specified." + | DHCP4 -> + [("enabled", "2")] in let ipv6_setting = match vif.ipv6_configuration with @@ -4903,6 +4905,8 @@ module VIF = struct | Static6 ([], _) -> internal_error "Static IPv6 configuration selected, but no address specified." + | Autoconf6 -> + [("enabled6", "2")] in let settings = constant_setting @ ipv4_setting @ ipv6_setting in List.map @@ -5242,12 +5246,12 @@ module VIF = struct ) ) - let set_ip_unspecified xs xenstore_path suffix = + let set_ip_unspecified_or_autoconf xs xenstore_path suffix enabled_mode = Xs.transaction xs (fun t -> let ip_setting_enabled = Printf.sprintf "%s/%s%s" xenstore_path "enabled" suffix in - t.Xst.write ip_setting_enabled "0" ; + t.Xst.write ip_setting_enabled enabled_mode ; let ip_setting_address = Printf.sprintf "%s/%s%s" xenstore_path "address" suffix in @@ -5289,12 +5293,14 @@ module VIF = struct in match ipv4_configuration with | Unspecified4 -> - set_ip_unspecified xs xenstore_path "" + set_ip_unspecified_or_autoconf xs xenstore_path "" "0" | Static4 (address :: _, gateway) -> set_ip_static xs xenstore_path "" address gateway | Static4 ([], _) -> internal_error "Static IPv4 configuration selected, but no address specified." + | DHCP4 -> + set_ip_unspecified_or_autoconf xs xenstore_path "" "2" ) let set_ipv6_configuration _task vm vif ipv6_configuration = @@ -5307,12 +5313,14 @@ module VIF = struct in match ipv6_configuration with | Unspecified6 -> - set_ip_unspecified xs xenstore_path "6" + set_ip_unspecified_or_autoconf xs xenstore_path "6" "0" | Static6 (address :: _, gateway) -> set_ip_static xs xenstore_path "6" address gateway | Static6 ([], _) -> internal_error "Static IPv6 configuration selected, but no address specified." + | Autoconf6 -> + set_ip_unspecified_or_autoconf xs xenstore_path "6" "2" ) let set_pvs_proxy _task vm vif proxy =