From ead6edc110804f2bf8ddcb8663ef2dc4ee66d315 Mon Sep 17 00:00:00 2001 From: Gang Ji <62988402+gangj@users.noreply.github.com> Date: Tue, 5 Dec 2023 23:05:33 +0800 Subject: [PATCH 01/39] CP-45565: Add new guidance fields to API and CLI MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is the initial commit for the update guidance improvement: 1. Update comments for re-purposing host.pending_guidances. 2. Add new pending-guidance fields: host.pending_guidances_recommended, host.pending_guidances_full, vm.pending_guidances_recommended and vm.pending_guidances_full. 3. Add definition for new guidance: RestartVM, reboot_host_on_kernel_livepatch_failure and reboot_host_on_xen_livepatch_failure 4. Add DB upgrade rule: replace reboot_host_on_livepatch_failure in "host.pending_guidances" with both reboot_host_on_kernel_livepatch_failure and reboot_host_on_xen_livepatch_failure in "host.pending_guidances_recommended” 5. Clear reboot_host_on_kernel_livepatch_failure and reboot_host_on_xen_livepatch_failure on reboot 6. CLI: expose those new added pending guidance fields Signed-off-by: Gang Ji --- ocaml/idl/datamodel_common.ml | 11 ++++++++++- ocaml/idl/datamodel_host.ml | 14 +++++++++++++- ocaml/idl/datamodel_vm.ml | 14 +++++++++++++- ocaml/idl/schematest.ml | 2 +- ocaml/tests/common/test_common.ml | 3 ++- ocaml/xapi-cli-server/record_util.ml | 6 ++++++ ocaml/xapi-cli-server/records.ml | 24 ++++++++++++++++++++++++ ocaml/xapi/create_misc.ml | 3 ++- ocaml/xapi/updateinfo.ml | 17 +++++++++++++++++ ocaml/xapi/updateinfo.mli | 8 +++++++- ocaml/xapi/xapi_db_upgrade.ml | 28 ++++++++++++++++++++++++++++ ocaml/xapi/xapi_host.ml | 3 ++- ocaml/xapi/xapi_host_helpers.ml | 4 ++++ ocaml/xapi/xapi_vm.ml | 3 ++- ocaml/xapi/xapi_vm_clone.ml | 3 ++- 15 files changed, 133 insertions(+), 10 deletions(-) diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 29de79f4478..2253927c6c3 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 = 768 +let schema_minor_vsn = 769 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 @@ -316,6 +316,14 @@ let update_guidances = , "Indicates the updated host should reboot as soon as possible since \ one or more livepatch(es) failed to be applied." ) + ; ( "reboot_host_on_kernel_livepatch_failure" + , "Indicates the updated host should reboot as soon as possible since \ + one or more kernel livepatch(es) failed to be applied." + ) + ; ( "reboot_host_on_xen_livepatch_failure" + , "Indicates the updated host should reboot as soon as possible since \ + one or more xen livepatch(es) failed to be applied." + ) ; ( "restart_toolstack" , "Indicates the Toolstack running on the updated host should restart \ as soon as possible" @@ -324,6 +332,7 @@ let update_guidances = , "Indicates the device model of a running VM should restart as soon \ as possible" ) + ; ("restart_vm", "Indicates the VM should restart as soon as possible") ] ) diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 672f34ea8c4..574742f2764 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -2142,7 +2142,8 @@ let t = ; field ~qualifier:DynamicRO ~in_product_since:"1.303.0" ~ty:(Set update_guidances) "pending_guidances" ~default_value:(Some (VSet [])) - "The set of pending guidances after applying updates" + "The set of pending mandatory guidances after applying updates, \ + which must be applied, as otherwise there may be e.g. VM failures" ; field ~qualifier:DynamicRO ~in_product_since:"1.313.0" ~ty:Bool "tls_verification_enabled" ~default_value:(Some (VBool false)) "True if this host has TLS verifcation enabled" @@ -2164,6 +2165,17 @@ let t = ~default_value:(Some (VEnum "unknown")) "Default as 'unknown', 'yes' if the host is up to date with \ updates synced from remote CDN, otherwise 'no'" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set update_guidances) + "pending_guidances_recommended" ~default_value:(Some (VSet [])) + "The set of pending recommended guidances after applying updates, \ + which most users should follow to make the updates effective, but \ + if not followed, will not cause a failure" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set update_guidances) + "pending_guidances_full" ~default_value:(Some (VSet [])) + "The set of pending full guidances after applying updates, which a \ + user should follow to make some updates, e.g. specific hardware \ + drivers or CPU features, fully effective, but the 'average user' \ + doesn't need to" ] ) () diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index 014244ee41e..073af34d342 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -2155,12 +2155,24 @@ let t = ; field ~qualifier:DynamicRO ~in_product_since:"1.303.0" ~ty:(Set update_guidances) "pending_guidances" ~default_value:(Some (VSet [])) - "The set of pending guidances after applying updates" + "The set of pending mandatory guidances after applying updates, \ + which must be applied, as otherwise there may be e.g. VM failures" ; field ~qualifier:DynamicRO ~internal_only:true ~lifecycle:[(Prototyped, "23.18.0", ""); (Removed, "23.24.0", "")] ~ty:(Set update_guidances) "recommended_guidances" ~default_value:(Some (VSet [])) "The set of recommended guidances after applying updates" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set update_guidances) + "pending_guidances_recommended" ~default_value:(Some (VSet [])) + "The set of pending recommended guidances after applying updates, \ + which most users should follow to make the updates effective, but \ + if not followed, will not cause a failure" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:(Set update_guidances) + "pending_guidances_full" ~default_value:(Some (VSet [])) + "The set of pending full guidances after applying updates, which a \ + user should follow to make some updates, e.g. specific hardware \ + drivers or CPU features, fully effective, but the 'average user' \ + doesn't need to" ] ) () diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 58f772f09f7..6f31434e7dd 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -2,7 +2,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 = "8ff8c73b261e332b889583c8b2df5ecc" +let last_known_schema_hash = "9c650ad57273c375b9f82f26f82aa75f" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index a17dc8f6c54..8cb7c2b1a58 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -211,7 +211,8 @@ let make_host2 ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) ~multipathing:false ~uefi_certificates:"" ~editions:[] ~pending_guidances:[] ~tls_verification_enabled ~last_software_update:(Xapi_host.get_servertime ~__context ~host:ref) - ~recommended_guidances:[] ~latest_synced_updates_applied:`unknown ; + ~recommended_guidances:[] ~latest_synced_updates_applied:`unknown + ~pending_guidances_recommended:[] ~pending_guidances_full:[] ; ref let make_pif ~__context ~network ~host ?(device = "eth0") diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index 9b681ea6772..e21963c7172 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -203,10 +203,16 @@ let update_guidance_to_string = function "reboot_host" | `reboot_host_on_livepatch_failure -> "reboot_host_on_livepatch_failure" + | `reboot_host_on_kernel_livepatch_failure -> + "reboot_host_on_kernel_livepatch_failure" + | `reboot_host_on_xen_livepatch_failure -> + "reboot_host_on_xen_livepatch_failure" | `restart_toolstack -> "restart_toolstack" | `restart_device_model -> "restart_device_model" + | `restart_vm -> + "restart_vm" let latest_synced_updates_applied_state_to_string = function | `yes -> diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index c3d350b7cf2..168c59795cb 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -2588,6 +2588,18 @@ let vm_record rpc session_id vm = ; make_field ~name:"vtpms" ~get:(fun () -> get_uuids_from_refs (x ()).API.vM_VTPMs) () + ; make_field ~name:"pending-guidances-recommended" + ~get:(fun () -> + map_and_concat Record_util.update_guidance_to_string + (x ()).API.vM_pending_guidances_recommended + ) + () + ; make_field ~name:"pending-guidances-full" + ~get:(fun () -> + map_and_concat Record_util.update_guidance_to_string + (x ()).API.vM_pending_guidances_full + ) + () ] } @@ -3232,6 +3244,18 @@ let host_record rpc session_id host = (x ()).API.host_latest_synced_updates_applied ) () + ; make_field ~name:"pending-guidances-recommended" + ~get:(fun () -> + map_and_concat Record_util.update_guidance_to_string + (x ()).API.host_pending_guidances_recommended + ) + () + ; make_field ~name:"pending-guidances-full" + ~get:(fun () -> + map_and_concat Record_util.update_guidance_to_string + (x ()).API.host_pending_guidances_full + ) + () ] } diff --git a/ocaml/xapi/create_misc.ml b/ocaml/xapi/create_misc.ml index ac771469468..61dc5220f39 100644 --- a/ocaml/xapi/create_misc.ml +++ b/ocaml/xapi/create_misc.ml @@ -321,7 +321,8 @@ and create_domain_zero_record ~__context ~domain_zero_ref (host_info : host_info ~version:0L ~generation_id:"" ~hardware_platform_version:0L ~has_vendor_device:false ~requires_reboot:false ~reference_label:"" ~domain_type:Xapi_globs.domain_zero_domain_type ~nVRAM:[] - ~pending_guidances:[] ~recommended_guidances:[] ; + ~pending_guidances:[] ~recommended_guidances:[] + ~pending_guidances_recommended:[] ~pending_guidances_full:[] ; ensure_domain_zero_metrics_record ~__context ~domain_zero_ref host_info ; Db.Host.set_control_domain ~__context ~self:localhost ~value:domain_zero_ref ; Xapi_vm_helpers.update_memory_overhead ~__context ~vm:domain_zero_ref diff --git a/ocaml/xapi/updateinfo.ml b/ocaml/xapi/updateinfo.ml index 0640e27be99..2167266648d 100644 --- a/ocaml/xapi/updateinfo.ml +++ b/ocaml/xapi/updateinfo.ml @@ -24,6 +24,9 @@ module Guidance = struct | EvacuateHost | RestartDeviceModel | RebootHostOnLivePatchFailure + | RebootHostOnKernelLivePatchFailure + | RebootHostOnXenLivePatchFailure + | RestartVM type guidance_kind = Absolute | Recommended @@ -40,6 +43,12 @@ module Guidance = struct "RestartDeviceModel" | RebootHostOnLivePatchFailure -> "RebootHostOnLivePatchFailure" + | RebootHostOnKernelLivePatchFailure -> + "RebootHostOnKernelLivePatchFailure" + | RebootHostOnXenLivePatchFailure -> + "RebootHostOnXenLivePatchFailure" + | RestartVM -> + "RestartVM" let of_string = function | "RebootHost" -> @@ -50,6 +59,8 @@ module Guidance = struct EvacuateHost | "RestartDeviceModel" -> RestartDeviceModel + | "RestartVM" -> + RestartVM | g -> warn "Un-recognized guidance in \ @@ -63,10 +74,16 @@ module Guidance = struct RebootHost | `reboot_host_on_livepatch_failure -> RebootHostOnLivePatchFailure + | `reboot_host_on_kernel_livepatch_failure -> + RebootHostOnKernelLivePatchFailure + | `reboot_host_on_xen_livepatch_failure -> + RebootHostOnXenLivePatchFailure | `restart_toolstack -> RestartToolstack | `restart_device_model -> RestartDeviceModel + | `restart_vm -> + RestartVM end module Applicability = struct diff --git a/ocaml/xapi/updateinfo.mli b/ocaml/xapi/updateinfo.mli index 69d18571758..853ad4b74f9 100644 --- a/ocaml/xapi/updateinfo.mli +++ b/ocaml/xapi/updateinfo.mli @@ -20,6 +20,9 @@ module Guidance : sig | EvacuateHost | RestartDeviceModel | RebootHostOnLivePatchFailure + | RebootHostOnKernelLivePatchFailure + | RebootHostOnXenLivePatchFailure + | RestartVM type guidance_kind = Absolute | Recommended @@ -33,8 +36,11 @@ module Guidance : sig val of_update_guidance : [< `reboot_host | `reboot_host_on_livepatch_failure + | `reboot_host_on_kernel_livepatch_failure + | `reboot_host_on_xen_livepatch_failure | `restart_device_model - | `restart_toolstack ] + | `restart_toolstack + | `restart_vm ] -> t end diff --git a/ocaml/xapi/xapi_db_upgrade.ml b/ocaml/xapi/xapi_db_upgrade.ml index 2975f885168..cf8bc3f4c3b 100644 --- a/ocaml/xapi/xapi_db_upgrade.ml +++ b/ocaml/xapi/xapi_db_upgrade.ml @@ -859,6 +859,33 @@ let empty_pool_uefi_certificates = ) } +let update_livepatch_guidance = + { + description= + "Replace reboot_host_on_livepatch_failure in host.pending_guidances with \ + reboot_host_on_kernel_livepatch_failure and \ + reboot_host_on_xen_livepatch_failure in \ + host.pending_guidances_recommended" + ; version= (fun _ -> true) + ; fn= + (fun ~__context -> + Db.Host.get_all ~__context + |> List.iter (fun self -> + if + List.mem `reboot_host_on_livepatch_failure + (Db.Host.get_pending_guidances ~__context ~self) + then ( + Db.Host.add_pending_guidances_recommended ~__context ~self + ~value:`reboot_host_on_kernel_livepatch_failure ; + Db.Host.add_pending_guidances_recommended ~__context ~self + ~value:`reboot_host_on_xen_livepatch_failure ; + Db.Host.remove_pending_guidances ~__context ~self + ~value:`reboot_host_on_livepatch_failure + ) + ) + ) + } + let rules = [ upgrade_domain_type @@ -887,6 +914,7 @@ let rules = ; upgrade_secrets ; remove_legacy_ssl_support ; empty_pool_uefi_certificates + ; update_livepatch_guidance ] (* Maybe upgrade most recent db *) diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 65884883c96..ac71391a2c6 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1055,7 +1055,8 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address ~control_domain:Ref.null ~updates_requiring_reboot:[] ~iscsi_iqn:"" ~multipathing:false ~uefi_certificates:"" ~editions:[] ~pending_guidances:[] ~tls_verification_enabled ~last_software_update ~recommended_guidances:[] - ~latest_synced_updates_applied:`unknown ; + ~latest_synced_updates_applied:`unknown ~pending_guidances_recommended:[] + ~pending_guidances_full:[] ; (* If the host we're creating is us, make sure its set to live *) Db.Host_metrics.set_last_updated ~__context ~self:metrics ~value:(Date.of_float (Unix.gettimeofday ())) ; diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index f9b38a84c31..80c1bfb7f01 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -382,6 +382,10 @@ let consider_enabling_host_nolock ~__context = ~value:`reboot_host ; Db.Host.remove_pending_guidances ~__context ~self:localhost ~value:`reboot_host_on_livepatch_failure ; + Db.Host.remove_pending_guidances_recommended ~__context ~self:localhost + ~value:`reboot_host_on_kernel_livepatch_failure ; + Db.Host.remove_pending_guidances_recommended ~__context ~self:localhost + ~value:`reboot_host_on_xen_livepatch_failure ; update_allowed_operations ~__context ~self:localhost ; Localdb.put Constants.host_disabled_until_reboot "false" ; (* Start processing pending VM powercycle events *) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 4db86acbdef..cf02d593f7e 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -675,7 +675,8 @@ let create ~__context ~name_label ~name_description ~power_state ~user_version ~is_vmss_snapshot:false ~appliance ~start_delay ~shutdown_delay ~order ~suspend_SR ~version ~generation_id ~hardware_platform_version ~has_vendor_device ~requires_reboot:false ~reference_label ~domain_type - ~pending_guidances:[] ~recommended_guidances:[] ; + ~pending_guidances:[] ~recommended_guidances:[] + ~pending_guidances_recommended:[] ~pending_guidances_full:[] ; Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm_ref ; update_memory_overhead ~__context ~vm:vm_ref ; update_vm_virtual_hardware_platform_version ~__context ~vm:vm_ref ; diff --git a/ocaml/xapi/xapi_vm_clone.ml b/ocaml/xapi/xapi_vm_clone.ml index 73c551ca07e..8aac784002e 100644 --- a/ocaml/xapi/xapi_vm_clone.ml +++ b/ocaml/xapi/xapi_vm_clone.ml @@ -397,7 +397,8 @@ let copy_vm_record ?snapshot_info_record ~__context ~vm ~disk_op ~new_name ~has_vendor_device:all.Db_actions.vM_has_vendor_device ~requires_reboot:false ~reference_label:all.Db_actions.vM_reference_label ~domain_type:all.Db_actions.vM_domain_type ~nVRAM:all.Db_actions.vM_NVRAM - ~pending_guidances:[] ~recommended_guidances:[] ; + ~pending_guidances:[] ~recommended_guidances:[] + ~pending_guidances_recommended:[] ~pending_guidances_full:[] ; (* update the VM's parent field in case of snapshot. Note this must be done after "ref" has been created, so that its "children" field can be updated by the database layer *) ( match disk_op with From 4c036152a4e0590564b5f5595edee55474940852 Mon Sep 17 00:00:00 2001 From: Gang Ji <62988402+gangj@users.noreply.github.com> Date: Thu, 14 Dec 2023 09:42:25 +0800 Subject: [PATCH 02/39] CP-45568: Do not enable host if its mandatory host guidance is pending As mandatory host guidance must be applied after applying updates, otherwise there may be e.g. VM failures, it is safe not to enable a host when its mandatory host guidance is pending: 1. do not enable host on xapi startup if there is pending mandatory guidance in the host. 2. raise error "host_pending_mandatory_guidances_not_empty" for API host.enable if there is pending mandatory guidance in the host. 3. not enable host when both on host startup and on only xapi startup. Signed-off-by: Gang Ji --- ocaml/idl/datamodel_errors.ml | 6 ++++ ocaml/xapi-consts/api_errors.ml | 3 ++ ocaml/xapi/xapi_host.ml | 36 ++++++++++++++++++--- ocaml/xapi/xapi_host_helpers.ml | 55 ++++++++++++++++++++++++++------- 4 files changed, 84 insertions(+), 16 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 2aa67691774..01cf64a5185 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1963,6 +1963,12 @@ let _ = error Api_errors.no_repositories_configured [] ~doc:"No update repositories have been configured." () ; + error Api_errors.host_pending_mandatory_guidances_not_empty ["host"] + ~doc: + "The specified server is disabled and cannot be re-enabled until all of \ + its pending mandatory guidances got applied." + () ; + message (fst Api_messages.ha_pool_overcommitted) ~doc: diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 09317e31074..a7e15e079da 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1290,6 +1290,9 @@ let invalid_update_sync_day = "INVALID_UPDATE_SYNC_DAY" let no_repositories_configured = "NO_REPOSITORIES_CONFIGURED" +let host_pending_mandatory_guidances_not_empty = + "HOST_PENDING_MANDATORY_GUIDANCE_NOT_EMPTY" + (* VTPMs *) let vtpm_max_amount_reached = "VTPM_MAX_AMOUNT_REACHED" diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index ac71391a2c6..a284f934da1 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -67,19 +67,45 @@ let set_power_on_mode ~__context ~self ~power_on_mode ~power_on_config = Xapi_host_helpers.update_allowed_operations ~__context ~self (** Before we re-enable this host we make sure it's safe to do so. It isn't if: - + we're in the middle of an HA shutdown/reboot and have our fencing temporarily disabled. - + xapi hasn't properly started up yet. - + HA is enabled and this host has broken storage or networking which would cause protected VMs - to become non-agile + + there are pending mandatory guidances on the host + + we're in the middle of an HA shutdown/reboot and have our fencing temporarily disabled. + + xapi hasn't properly started up yet. + + HA is enabled and this host has broken storage or networking which would cause protected VMs + to become non-agile *) let assert_safe_to_reenable ~__context ~self = assert_startup_complete () ; + let host_pending_mandatory_guidances = + Db.Host.get_pending_guidances ~__context ~self + in + if host_pending_mandatory_guidances <> [] then ( + error "%s: %d mandatory guidances are pending for host %s: [%s]" + __FUNCTION__ + (List.length host_pending_mandatory_guidances) + (Ref.string_of self) + (String.concat ";" + (List.map Updateinfo.Guidance.to_string + (List.map Updateinfo.Guidance.of_update_guidance + host_pending_mandatory_guidances + ) + ) + ) ; + raise + (Api_errors.Server_error + ( Api_errors.host_pending_mandatory_guidances_not_empty + , [Ref.string_of self] + ) + ) + ) ; let host_disabled_until_reboot = try bool_of_string (Localdb.get Constants.host_disabled_until_reboot) with _ -> false in if host_disabled_until_reboot then - raise (Api_errors.Server_error (Api_errors.host_disabled_until_reboot, [])) ; + raise + (Api_errors.Server_error + (Api_errors.host_disabled_until_reboot, [Ref.string_of self]) + ) ; if Db.Pool.get_ha_enabled ~__context ~self:(Helpers.get_pool ~__context) then ( let pbds = Db.Host.get_PBDs ~__context ~self in let unplugged_pbds = diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 80c1bfb7f01..8e5c913839b 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -374,10 +374,30 @@ let consider_enabling_host_nolock ~__context = let pool = Helpers.get_pool ~__context in Db.Host.remove_pending_guidances ~__context ~self:localhost ~value:`restart_toolstack ; + let if_no_pending_guidances f = + let host_pending_mandatory_guidances = + Db.Host.get_pending_guidances ~__context ~self:localhost + in + if host_pending_mandatory_guidances <> [] then + debug + "Host.enabled: there are %d pending mandatory guidances on host \ + (%s): [%s]. Leave host disabled." + (List.length host_pending_mandatory_guidances) + (Ref.string_of localhost) + (String.concat ";" + (List.map Updateinfo.Guidance.to_string + (List.map Updateinfo.Guidance.of_update_guidance + host_pending_mandatory_guidances + ) + ) + ) + else + f () + in if !Xapi_globs.on_system_boot then ( debug - "Host.enabled: system has just restarted: setting localhost to enabled" ; - Db.Host.set_enabled ~__context ~self:localhost ~value:true ; + "Host.enabled: system has just restarted: remove livepatch failure \ + guidances" ; Db.Host.remove_pending_guidances ~__context ~self:localhost ~value:`reboot_host ; Db.Host.remove_pending_guidances ~__context ~self:localhost @@ -386,10 +406,17 @@ let consider_enabling_host_nolock ~__context = ~value:`reboot_host_on_kernel_livepatch_failure ; Db.Host.remove_pending_guidances_recommended ~__context ~self:localhost ~value:`reboot_host_on_xen_livepatch_failure ; - update_allowed_operations ~__context ~self:localhost ; - Localdb.put Constants.host_disabled_until_reboot "false" ; - (* Start processing pending VM powercycle events *) - Local_work_queue.start_vm_lifecycle_queue () + + if_no_pending_guidances (fun () -> + debug + "Host.enabled: system has just restarted and no pending mandatory \ + guidances: setting localhost to enabled" ; + Db.Host.set_enabled ~__context ~self:localhost ~value:true ; + update_allowed_operations ~__context ~self:localhost ; + Localdb.put Constants.host_disabled_until_reboot "false" ; + (* Start processing pending VM powercycle events *) + Local_work_queue.start_vm_lifecycle_queue () + ) ) else if try bool_of_string (Localdb.get Constants.host_disabled_until_reboot) with _ -> false @@ -400,11 +427,17 @@ let consider_enabling_host_nolock ~__context = else ( debug "Host.enabled: system not just rebooted && host_disabled_until_reboot \ - not set: setting localhost to enabled" ; - Db.Host.set_enabled ~__context ~self:localhost ~value:true ; - update_allowed_operations ~__context ~self:localhost ; - (* Start processing pending VM powercycle events *) - Local_work_queue.start_vm_lifecycle_queue () + not set" ; + if_no_pending_guidances (fun () -> + debug + "Host.enabled: system not just rebooted && \ + host_disabled_until_reboot not set and no pending mandatory \ + guidances: setting localhost to enabled" ; + Db.Host.set_enabled ~__context ~self:localhost ~value:true ; + update_allowed_operations ~__context ~self:localhost ; + (* Start processing pending VM powercycle events *) + Local_work_queue.start_vm_lifecycle_queue () + ) ) ; (* If Host has been enabled and HA is also enabled then tell the master to recompute its plan *) if From dbd7e7ecadc85bc0c830821a4e2d6703379b9fc9 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 1 Dec 2023 16:03:37 +0800 Subject: [PATCH 03/39] CP-45566: [1/4] Change to use new guidance format in updateinfo.xml The guidance in new format in updateinfo.xml file deprecates the guidance in old format. For backwards compatibility support, both old and new guidance data will be in updateinfo.xml. With this commit, XAPI uses the guidance in new format only as the data in new format has been presented in updateinfo.xml. Signed-off-by: Ming Lu --- ocaml/xapi/updateinfo.ml | 142 ++++++++++++++++++++++++-------------- ocaml/xapi/updateinfo.mli | 27 ++++++-- 2 files changed, 114 insertions(+), 55 deletions(-) diff --git a/ocaml/xapi/updateinfo.ml b/ocaml/xapi/updateinfo.ml index 2167266648d..5c8cb22d9ca 100644 --- a/ocaml/xapi/updateinfo.ml +++ b/ocaml/xapi/updateinfo.ml @@ -28,7 +28,17 @@ module Guidance = struct | RebootHostOnXenLivePatchFailure | RestartVM - type guidance_kind = Absolute | Recommended + type kind = Mandatory | Recommended | Full | Livepatch + + let kind_to_string = function + | Recommended -> + "recommended" + | Mandatory -> + "mandatory" + | Full -> + "full" + | Livepatch -> + "livepatch" let compare = Stdlib.compare @@ -50,6 +60,8 @@ module Guidance = struct | RestartVM -> "RestartVM" + let to_json g = `String (to_string g) + let of_string = function | "RebootHost" -> RebootHost @@ -62,11 +74,7 @@ module Guidance = struct | "RestartVM" -> RestartVM | g -> - warn - "Un-recognized guidance in \ - : %s, fallback to \ - RebootHost" - g ; + warn "Un-recognized guidance: %s, fallback to RebootHost" g ; RebootHost let of_update_guidance = function @@ -441,18 +449,79 @@ module Severity = struct raise Api_errors.(Server_error (invalid_updateinfo_xml, [])) end +module GuidanceInUpdateInfo = struct + type t = (Guidance.kind * Guidance.t list) list + + let value_of_xml = function + | Xml.Element ("value", _, [Xml.PCData v]) -> + Some (Guidance.of_string v) + | Xml.Element (unexpected, _, _) -> + warn "Ignore unexpected guidance value XML tag %s" unexpected ; + None + | _ -> + None + + exception Unsupported_kind_xml + + let kind_of_xml = function + | "recommended" -> + Guidance.Recommended + | "mandatory" -> + Guidance.Mandatory + | "full" -> + Guidance.Full + | "livepatch" -> + Guidance.Livepatch + | _ -> + raise Unsupported_kind_xml + + let default = + let open Guidance in + [(Mandatory, []); (Recommended, []); (Full, []); (Livepatch, [])] + + let of_xml xml_blocks = + List.fold_left + (fun acc xml_block -> + match xml_block with + | Xml.Element (kind_xml, _, values_in_xml) -> ( + match kind_of_xml kind_xml with + | kind -> + let values = List.filter_map value_of_xml values_in_xml in + (kind, values) :: List.remove_assoc kind acc + | exception Unsupported_kind_xml -> + warn "Unsupported guidance kind XML tag %s" kind_xml ; + acc + ) + | _ -> + warn "Ignore unexpected XML node in guidance." ; + acc + ) + default xml_blocks + + let to_json guidance = + List.map + (fun (kind, guidance_tasks) -> + ( Guidance.kind_to_string kind + , `List (List.map Guidance.to_json guidance_tasks) + ) + ) + guidance + |> fun l -> `Assoc l + + let to_string guidance = to_json guidance |> Yojson.Basic.to_string +end + module UpdateInfo = struct + (** The [guidance] deprecates [rec_guidance], [abs_guidance] and [livepatch_guidance] *) type t = { id: string ; summary: string ; description: string - ; rec_guidance: Guidance.t option - ; abs_guidance: Guidance.t option + ; guidance: GuidanceInUpdateInfo.t ; guidance_applicabilities: Applicability.t list ; spec_info: string ; url: string ; update_type: string - ; livepatch_guidance: Guidance.t option ; livepatches: LivePatch.t list ; issued: Xapi_stdext_date.Date.t ; severity: Severity.t @@ -462,7 +531,7 @@ module UpdateInfo = struct Option.value (Option.map Guidance.to_string o) ~default:"" let to_json ui = - let l = + `Assoc [ ("id", `String ui.id) ; ("summary", `String ui.summary) @@ -470,52 +539,26 @@ module UpdateInfo = struct ; ("special-info", `String ui.spec_info) ; ("URL", `String ui.url) ; ("type", `String ui.update_type) - ; ("recommended-guidance", `String (guidance_to_string ui.rec_guidance)) - ; ("absolute-guidance", `String (guidance_to_string ui.abs_guidance)) ; ("issued", `String (Xapi_stdext_date.Date.to_string ui.issued)) ; ("severity", `String (Severity.to_string ui.severity)) + ; ( "livepatches" + , `List (List.map (fun x -> LivePatch.to_json x) ui.livepatches) + ) + ; ("guidance", GuidanceInUpdateInfo.to_json ui.guidance) ] - in - match ui.livepatches with - | [] -> - `Assoc l - | _ as lps -> - let l' = - ( "livepatch-guidance" - , `String (guidance_to_string ui.livepatch_guidance) - ) - :: ("livepatches", `List (List.map (fun x -> LivePatch.to_json x) lps)) - :: l - in - `Assoc l' - - let to_string ui = - Printf.sprintf - "id=%s rec_guidance=%s abs_guidance=%s guidance_applicabilities=%s \ - livepatch_guidance=%s livepatches=%s" - ui.id - (guidance_to_string ui.rec_guidance) - (guidance_to_string ui.abs_guidance) - (String.concat ";" - (List.map Applicability.to_string ui.guidance_applicabilities) - ) - (guidance_to_string ui.livepatch_guidance) - (Astring.String.concat ~sep:";" - (List.map LivePatch.to_string ui.livepatches) - ) + + let to_string ui = to_json ui |> Yojson.Basic.to_string let default = { id= "" ; summary= "" ; description= "" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= GuidanceInUpdateInfo.default ; guidance_applicabilities= [] ; spec_info= "" ; url= "" ; update_type= "" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -537,6 +580,9 @@ module UpdateInfo = struct raise Api_errors.(Server_error (invalid_updateinfo_xml, [])) ) + let get_guidances_of_kind ~kind updateinfo = + Option.value (List.assoc_opt kind updateinfo.guidance) ~default:[] + let of_xml = function | Xml.Element ("updates", _, children) -> List.filter_map @@ -564,15 +610,11 @@ module UpdateInfo = struct {acc with summary= v} | Xml.Element ("description", _, [Xml.PCData v]) -> {acc with description= v} - | Xml.Element ("recommended_guidance", _, [Xml.PCData v]) - -> - {acc with rec_guidance= Some (Guidance.of_string v)} - | Xml.Element ("absolute_guidance", _, [Xml.PCData v]) -> - {acc with abs_guidance= Some (Guidance.of_string v)} - | Xml.Element ("livepatch_guidance", _, [Xml.PCData v]) -> + | Xml.Element ("guidance", _, guidance_blocks) -> { acc with - livepatch_guidance= Some (Guidance.of_string v) + guidance= + GuidanceInUpdateInfo.of_xml guidance_blocks } | Xml.Element ("guidance_applicabilities", _, apps) -> { diff --git a/ocaml/xapi/updateinfo.mli b/ocaml/xapi/updateinfo.mli index 853ad4b74f9..1040aa0a014 100644 --- a/ocaml/xapi/updateinfo.mli +++ b/ocaml/xapi/updateinfo.mli @@ -24,12 +24,16 @@ module Guidance : sig | RebootHostOnXenLivePatchFailure | RestartVM - type guidance_kind = Absolute | Recommended + type kind = Mandatory | Recommended | Full | Livepatch + + val kind_to_string : kind -> string val compare : t -> t -> int val to_string : t -> string + val to_json : t -> Yojson.Basic.t + (* may fail *) val of_string : string -> t @@ -113,19 +117,30 @@ module Severity : sig val of_string : string -> t end -(** The metadata of one update in updateinfo *) +(** The type of [guidance] in updateinfo metadata. *) +module GuidanceInUpdateInfo : sig + type t = (Guidance.kind * Guidance.t list) list + + val default : t + + val of_xml : Xml.xml list -> t + + val to_json : t -> Yojson.Basic.t + + val to_string : t -> string +end + +(** The metadata of one update in updateinfo. *) module UpdateInfo : sig type t = { id: string ; summary: string ; description: string - ; rec_guidance: Guidance.t option - ; abs_guidance: Guidance.t option + ; guidance: GuidanceInUpdateInfo.t ; guidance_applicabilities: Applicability.t list ; spec_info: string ; url: string ; update_type: string - ; livepatch_guidance: Guidance.t option ; livepatches: LivePatch.t list ; issued: Xapi_stdext_date.Date.t ; severity: Severity.t @@ -138,6 +153,8 @@ module UpdateInfo : sig val of_xml : Xml.xml -> (string * t) list val of_xml_file : string -> (string * t) list + + val get_guidances_of_kind : kind:Guidance.kind -> t -> Guidance.t list end module HostUpdates : sig From 35639f538932d6f5129c7c7c14844a7f033cdb7c Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 1 Dec 2023 16:29:48 +0800 Subject: [PATCH 04/39] CP-45566: [2/4] Update evaluating guidances from new data structures This commit updates the guidance evaluation logic and exposes the result of evaluation to the response of query on HTTP /updates endpoint. The response will be consumed by clients like XenCenter. The format of response is changed in this commit. Regarding this change, the backwards compatibility is not supported on this interface. Additionally, the evaluation is simplified by not considering the failed livapatches any more. Otherwise, the client like XenCenter has to introduce complicated UI design to populate the guidance change due to the livepatch failures. This may cause un-necessary carrying out of livepatch guidances. But the overall impact of carrying out these guidances is considered as ignorable. Signed-off-by: Ming Lu --- ocaml/xapi/repository_helpers.ml | 214 ++++++++++++++++--------------- ocaml/xapi/updateinfo.ml | 29 +++-- ocaml/xapi/updateinfo.mli | 16 ++- ocaml/xapi/xapi_host.ml | 2 +- ocaml/xapi/xapi_host_helpers.ml | 2 +- 5 files changed, 146 insertions(+), 117 deletions(-) diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 2fe83bd20b3..710995890a7 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -130,23 +130,34 @@ module GuidanceSet = struct [ (RebootHost, of_list [RestartToolstack; EvacuateHost; RestartDeviceModel]) ; (EvacuateHost, of_list [RestartDeviceModel]) + ; (RestartVM, of_list [RestartDeviceModel]) ] - let resort_guidances ~remove_evacuations gs = - let gs' = + (** reduce the set [gs] by sorting partially with the defined [precedences] *) + let resort gs = + List.fold_left + (fun acc (higher, lowers) -> + if mem higher acc then + diff acc lowers + else + acc + ) + gs precedences + + (** remove the guidances which are in s1 from s2. *) + let reduce s1 s2 = diff (resort (union s1 s2)) s1 + + (** for each set in the list, remove the guidances which are in previous sets from it. *) + let reduce_cascaded_list l = + let _, reduced_list_in_reverse = List.fold_left - (fun acc (higher, lowers) -> - if mem higher acc then - diff acc lowers - else - acc + (fun (acc_set, acc_list) (k, s) -> + let reduced = reduce acc_set s in + (union s acc_set, (k, reduced) :: acc_list) ) - gs precedences + (empty, []) l in - if remove_evacuations then - remove EvacuateHost gs' - else - gs' + List.rev reduced_list_in_reverse end let create_repository_record ~__context ~name_label ~name_description @@ -560,34 +571,31 @@ let get_updates_from_updateinfo ~__context repositories = in new_updates @ updates +let is_applicable ~update (applicability : Applicability.t) = + let open Update in + match + (update.name = applicability.name, update.arch = applicability.arch) + with + | true, true -> ( + match (update.old_epoch, update.old_version, update.old_release) with + | Some old_epoch, Some old_version, Some old_release -> + Applicability.eval ~epoch:old_epoch ~version:old_version + ~release:old_release ~applicability + | _ -> + warn "No installed epoch, version or release for package %s.%s" + update.name update.arch ; + false + ) + | _ -> + false + let eval_guidance_for_one_update ~updates_info ~update ~kind - ~upd_ids_of_livepatches ~upd_ids_of_failed_livepatches = + ~upd_ids_of_livepatches = let open Update in match update.update_id with | Some upd_id -> ( match List.assoc_opt upd_id updates_info with | Some updateinfo -> ( - let is_applicable (a : Applicability.t) = - match - ( update.name = a.Applicability.name - , update.arch = a.Applicability.arch - ) - with - | true, true -> ( - match - (update.old_epoch, update.old_version, update.old_release) - with - | Some old_epoch, Some old_version, Some old_release -> - Applicability.eval ~epoch:old_epoch ~version:old_version - ~release:old_release ~applicability:a - | _ -> - warn "No installed epoch, version or release for package %s.%s" - update.name update.arch ; - false - ) - | _ -> - false - in let pkg_str = Printf.sprintf "package %s.%s in update %s" update.name update.arch upd_id @@ -596,72 +604,77 @@ let eval_guidance_for_one_update ~updates_info ~update ~kind Printf.sprintf "Evaluating applicability for %s returned '%s'" pkg_str (string_of_bool r) in + let str_of_guidances guidances = + String.concat ";" (List.map Guidance.to_string guidances) + in let apps = updateinfo.UpdateInfo.guidance_applicabilities in - match (List.exists is_applicable apps, apps) with + match (List.exists (is_applicable ~update) apps, apps) with | true, _ | false, [] -> ( debug "%s" (dbg_msg true) ; + let open Guidance in + let open UpdateInfo in match kind with - | Guidance.Absolute -> - updateinfo.UpdateInfo.abs_guidance - | Guidance.Recommended -> ( - match - ( UpdateIdSet.mem upd_id upd_ids_of_livepatches - , UpdateIdSet.mem upd_id upd_ids_of_failed_livepatches - ) - with - | _, true -> - (* The update contains a failed livepatch. No guidance should be picked up. *) - debug - "%s doesn't contribute guidance due to a livepatch failure" - pkg_str ; - None - | true, false -> - (* The update has an applicable/successful livepatch. - * Using the livepatch guidance. - *) - let g = updateinfo.UpdateInfo.livepatch_guidance in - debug "%s provides livepatch guidance %s" pkg_str - (Option.value (Option.map Guidance.to_string g) ~default:"") ; - g - | false, false -> - let g = updateinfo.UpdateInfo.rec_guidance in - debug "%s provides recommended guidance %s" pkg_str - (Option.value (Option.map Guidance.to_string g) ~default:"") ; - g - ) + | Livepatch -> + (* Livepatch should not be evaluated directly *) + [] + | Full | Mandatory -> + let gs = get_guidances_of_kind ~kind updateinfo in + debug "%s contributes to %s guidances [%s]" pkg_str + (kind_to_string kind) (str_of_guidances gs) ; + gs + | Recommended -> + let gs = + match UpdateIdSet.mem upd_id upd_ids_of_livepatches with + | true -> + debug "use livepatch guidance of %s" pkg_str ; + get_guidances_of_kind ~kind:Livepatch updateinfo + | false -> + get_guidances_of_kind ~kind:Recommended updateinfo + in + debug "%s contributes to recommended guidances [%s]" pkg_str + (str_of_guidances gs) ; + gs ) | _ -> debug "%s" (dbg_msg false) ; - None + [] ) | None -> warn "Can't find update ID %s from updateinfo.xml for update %s.%s" upd_id update.name update.arch ; - None + [] ) | None -> warn "Ignore evaluating against package %s.%s as its update ID is missing" update.name update.arch ; - None + [] (* In case that the RPM in an update has been installed (including livepatch file), * but the livepatch has not been applied. * In other words, this RPM update will not appear in parameter [updates] of * function [eval_guidances], but the livepatch in it is still applicable. *) -let append_livepatch_guidances ~updates_info ~upd_ids_of_livepatches guidances = +let append_livepatch_guidance ~updates_info ~upd_ids_of_livepatches + guidance_tasks = + let ( let* ) = Option.bind in UpdateIdSet.fold (fun upd_id acc -> - match List.assoc_opt upd_id updates_info with - | Some UpdateInfo.{livepatch_guidance= Some g; _} -> - GuidanceSet.add g acc - | _ -> + let get_livepatch_guidance () = + let* updateinfo = List.assoc_opt upd_id updates_info in + let* l = + List.assoc_opt Guidance.Livepatch updateinfo.UpdateInfo.guidance + in + Some (GuidanceSet.of_list l) + in + match get_livepatch_guidance () with + | Some s -> + GuidanceSet.union s acc + | None -> acc ) - upd_ids_of_livepatches guidances + upd_ids_of_livepatches guidance_tasks -let eval_guidances ~updates_info ~updates ~kind ~livepatches ~failed_livepatches - = +let eval_guidances ~updates_info ~updates ~kind ~livepatches = let extract_upd_ids lps = List.fold_left (fun acc (_, lps) -> @@ -672,22 +685,22 @@ let eval_guidances ~updates_info ~updates ~kind ~livepatches ~failed_livepatches UpdateIdSet.empty lps in let upd_ids_of_livepatches = extract_upd_ids livepatches in - let upd_ids_of_failed_livepatches = extract_upd_ids failed_livepatches in List.fold_left (fun acc u -> - match - eval_guidance_for_one_update ~updates_info ~update:u ~kind - ~upd_ids_of_livepatches ~upd_ids_of_failed_livepatches - with - | Some g -> - GuidanceSet.add g acc - | None -> - acc + eval_guidance_for_one_update ~updates_info ~update:u ~kind + ~upd_ids_of_livepatches + |> GuidanceSet.of_list + |> GuidanceSet.union acc ) GuidanceSet.empty updates - |> append_livepatch_guidances ~updates_info ~upd_ids_of_livepatches - |> GuidanceSet.resort_guidances ~remove_evacuations:(kind = Guidance.Absolute) - |> GuidanceSet.elements + |> (fun l -> + match kind with + | Recommended -> + append_livepatch_guidance ~updates_info ~upd_ids_of_livepatches l + | _ -> + l + ) + |> GuidanceSet.resort let merge_with_unapplied_guidances ~__context ~host ~guidances = let open GuidanceSet in @@ -1282,35 +1295,28 @@ let consolidate_updates_of_host ~repository_name ~updates_info host let livepatches = retrieve_livepatches_from_updateinfo ~updates_info ~updates:updates_of_host in - let rec_guidances = - eval_guidances ~updates_info ~updates ~kind:Recommended ~livepatches - ~failed_livepatches:[] - in - let abs_guidances = - eval_guidances ~updates_info ~updates ~kind:Absolute ~livepatches:[] - ~failed_livepatches:[] - |> List.filter (fun g -> not (List.mem g rec_guidances)) - in - let upd_ids_of_livepatches, lps = - if List.mem Guidance.RebootHost rec_guidances then - (* Any livepatches should not be applied if packages updates require RebootHost *) - (UpdateIdSet.empty, []) - else - merge_livepatches ~livepatches + let guidance = + let open Guidance in + (* The order does matter with the following reducing *) + [Mandatory; Recommended; Full] + |> List.map (fun kind -> + (kind, eval_guidances ~updates_info ~updates ~kind ~livepatches) + ) + |> GuidanceSet.reduce_cascaded_list + |> List.map (fun (kind, s) -> (kind, GuidanceSet.elements s)) in + let upd_ids_of_livepatches, lps = merge_livepatches ~livepatches in let upd_ids = UpdateIdSet.union ids_of_updates upd_ids_of_livepatches in let host_updates = HostUpdates. { host - ; rec_guidances - ; abs_guidances + ; guidance ; rpms ; update_ids= UpdateIdSet.elements upd_ids ; livepatches= lps } in - (host_updates, upd_ids) let append_by_key l k v = diff --git a/ocaml/xapi/updateinfo.ml b/ocaml/xapi/updateinfo.ml index 5c8cb22d9ca..6c58e23a452 100644 --- a/ocaml/xapi/updateinfo.ml +++ b/ocaml/xapi/updateinfo.ml @@ -77,7 +77,7 @@ module Guidance = struct warn "Un-recognized guidance: %s, fallback to RebootHost" g ; RebootHost - let of_update_guidance = function + let of_pending_guidance = function | `reboot_host -> RebootHost | `reboot_host_on_livepatch_failure -> @@ -92,6 +92,24 @@ module Guidance = struct RestartDeviceModel | `restart_vm -> RestartVM + + let to_pending_guidance = function + | RebootHost -> + Some `reboot_host + | RebootHostOnLivePatchFailure -> + Some `reboot_host_on_livepatch_failure + | RestartToolstack -> + Some `restart_toolstack + | RestartDeviceModel -> + Some `restart_device_model + | RebootHostOnXenLivePatchFailure -> + Some `reboot_host_on_xen_livepatch_failure + | RebootHostOnKernelLivePatchFailure -> + Some `reboot_host_on_kernel_livepatch_failure + | RestartVM -> + Some `restart_vm + | EvacuateHost -> + None end module Applicability = struct @@ -686,23 +704,18 @@ end module HostUpdates = struct type t = { host: string - ; rec_guidances: Guidance.t list - ; abs_guidances: Guidance.t list + ; guidance: GuidanceInUpdateInfo.t ; rpms: Rpm.Pkg.t list ; update_ids: string list ; livepatches: LivePatch.t list } let to_json host_updates = - let g_to_j x = `String (Guidance.to_string x) in let p_to_j x = `String (Pkg.to_fullname x) in `Assoc [ ("ref", `String host_updates.host) - ; ( "recommended-guidance" - , `List (List.map g_to_j host_updates.rec_guidances) - ) - ; ("absolute-guidance", `List (List.map g_to_j host_updates.abs_guidances)) + ; ("guidance", GuidanceInUpdateInfo.to_json host_updates.guidance) ; ("RPMS", `List (List.map p_to_j host_updates.rpms)) ; ( "updates" , `List (List.map (fun upd_id -> `String upd_id) host_updates.update_ids) diff --git a/ocaml/xapi/updateinfo.mli b/ocaml/xapi/updateinfo.mli index 1040aa0a014..5d666144358 100644 --- a/ocaml/xapi/updateinfo.mli +++ b/ocaml/xapi/updateinfo.mli @@ -37,7 +37,7 @@ module Guidance : sig (* may fail *) val of_string : string -> t - val of_update_guidance : + val of_pending_guidance : [< `reboot_host | `reboot_host_on_livepatch_failure | `reboot_host_on_kernel_livepatch_failure @@ -46,6 +46,17 @@ module Guidance : sig | `restart_toolstack | `restart_vm ] -> t + + val to_pending_guidance : + t + -> [> `reboot_host + | `reboot_host_on_livepatch_failure + | `reboot_host_on_kernel_livepatch_failure + | `reboot_host_on_xen_livepatch_failure + | `restart_device_model + | `restart_toolstack + | `restart_vm ] + option end (** The applicability of metadata for one update in updateinfo *) @@ -160,8 +171,7 @@ end module HostUpdates : sig type t = { host: string - ; rec_guidances: Guidance.t list - ; abs_guidances: Guidance.t list + ; guidance: GuidanceInUpdateInfo.t ; rpms: Rpm.Pkg.t list ; update_ids: string list ; livepatches: LivePatch.t list diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index a284f934da1..32dc3391d1b 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -85,7 +85,7 @@ let assert_safe_to_reenable ~__context ~self = (Ref.string_of self) (String.concat ";" (List.map Updateinfo.Guidance.to_string - (List.map Updateinfo.Guidance.of_update_guidance + (List.map Updateinfo.Guidance.of_pending_guidance host_pending_mandatory_guidances ) ) diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 8e5c913839b..9549c0176d8 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -386,7 +386,7 @@ let consider_enabling_host_nolock ~__context = (Ref.string_of localhost) (String.concat ";" (List.map Updateinfo.Guidance.to_string - (List.map Updateinfo.Guidance.of_update_guidance + (List.map Updateinfo.Guidance.of_pending_guidance host_pending_mandatory_guidances ) ) From e9800c4e80259ebcd80659e015e079e04365a351 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 1 Dec 2023 16:40:54 +0800 Subject: [PATCH 05/39] CP-45566: [3/4] Fixup handling pending mandatory guidances This commit updates the setting pending guidances logic. Since the host|VM.pending_guidances are re-purposed to be mandatory guidances, the setting logic is updated accordingly. Aslo fix-up setting pending mandatory guidances logic. The VMs' pending lists were missed. Meanwhile, the handling logic is changed to be easy for unit testing as well. Livepatch failures related guidance will not be in mandatory pending list. They will be handled in another pull request. Signed-off-by: Ming Lu --- ocaml/idl/datamodel_errors.ml | 4 - ocaml/xapi-consts/api_errors.ml | 5 - ocaml/xapi/repository.ml | 121 ++++++-------------- ocaml/xapi/repository.mli | 2 +- ocaml/xapi/repository_helpers.ml | 185 +++++++++++++++++++++++-------- ocaml/xapi/xapi_host.ml | 12 +- 6 files changed, 174 insertions(+), 155 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 01cf64a5185..1d841ccdb21 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1942,10 +1942,6 @@ let _ = ~doc:"The repository domain allowlist has some invalid domains." () ; error Api_errors.apply_livepatch_failed ["livepatch"] ~doc:"Failed to apply a livepatch." () ; - error Api_errors.updates_require_recommended_guidance ["recommended_guidance"] - ~doc:"Requires recommended guidance after applying updates." () ; - error Api_errors.update_guidance_changed ["guidance"] - ~doc:"Guidance for the update has changed" () ; error Api_errors.vtpm_max_amount_reached ["amount"] ~doc:"The VM cannot be associated with more VTPMs." () ; diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index a7e15e079da..58e4d52fd05 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1281,11 +1281,6 @@ let invalid_repository_domain_allowlist = "INVALID_REPOSITORY_DOMAIN_ALLOWLIST" let apply_livepatch_failed = "APPLY_LIVEPATCH_FAILED" -let updates_require_recommended_guidance = - "UPDATES_REQUIRE_RECOMMENDED_GUIDANCE" - -let update_guidance_changed = "UPDATE_GUIDANCE_CHANGED" - let invalid_update_sync_day = "INVALID_UPDATE_SYNC_DAY" let no_repositories_configured = "NO_REPOSITORIES_CONFIGURED" diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index c80f51ad41a..9e2aad855f4 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -623,47 +623,6 @@ let apply_livepatch ~__context ~host:_ ~component ~base_build_id ~base_version error "%s" msg ; raise Api_errors.(Server_error (internal_error, [msg])) -let set_restart_device_models ~__context ~host = - (* Set pending restart device models of all running HVM VMs on the host *) - do_with_device_models ~__context ~host @@ fun (ref, record) -> - match - (record.API.vM_power_state, Helpers.has_qemu_currently ~__context ~self:ref) - with - | `Running, true | `Paused, true -> - Db.VM.set_pending_guidances ~__context ~self:ref - ~value:[`restart_device_model] ; - None - | _ -> - (* No device models are running for this VM *) - None - -let set_guidances ~__context ~host ~guidances ~db_set = - let open Guidance in - guidances - |> List.fold_left - (fun acc g -> - match g with - | RebootHost -> - `reboot_host :: acc - | RestartToolstack -> - `restart_toolstack :: acc - | RestartDeviceModel -> - set_restart_device_models ~__context ~host ; - acc - | RebootHostOnLivePatchFailure -> - `reboot_host_on_livepatch_failure :: acc - | _ -> - warn "Unsupported pending guidance %s, ignoring it." - (Guidance.to_string g) ; - acc - ) - [] - |> fun gs -> db_set ~__context ~self:host ~value:gs - -let set_pending_guidances ~__context ~host ~guidances = - set_guidances ~__context ~host ~guidances - ~db_set:Db.Host.set_pending_guidances - let apply_livepatches' ~__context ~host ~livepatches = List.partition_map (fun (lp, lps) -> @@ -695,18 +654,7 @@ let apply_livepatches' ~__context ~host ~livepatches = ) livepatches -let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates - = - (* This function runs on coordinator host *) - (* Install RPM updates firstly *) - Helpers.call_api_functions ~__context (fun rpc session_id -> - Client.Client.Repository.apply ~rpc ~session_id ~host - ) ; - (* Apply live patches with best effort *) - let successful_livepatches, failed_livepatches = - apply_livepatches' ~__context ~host ~livepatches - in - (* Update states in cache with best effort as well *) +let update_cache ~host ~failed_livepatches = Hashtbl.replace updates_in_cache host (`Assoc [ @@ -720,40 +668,41 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates ) ) ] - ) ; - (* Evaluate guidances *) - let guidances = - let guidances' = - (* EvacuateHost will be applied before applying updates *) - eval_guidances ~updates_info ~updates:acc_rpm_updates ~kind:Recommended - ~livepatches:successful_livepatches ~failed_livepatches - |> List.filter (fun g -> g <> Guidance.EvacuateHost) - |> fun l -> merge_with_unapplied_guidances ~__context ~host ~guidances:l - in - GuidanceSet.assert_valid_guidances guidances' ; - match failed_livepatches with - | [] -> - guidances' - | _ :: _ -> - (* There is(are) livepatch failure(s): - * the host should not be rebooted, and - * an extra pending guidance 'RebootHostOnLivePatchFailure' should be set. - *) - guidances' - |> List.filter (fun g -> g <> Guidance.RebootHost) - |> List.cons Guidance.RebootHostOnLivePatchFailure + ) + +let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates + = + (* This function runs on coordinator host *) + let open Guidance in + let get_guidances kind = + eval_guidances ~updates_info ~updates:acc_rpm_updates ~kind ~livepatches + |> GuidanceSet.remove EvacuateHost + |> GuidanceSet.elements in + let mandatory = get_guidances Mandatory in + (* Install RPM updates *) + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Repository.apply ~rpc ~session_id ~host + ) ; + (* Apply livepatches *) + let _, failed_livepatches = + match List.mem RebootHost mandatory with + | true -> + (* Not apply any livepatches as the host will reboot *) + ([], []) + | false -> + apply_livepatches' ~__context ~host ~livepatches + in + (* Update states in cache *) + update_cache ~host ~failed_livepatches ; List.iter - (fun g -> debug "pending_guidance: %s" (Guidance.to_string g)) - guidances ; - set_pending_guidances ~__context ~host ~guidances ; - ( guidances - , List.map - (fun (lp, _) -> - [Api_errors.apply_livepatch_failed; LivePatch.to_string lp] - ) - failed_livepatches - ) + (fun g -> debug "mandatory pending_guidance: %s" (to_string g)) + mandatory ; + let ops = get_ops_of_pending ~__context ~host ~kind:Mandatory in + set_pending_guidances ~ops ~coming:mandatory ; + List.map + (fun (lp, _) -> [Api_errors.apply_livepatch_failed; LivePatch.to_string lp]) + failed_livepatches let apply_updates ~__context ~host ~hash = (* This function runs on coordinator host *) @@ -782,7 +731,7 @@ let apply_updates ~__context ~host ~hash = | [], [] -> let host' = Ref.string_of host in info "Host ref='%s' is already up to date." host' ; - ([], []) + [] | _ -> let repository_name = get_repository_name ~__context ~self:repository diff --git a/ocaml/xapi/repository.mli b/ocaml/xapi/repository.mli index 43ea34cbe4f..8b8ee7e09cd 100644 --- a/ocaml/xapi/repository.mli +++ b/ocaml/xapi/repository.mli @@ -64,7 +64,7 @@ val apply_updates : __context:Context.t -> host:[`host] API.Ref.t -> hash:string - -> Updateinfo.Guidance.t list * string list list + -> string list list val set_available_updates : __context:Context.t -> string diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 710995890a7..af11dc4dc0a 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -99,33 +99,6 @@ module GuidanceSet = struct include GuidanceSet' open Guidance - let eq l s = equal (of_list l) (of_list s) - - let eq_set1 = eq [EvacuateHost; RestartToolstack] - - let eq_set2 = eq [RestartDeviceModel; RestartToolstack] - - let error_msg l = - Printf.sprintf "Found wrong guidance(s): %s" - (String.concat ";" (List.map to_string l)) - - let assert_valid_guidances = function - | [] - | [RebootHost] - | [EvacuateHost] - | [RestartToolstack] - | [RestartDeviceModel] -> - () - | l when eq_set1 l -> - (* EvacuateHost and RestartToolstack *) - () - | l when eq_set2 l -> - (* RestartDeviceModel and RestartToolstack *) - () - | l -> - let msg = error_msg l in - raise Api_errors.(Server_error (internal_error, [msg])) - let precedences = [ (RebootHost, of_list [RestartToolstack; EvacuateHost; RestartDeviceModel]) @@ -702,16 +675,6 @@ let eval_guidances ~updates_info ~updates ~kind ~livepatches = ) |> GuidanceSet.resort -let merge_with_unapplied_guidances ~__context ~host ~guidances = - let open GuidanceSet in - Db.Host.get_pending_guidances ~__context ~self:host - |> List.map (fun g -> Guidance.of_update_guidance g) - |> List.filter (fun g -> g <> Guidance.RebootHostOnLivePatchFailure) - |> of_list - |> union (of_list guidances) - |> resort_guidances ~remove_evacuations:false - |> elements - let repoquery_sep = ":|" let get_repoquery_fmt () = @@ -1379,15 +1342,139 @@ let prune_updateinfo_for_livepatches livepatches updateinfo = in {updateinfo with livepatches= lps} -let do_with_device_models ~__context ~host f = - (* Call f with device models of all running HVM VMs on the host *) - Db.Host.get_resident_VMs ~__context ~self:host - |> List.map (fun self -> (self, Db.VM.get_record ~__context ~self)) - |> List.filter (fun (_, record) -> not record.API.vM_is_control_domain) - |> List.filter_map f - |> function - | [] -> - () - | _ :: _ -> - let host' = Ref.string_of host in - raise Api_errors.(Server_error (cannot_restart_device_model, [host'])) +let do_with_host_pending_guidances ~op guidances = + List.iter + (fun g -> + match Guidance.to_pending_guidance g with + | ( Some `restart_toolstack + | Some `reboot_host + | Some `reboot_host_on_xen_livepatch_failure + | Some `reboot_host_on_kernel_livepatch_failure + | Some `reboot_host_on_livepatch_failure ) as g' -> + Option.iter op g' + | _ -> + () + ) + guidances + +let do_with_vm_pending_guidances ~op ~vm guidances = + List.iter + (fun g -> + match Guidance.to_pending_guidance g with + | Some `restart_device_model -> + op vm `restart_device_model + | Some `restart_vm -> + op vm `restart_vm + | _ -> + () + ) + guidances + +let merge_with_pending_guidances ~pending ~coming = + let open GuidanceSet in + let pending = of_list pending in + let unioned = union pending (of_list coming) |> remove EvacuateHost in + (diff unioned pending |> elements, diff pending unioned |> elements) + +let is_livepatch_failure = function + | Guidance.RebootHostOnLivePatchFailure + | Guidance.RebootHostOnXenLivePatchFailure + | Guidance.RebootHostOnKernelLivePatchFailure -> + true + | _ -> + false + +type pending_ops = { + host_get: unit -> Guidance.t list + ; host_add: + [ `reboot_host + | `reboot_host_on_livepatch_failure + | `restart_toolstack + | `reboot_host_on_xen_livepatch_failure + | `reboot_host_on_kernel_livepatch_failure ] + -> unit + ; host_remove: + [ `reboot_host + | `reboot_host_on_livepatch_failure + | `restart_toolstack + | `reboot_host_on_xen_livepatch_failure + | `reboot_host_on_kernel_livepatch_failure ] + -> unit + ; vms_get: unit -> (string * Guidance.t list) list + ; vm_add: string -> [`restart_device_model | `restart_vm] -> unit + ; vm_remove: string -> [`restart_device_model | `restart_vm] -> unit +} + +let get_ops_of_pending ~__context ~host ~kind = + let get_pending_guidances_of_host ~db_get = + db_get ~__context ~self:host + |> List.map (fun g -> Guidance.of_pending_guidance g) + in + let get_pending_guidances_of_vms ~db_get = + Db.Host.get_resident_VMs ~__context ~self:host + |> List.map (fun self -> (self, Db.VM.get_record ~__context ~self)) + |> List.filter_map (fun (ref, record) -> + match + ( record.API.vM_is_control_domain + , record.API.vM_power_state + , Helpers.has_qemu_currently ~__context ~self:ref + ) + with + | false, `Running, true | false, `Paused, true -> + Some ref + | _ -> + None + ) + |> List.map (fun vm_ref -> + let pending_guidances = + db_get ~__context ~self:vm_ref + |> List.map Guidance.of_pending_guidance + in + (Ref.string_of vm_ref, pending_guidances) + ) + in + match kind with + | Guidance.Mandatory -> + let host_get () = + get_pending_guidances_of_host ~db_get:Db.Host.get_pending_guidances + in + let host_add value = + Db.Host.add_pending_guidances ~__context ~self:host ~value + in + let host_remove value = + Db.Host.remove_pending_guidances ~__context ~self:host ~value + in + let vms_get () = + get_pending_guidances_of_vms ~db_get:Db.VM.get_pending_guidances + in + let vm_add vm value = + Db.VM.add_pending_guidances ~__context ~self:(Ref.of_string vm) ~value + in + let vm_remove vm value = + Db.VM.remove_pending_guidances ~__context ~self:(Ref.of_string vm) + ~value + in + {host_get; host_add; host_remove; vms_get; vm_add; vm_remove} + | _ -> + raise Api_errors.(Server_error (internal_error, ["Not implemented kind"])) + +let set_pending_guidances ~ops ~coming = + let pending_of_host = + ops.host_get () |> List.filter (fun x -> not (is_livepatch_failure x)) + in + let to_be_added, to_be_removed = + merge_with_pending_guidances ~pending:pending_of_host ~coming + in + do_with_host_pending_guidances ~op:ops.host_remove to_be_removed ; + do_with_host_pending_guidances ~op:ops.host_add to_be_added ; + + ops.vms_get () + |> List.map (fun (vm_ref_str, pending_of_vm) -> + let pending = List.append pending_of_host pending_of_vm in + (vm_ref_str, merge_with_pending_guidances ~pending ~coming) + ) + |> List.iter (fun (vm_ref_str, (to_be_added, to_be_removed)) -> + do_with_vm_pending_guidances ~op:ops.vm_remove ~vm:vm_ref_str + to_be_removed ; + do_with_vm_pending_guidances ~op:ops.vm_add ~vm:vm_ref_str to_be_added + ) diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 32dc3391d1b..c1fed8daeb3 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -3021,7 +3021,7 @@ let apply_updates ~__context ~self ~hash = (* This function runs on master host *) Helpers.assert_we_are_master ~__context ; Pool_features.assert_enabled ~__context ~f:Features.Updates ; - let guidances, warnings = + let warnings = Xapi_pool_helpers.with_pool_operation ~__context ~self:(Helpers.get_pool ~__context) ~doc:"Host.apply_updates" ~op:`apply_updates @@ -3036,15 +3036,7 @@ let apply_updates ~__context ~self ~hash = Db.Host.set_last_software_update ~__context ~self ~value:(get_servertime ~__context ~host:self) ; Db.Host.set_latest_synced_updates_applied ~__context ~self ~value:`yes ; - List.map - (fun g -> - [ - Api_errors.updates_require_recommended_guidance - ; Updateinfo.Guidance.to_string g - ] - ) - guidances - @ warnings + warnings let cc_prep () = let cc = "CC_PREPARATIONS" in From 80cb76b7d31a9dda224434c4fcda0aecf767e5cb Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 1 Dec 2023 16:45:02 +0800 Subject: [PATCH 06/39] CP-45566: [4/4] Update unit tests This commit updates and adds unit tests for previous commits. Signed-off-by: Ming Lu --- ocaml/tests/test_repository_helpers.ml | 1569 +++++++++++++++++++----- ocaml/tests/test_updateinfo.ml | 495 +++++++- 2 files changed, 1709 insertions(+), 355 deletions(-) diff --git a/ocaml/tests/test_repository_helpers.ml b/ocaml/tests/test_repository_helpers.ml index eeebee23926..0eee649056a 100644 --- a/ocaml/tests/test_repository_helpers.ml +++ b/ocaml/tests/test_repository_helpers.ml @@ -187,118 +187,6 @@ module UpdateOfJsonTest = Generic.MakeStateless (struct ] end) -module GuidanceSetAssertValidGuidanceTest = Generic.MakeStateless (struct - module Io = struct - type input_t = Guidance.t list - - type output_t = (unit, exn) result - - let string_of_input_t l = - Fmt.(str "%a" Dump.(list string)) (List.map Guidance.to_string l) - - let string_of_output_t = - Fmt.(str "%a" Dump.(result ~ok:(any "()") ~error:exn)) - end - - let transform input = - try Ok (GuidanceSet.assert_valid_guidances input) with e -> Error e - - let tests = - let open Guidance in - `QuickAndAutoDocumented - [ - ([], Ok ()) - ; ([RebootHost], Ok ()) - ; ([RestartToolstack], Ok ()) - ; ([RestartDeviceModel], Ok ()) - ; ([EvacuateHost], Ok ()) - ; ([EvacuateHost; RestartToolstack], Ok ()) - ; ([RestartDeviceModel; RestartToolstack], Ok ()) - ; ( [RestartDeviceModel; EvacuateHost] - , Error - Api_errors.( - Server_error - ( internal_error - , [GuidanceSet.error_msg [RestartDeviceModel; EvacuateHost]] - ) - ) - ) - ; ( [EvacuateHost; RestartToolstack; RestartDeviceModel] - , Error - Api_errors.( - Server_error - ( internal_error - , [ - GuidanceSet.error_msg - [EvacuateHost; RestartToolstack; RestartDeviceModel] - ] - ) - ) - ) - ; ( [RebootHost; RestartToolstack] - , Error - Api_errors.( - Server_error - ( internal_error - , [GuidanceSet.error_msg [RebootHost; RestartToolstack]] - ) - ) - ) - ; ( [RebootHost; RestartDeviceModel] - , Error - Api_errors.( - Server_error - ( internal_error - , [GuidanceSet.error_msg [RebootHost; RestartDeviceModel]] - ) - ) - ) - ; ( [RebootHost; EvacuateHost] - , Error - Api_errors.( - Server_error - ( internal_error - , [GuidanceSet.error_msg [RebootHost; EvacuateHost]] - ) - ) - ) - ] -end) - -let fields_of_updateinfo = - Fmt.Dump. - [ - field "id" (fun (r : UpdateInfo.t) -> r.id) string - ; field "summary" (fun (r : UpdateInfo.t) -> r.summary) string - ; field "description" (fun (r : UpdateInfo.t) -> r.description) string - ; field "rec_guidance" - (fun (r : UpdateInfo.t) -> UpdateInfo.guidance_to_string r.rec_guidance) - string - ; field "abs_guidance" - (fun (r : UpdateInfo.t) -> UpdateInfo.guidance_to_string r.abs_guidance) - string - ; field "guidance_applicabilities" - (fun (r : UpdateInfo.t) -> - List.map Applicability.to_string r.guidance_applicabilities - ) - (list string) - ; field "spec_info" (fun (r : UpdateInfo.t) -> r.spec_info) string - ; field "url" (fun (r : UpdateInfo.t) -> r.url) string - ; field "update_type" (fun (r : UpdateInfo.t) -> r.update_type) string - ; field "livepatch_guidance" - (fun (r : UpdateInfo.t) -> - UpdateInfo.guidance_to_string r.livepatch_guidance - ) - string - ; field "livepatches" - (fun (r : UpdateInfo.t) -> - List.map - (fun x -> x |> LivePatch.to_json |> Yojson.Basic.pretty_to_string) - r.livepatches - ) - (list string) - ] - module AssertUrlIsValid = Generic.MakeStateless (struct module Io = struct type input_t = string * string list @@ -520,10 +408,10 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct updates_info: (string * UpdateInfo.t) list ; update: Update.t ; upd_ids_of_livepatches: string list - ; upd_ids_of_failed_livepatches: string list + ; kind: Guidance.kind } - type output_t = Guidance.t option + type output_t = Guidance.t list let fields_of_input = Fmt.Dump. @@ -548,37 +436,24 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct |> Printf.sprintf "[%s]" ) string - ; field "upd_ids_of_failed_livepatches" - (fun (r : input_t) -> - r.upd_ids_of_failed_livepatches - |> String.concat ";" - |> Printf.sprintf "[%s]" - ) + ; field "kind" + (fun (r : input_t) -> Guidance.kind_to_string r.kind) string ] let string_of_input_t = Fmt.(str "%a" Dump.(record @@ fields_of_input)) - let string_of_output_t g = - Fmt.(str "%a" Dump.(string)) (UpdateInfo.guidance_to_string g) + let string_of_output_t l = + Fmt.(str "%a" Dump.(list string)) (List.map Guidance.to_string l) end - let transform - Io. - { - updates_info - ; update - ; upd_ids_of_livepatches - ; upd_ids_of_failed_livepatches - } = - eval_guidance_for_one_update ~updates_info ~update - ~kind:Guidance.Recommended + let transform Io.{updates_info; update; upd_ids_of_livepatches; kind} = + eval_guidance_for_one_update ~updates_info ~update ~kind ~upd_ids_of_livepatches:(UpdateIdSet.of_list upd_ids_of_livepatches) - ~upd_ids_of_failed_livepatches: - (UpdateIdSet.of_list upd_ids_of_failed_livepatches) let tests = let open Io in + let open Guidance in `QuickAndAutoDocumented [ (* Update ID in update can't be found in updateinfo list *) @@ -600,9 +475,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Mandatory } - , None + , [] ) ; (* Update ID in update can't be found in updateinfo list *) ( { @@ -614,13 +489,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.EvacuateHost - ; abs_guidance= Some Guidance.RebootHost + ; guidance= + [ + (Mandatory, [EvacuateHost]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -632,13 +511,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.EvacuateHost - ; abs_guidance= Some Guidance.RebootHost + ; guidance= + [ + (Mandatory, [EvacuateHost]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -661,9 +544,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Mandatory } - , None + , [] ) ; (* No update ID in update *) ( { @@ -675,13 +558,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.EvacuateHost - ; abs_guidance= Some Guidance.RebootHost + ; guidance= + [ + (Mandatory, [EvacuateHost]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -703,9 +590,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , None + , [] ) ; (* Empty applicabilities *) ( { @@ -717,13 +604,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -735,13 +626,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -763,9 +658,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , Some Guidance.RebootHost + , [RebootHost] ) ; (* Matched applicability *) ( { @@ -777,13 +672,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -795,8 +694,13 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RestartDeviceModel - ; abs_guidance= None + ; guidance= + [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [ Applicability. @@ -814,7 +718,6 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -836,9 +739,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Mandatory } - , Some Guidance.RestartDeviceModel + , [RestartDeviceModel] ) ; (* Matched in multiple applicabilities *) ( { @@ -850,13 +753,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -868,8 +775,13 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RestartDeviceModel - ; abs_guidance= None + ; guidance= + [ + (Mandatory, [EvacuateHost]) + ; (Recommended, [RestartDeviceModel]) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [ Applicability. @@ -898,7 +810,6 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -920,9 +831,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , Some Guidance.RestartDeviceModel + , [RestartDeviceModel] ) ; (* No matched applicability *) ( { @@ -934,13 +845,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -952,8 +867,13 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RestartDeviceModel - ; abs_guidance= None + ; guidance= + [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [ Applicability. @@ -971,7 +891,6 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -993,9 +912,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Mandatory } - , None + , [] ) ; (* Unmatched arch *) ( { @@ -1007,13 +926,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -1025,8 +948,13 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RestartDeviceModel - ; abs_guidance= None + ; guidance= + [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [ Applicability. @@ -1043,7 +971,6 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -1065,9 +992,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Mandatory } - , None + , [] ) ; (* Matched in multiple applicabilities with epoch *) ( { @@ -1079,13 +1006,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -1097,8 +1028,13 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RestartDeviceModel - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RestartDeviceModel; RestartToolstack]) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [ Applicability. @@ -1127,7 +1063,6 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -1149,11 +1084,11 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= [] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , Some Guidance.RestartDeviceModel + , [RestartDeviceModel; RestartToolstack] ) - ; (* livepatch_guidance: Some _ *) + ; (* livepatch_guidance *) ( { updates_info= [ @@ -1163,13 +1098,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, [RestartDeviceModel; RestartToolstack]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartDeviceModel ; livepatches= [ LivePatch. @@ -1213,11 +1152,11 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= ["UPDATE-0000"] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , Some Guidance.RestartDeviceModel + , [RestartDeviceModel; RestartToolstack] ) - ; (* livepatch_guidance - None *) + ; (* livepatch_guidance - empty *) ( { updates_info= [ @@ -1227,13 +1166,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [ LivePatch. @@ -1267,9 +1210,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= ["UPDATE-0000"] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , None + , [] ) ; (* livepatch_guidance: livepatch does not come from RPM update UPDATE-0001. * And the RPM update UPDATE-0001 requires RebootHost. @@ -1283,13 +1226,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, [RestartDeviceModel]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartDeviceModel ; livepatches= [ LivePatch. @@ -1313,13 +1260,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, [RestartToolstack]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartToolstack ; livepatches= [ LivePatch. @@ -1353,9 +1304,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= ["UPDATE-0000"] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , Some Guidance.RebootHost + , [RebootHost] ) ; (* livepatch_guidance: livepatch comes from the RPM update UPDATE-001 *) ( { @@ -1367,13 +1318,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, [RestartDeviceModel]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartDeviceModel ; livepatches= [ LivePatch. @@ -1397,13 +1352,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, [RestartToolstack]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartToolstack ; livepatches= [ LivePatch. @@ -1447,11 +1406,11 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= ["UPDATE-0001"] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , Some Guidance.RestartToolstack + , [RestartToolstack] ) - ; (* livepatch_guidance: latest update doesn't have livepatch and recommendedGuidance is None *) + ; (* livepatch_guidance: latest update doesn't have livepatch and recommended is empty *) ( { updates_info= [ @@ -1461,13 +1420,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, [RestartDeviceModel]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [ LivePatch. @@ -1491,13 +1454,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RestartToolstack]) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -1519,11 +1486,11 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= ["UPDATE-0000"] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , None + , [RestartToolstack] ) - ; (* livepatch_guidance: latest update doesn't have livepatch and recommendedGuidance is RebootHost *) + ; (* livepatch_guidance: latest update doesn't have livepatch but recommended is RebootHost *) ( { updates_info= [ @@ -1533,13 +1500,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, [RestartToolstack]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [ LivePatch. @@ -1563,13 +1534,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -1591,11 +1566,11 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= ["UPDATE-0000"] - ; upd_ids_of_failed_livepatches= [] + ; kind= Recommended } - , Some Guidance.RebootHost + , [RebootHost] ) - ; (* livepatch_guidance: failure of applying livepatch *) + ; (* livepatch_guidance: is overwhelmed by aother update *) ( { updates_info= [ @@ -1605,13 +1580,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RestartVM]) + ; (Full, []) + ; (Livepatch, [RestartVM]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartToolstack ; livepatches= [ LivePatch. @@ -1645,13 +1624,17 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, [RebootHost]) + ; (Full, []) + ; (Livepatch, [RestartDeviceModel]) + ] ; guidance_applicabilities= [] (* No applicabilities *) ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [ LivePatch. @@ -1685,9 +1668,9 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; repository= "regular" } ; upd_ids_of_livepatches= ["UPDATE-0000"] - ; upd_ids_of_failed_livepatches= ["UPDATE-0001"] + ; kind= Recommended } - , None + , [RebootHost] ) ] end) @@ -2000,46 +1983,70 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct id= "" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [(Mandatory, []); (Recommended, []); (Full, []); (Livepatch, [])] ; guidance_applicabilities= [] ; spec_info= "special info" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None } let updates_info = + let open Guidance in [ ( "UPDATE-0000" , { updateinfo with id= "UPDATE-0000" - ; rec_guidance= Some Guidance.EvacuateHost + ; guidance= + [ + (Mandatory, [EvacuateHost]) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] } ) ; ( "UPDATE-0001" , { updateinfo with id= "UPDATE-0001" - ; rec_guidance= Some Guidance.RebootHost + ; guidance= + [ + (Mandatory, [RebootHost]) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] } ) ; ( "UPDATE-0002" , { updateinfo with id= "UPDATE-0002" - ; rec_guidance= Some Guidance.RestartDeviceModel + ; guidance= + [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] } ) ; ( "UPDATE-0003" , { updateinfo with id= "UPDATE-0003" - ; rec_guidance= Some Guidance.EvacuateHost + ; guidance= + [ + (Mandatory, [EvacuateHost]) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] } ) ] @@ -2064,8 +2071,14 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct , ( `Assoc [ ("ref", `String host) - ; ("recommended-guidance", `List []) - ; ("absolute-guidance", `List []) + ; ( "guidance" + , `Assoc + [ + ("mandatory", `List []) + ; ("recommended", `List []) + ; ("full", `List []) + ] + ) ; ("RPMS", `List []) ; ("updates", `List []) ; ("livepatches", `List []) @@ -2144,8 +2157,14 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct , ( `Assoc [ ("ref", `String host) - ; ("recommended-guidance", `List [`String "RebootHost"]) - ; ("absolute-guidance", `List []) + ; ( "guidance" + , `Assoc + [ + ("mandatory", `List [`String "RebootHost"]) + ; ("recommended", `List []) + ; ("full", `List []) + ] + ) ; ( "RPMS" , `List [ @@ -2201,8 +2220,14 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct , ( `Assoc [ ("ref", `String host) - ; ("recommended-guidance", `List [`String "RebootHost"]) - ; ("absolute-guidance", `List []) + ; ( "guidance" + , `Assoc + [ + ("mandatory", `List [`String "RebootHost"]) + ; ("recommended", `List []) + ; ("full", `List []) + ] + ) ; ("RPMS", `List [`String "libpath-utils-0.2.2-9.el7.noarch.rpm"]) ; ("updates", `List [`String "UPDATE-0001"]) ; ("livepatches", `List []) @@ -2252,8 +2277,14 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct , ( `Assoc [ ("ref", `String host) - ; ("recommended-guidance", `List [`String "EvacuateHost"]) - ; ("absolute-guidance", `List []) + ; ( "guidance" + , `Assoc + [ + ("mandatory", `List [`String "EvacuateHost"]) + ; ("recommended", `List []) + ; ("full", `List []) + ] + ) ; ("RPMS", `List [`String "libpath-utils-0.2.2-9.el7.noarch.rpm"]) ; ("updates", `List [`String "UPDATE-0003"]) ; ("livepatches", `List []) @@ -2330,8 +2361,14 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct , ( `Assoc [ ("ref", `String host) - ; ("recommended-guidance", `List [`String "RebootHost"]) - ; ("absolute-guidance", `List []) + ; ( "guidance" + , `Assoc + [ + ("mandatory", `List [`String "RebootHost"]) + ; ("recommended", `List []) + ; ("full", `List []) + ] + ) ; ( "RPMS" , `List [ @@ -2414,8 +2451,14 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct , ( `Assoc [ ("ref", `String host) - ; ("recommended-guidance", `List [`String "RebootHost"]) - ; ("absolute-guidance", `List []) + ; ( "guidance" + , `Assoc + [ + ("mandatory", `List [`String "RebootHost"]) + ; ("recommended", `List []) + ; ("full", `List []) + ] + ) ; ( "RPMS" , `List [ @@ -2530,8 +2573,14 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct , ( `Assoc [ ("ref", `String host) - ; ("recommended-guidance", `List [`String "RebootHost"]) - ; ("absolute-guidance", `List []) + ; ( "guidance" + , `Assoc + [ + ("mandatory", `List [`String "RebootHost"]) + ; ("recommended", `List []) + ; ("full", `List []) + ] + ) ; ( "RPMS" , `List [ @@ -2750,52 +2799,725 @@ module ParseUpdateInfoList = Generic.MakeStateless (struct ] end) -module GuidanceSetResortGuidancesTest = Generic.MakeStateless (struct +module GuidanceSetResortTest = Generic.MakeStateless (struct module Io = struct - type input_t = Guidance.guidance_kind * Guidance.t list + type input_t = Guidance.t list type output_t = Guidance.t list - let string_of_input_t (kind, l) = - let kind' = - match kind with - | Guidance.Recommended -> - "Recommended" - | Guidance.Absolute -> - "Absolute" - in - kind' - ^ ", " - ^ Fmt.(str "%a" Dump.(list string)) (List.map Guidance.to_string l) - - let string_of_output_t l = + let string_of_input_t l = Fmt.(str "%a" Dump.(list string)) (List.map Guidance.to_string l) + + let string_of_output_t = string_of_input_t end - let transform (kind, guidances) = + let transform guidances = guidances |> GuidanceSet.of_list - |> GuidanceSet.resort_guidances - ~remove_evacuations:(kind = Guidance.Absolute) + |> GuidanceSet.resort |> GuidanceSet.elements let tests = + let open Guidance in `QuickAndAutoDocumented [ - ((Guidance.Recommended, [Guidance.RebootHost]), [Guidance.RebootHost]) - ; ( (Guidance.Recommended, [Guidance.RebootHost; Guidance.RebootHost]) - , [Guidance.RebootHost] + ([], []) + ; ([EvacuateHost], [EvacuateHost]) + ; ([EvacuateHost; RestartDeviceModel], [EvacuateHost]) + ; ( [EvacuateHost; RestartDeviceModel; RestartToolstack] + , [RestartToolstack; EvacuateHost] + ) + ; ( [EvacuateHost; RestartDeviceModel; RestartToolstack; RebootHost] + , [RebootHost] + ) + ; ([EvacuateHost; RestartDeviceModel; RebootHost], [RebootHost]) + ; ([EvacuateHost; RestartToolstack], [RestartToolstack; EvacuateHost]) + ; ([EvacuateHost; RestartToolstack; RebootHost], [RebootHost]) + ; ([EvacuateHost; RebootHost], [RebootHost]) + ; ([RestartDeviceModel], [RestartDeviceModel]) + ; ( [RestartDeviceModel; RestartToolstack] + , [RestartToolstack; RestartDeviceModel] + ) + ; ([RestartDeviceModel; RestartToolstack; RebootHost], [RebootHost]) + ; ([RestartDeviceModel; RebootHost], [RebootHost]) + ; ([RestartToolstack], [RestartToolstack]) + ; ([RestartToolstack; RebootHost], [RebootHost]) + ; ([RebootHost], [RebootHost]) + ; ([RestartVM], [RestartVM]) + ; ([RestartVM; EvacuateHost], [EvacuateHost; RestartVM]) + ; ( [RestartVM; EvacuateHost; RestartDeviceModel] + , [EvacuateHost; RestartVM] + ) + ; ( [RestartVM; EvacuateHost; RestartDeviceModel; RestartToolstack] + , [RestartToolstack; EvacuateHost; RestartVM] + ) + ; ( [ + RestartVM + ; EvacuateHost + ; RestartDeviceModel + ; RestartToolstack + ; RebootHost + ] + , [RebootHost; RestartVM] + ) + ; ( [RestartVM; EvacuateHost; RestartDeviceModel; RebootHost] + , [RebootHost; RestartVM] ) - ; ( ( Guidance.Recommended - , [Guidance.RebootHost; Guidance.RestartDeviceModel] + ; ( [RestartVM; EvacuateHost; RestartToolstack] + , [RestartToolstack; EvacuateHost; RestartVM] + ) + ; ( [RestartVM; EvacuateHost; RestartToolstack; RebootHost] + , [RebootHost; RestartVM] + ) + ; ([RestartVM; EvacuateHost; RebootHost], [RebootHost; RestartVM]) + ; ([RestartVM; RestartDeviceModel], [RestartVM]) + ; ( [RestartVM; RestartDeviceModel; RestartToolstack] + , [RestartToolstack; RestartVM] + ) + ; ( [RestartVM; RestartDeviceModel; RestartToolstack; RebootHost] + , [RebootHost; RestartVM] + ) + ; ([RestartVM; RestartDeviceModel; RebootHost], [RebootHost; RestartVM]) + ; ([RestartVM; RestartToolstack], [RestartToolstack; RestartVM]) + ; ([RestartVM; RestartToolstack; RebootHost], [RebootHost; RestartVM]) + ; ([RestartVM; RebootHost], [RebootHost; RestartVM]) + ] +end) + +module GuidanceSetReduceTest = Generic.MakeStateless (struct + module Io = struct + type input_t = Guidance.t list * Guidance.t list + + type output_t = Guidance.t list + + let string_of_input_t (l1, l2) = + Fmt.( + str "%a + %a" + Dump.(list string) + (List.map Guidance.to_string l1) + Dump.(list string) + (List.map Guidance.to_string l2) + ) + + let string_of_output_t l = + Fmt.(str "%a" Dump.(list string)) (List.map Guidance.to_string l) + end + + let transform (l1, l2) = + let open GuidanceSet in + reduce (of_list l1) (of_list l2) |> elements + + let tests = + let open Guidance in + `QuickAndAutoDocumented + [ + (([], []), []) + ; (([], [EvacuateHost]), [EvacuateHost]) + ; (([], [RebootHost]), [RebootHost]) + ; (([], [RestartDeviceModel]), [RestartDeviceModel]) + ; ( ([], [RestartToolstack; EvacuateHost]) + , [RestartToolstack; EvacuateHost] + ) + ; ( ([], [RestartToolstack; RestartDeviceModel]) + , [RestartToolstack; RestartDeviceModel] + ) + ; (([], [RestartToolstack]), [RestartToolstack]) + ; (([EvacuateHost], [EvacuateHost]), []) + ; (([EvacuateHost], [RebootHost]), [RebootHost]) + ; (([EvacuateHost], [RestartDeviceModel]), []) + ; (([EvacuateHost], [RestartToolstack; EvacuateHost]), [RestartToolstack]) + ; ( ([EvacuateHost], [RestartToolstack; RestartDeviceModel]) + , [RestartToolstack] + ) + ; (([EvacuateHost], [RestartToolstack]), [RestartToolstack]) + ; (([EvacuateHost], []), []) + ; (([RebootHost], [EvacuateHost]), []) + ; (([RebootHost], [RebootHost]), []) + ; (([RebootHost], [RestartDeviceModel]), []) + ; (([RebootHost], [RestartToolstack; EvacuateHost]), []) + ; (([RebootHost], [RestartToolstack; RestartDeviceModel]), []) + ; (([RebootHost], [RestartToolstack]), []) + ; (([RebootHost], []), []) + ; (([RestartDeviceModel], [EvacuateHost]), [EvacuateHost]) + ; (([RestartDeviceModel], [RebootHost]), [RebootHost]) + ; (([RestartDeviceModel], [RestartDeviceModel]), []) + ; ( ([RestartDeviceModel], [RestartToolstack; EvacuateHost]) + , [RestartToolstack; EvacuateHost] + ) + ; ( ([RestartDeviceModel], [RestartToolstack; RestartDeviceModel]) + , [RestartToolstack] + ) + ; (([RestartDeviceModel], [RestartToolstack]), [RestartToolstack]) + ; (([RestartDeviceModel], []), []) + ; (([RestartToolstack; EvacuateHost], [EvacuateHost]), []) + ; (([RestartToolstack; EvacuateHost], [RebootHost]), [RebootHost]) + ; (([RestartToolstack; EvacuateHost], [RestartDeviceModel]), []) + ; ( ([RestartToolstack; EvacuateHost], [RestartToolstack; EvacuateHost]) + , [] + ) + ; ( ( [RestartToolstack; EvacuateHost] + , [RestartToolstack; RestartDeviceModel] ) - , [Guidance.RebootHost] + , [] ) - ; ((Guidance.Absolute, [Guidance.EvacuateHost]), []) - ; ( ( Guidance.Recommended - , [Guidance.EvacuateHost; Guidance.RestartDeviceModel] + ; (([RestartToolstack; EvacuateHost], [RestartToolstack]), []) + ; (([RestartToolstack; EvacuateHost], []), []) + ; ( ([RestartToolstack; RestartDeviceModel], [EvacuateHost]) + , [EvacuateHost] + ) + ; (([RestartToolstack; RestartDeviceModel], [RebootHost]), [RebootHost]) + ; (([RestartToolstack; RestartDeviceModel], [RestartDeviceModel]), []) + ; ( ( [RestartToolstack; RestartDeviceModel] + , [RestartToolstack; EvacuateHost] + ) + , [EvacuateHost] + ) + ; ( ( [RestartToolstack; RestartDeviceModel] + , [RestartToolstack; RestartDeviceModel] + ) + , [] + ) + ; (([RestartToolstack; RestartDeviceModel], [RestartToolstack]), []) + ; (([RestartToolstack; RestartDeviceModel], []), []) + ; (([RestartToolstack], [EvacuateHost]), [EvacuateHost]) + ; (([RestartToolstack], [RebootHost]), [RebootHost]) + ; (([RestartToolstack], [RestartDeviceModel]), [RestartDeviceModel]) + ; (([RestartToolstack], [RestartToolstack; EvacuateHost]), [EvacuateHost]) + ; ( ([RestartToolstack], [RestartToolstack; RestartDeviceModel]) + , [RestartDeviceModel] + ) + ; (([RestartToolstack], [RestartToolstack]), []) + ; (([RestartToolstack], []), []) + ; (([RestartVM; EvacuateHost], [EvacuateHost]), []) + ; (([RestartVM; EvacuateHost], [RebootHost; RestartVM]), [RebootHost]) + ; (([RestartVM; EvacuateHost], [RebootHost]), [RebootHost]) + ; (([RestartVM; EvacuateHost], [RestartDeviceModel]), []) + ; ( ([RestartVM; EvacuateHost], [RestartToolstack; EvacuateHost]) + , [RestartToolstack] + ) + ; ( ([RestartVM; EvacuateHost], [RestartToolstack; RestartDeviceModel]) + , [RestartToolstack] + ) + ; (([RestartVM; EvacuateHost], [RestartToolstack]), [RestartToolstack]) + ; (([RestartVM; EvacuateHost], [RestartVM; EvacuateHost]), []) + ; ( ( [RestartVM; EvacuateHost] + , [RestartVM; RestartToolstack; EvacuateHost] + ) + , [RestartToolstack] + ) + ; ( ([RestartVM; EvacuateHost], [RestartVM; RestartToolstack]) + , [RestartToolstack] + ) + ; (([RestartVM; EvacuateHost], [RestartVM]), []) + ; (([RestartVM; EvacuateHost], []), []) + ; (([RestartVM; RestartToolstack; EvacuateHost], [EvacuateHost]), []) + ; ( ([RestartVM; RestartToolstack; EvacuateHost], [RebootHost; RestartVM]) + , [RebootHost] + ) + ; ( ([RestartVM; RestartToolstack; EvacuateHost], [RebootHost]) + , [RebootHost] + ) + ; (([RestartVM; RestartToolstack; EvacuateHost], [RestartDeviceModel]), []) + ; ( ( [RestartVM; RestartToolstack; EvacuateHost] + , [RestartToolstack; EvacuateHost] + ) + , [] + ) + ; ( ( [RestartVM; RestartToolstack; EvacuateHost] + , [RestartToolstack; RestartDeviceModel] + ) + , [] + ) + ; (([RestartVM; RestartToolstack; EvacuateHost], [RestartToolstack]), []) + ; ( ( [RestartVM; RestartToolstack; EvacuateHost] + , [RestartVM; EvacuateHost] + ) + , [] + ) + ; ( ( [RestartVM; RestartToolstack; EvacuateHost] + , [RestartVM; RestartToolstack; EvacuateHost] + ) + , [] + ) + ; ( ( [RestartVM; RestartToolstack; EvacuateHost] + , [RestartVM; RestartToolstack] ) - , [Guidance.EvacuateHost] + , [] + ) + ; (([RestartVM; RestartToolstack; EvacuateHost], [RestartVM]), []) + ; (([RestartVM; RestartToolstack; EvacuateHost], []), []) + ; (([RestartVM; RestartToolstack], [EvacuateHost]), [EvacuateHost]) + ; (([RestartVM; RestartToolstack], [RebootHost; RestartVM]), [RebootHost]) + ; (([RestartVM; RestartToolstack], [RebootHost]), [RebootHost]) + ; (([RestartVM; RestartToolstack], [RestartDeviceModel]), []) + ; ( ([RestartVM; RestartToolstack], [RestartToolstack; EvacuateHost]) + , [EvacuateHost] + ) + ; ( ([RestartVM; RestartToolstack], [RestartToolstack; RestartDeviceModel]) + , [] + ) + ; (([RestartVM; RestartToolstack], [RestartToolstack]), []) + ; ( ([RestartVM; RestartToolstack], [RestartVM; EvacuateHost]) + , [EvacuateHost] + ) + ; ( ( [RestartVM; RestartToolstack] + , [RestartVM; RestartToolstack; EvacuateHost] + ) + , [EvacuateHost] + ) + ; (([RestartVM; RestartToolstack], [RestartVM; RestartToolstack]), []) + ; (([RestartVM; RestartToolstack], [RestartVM]), []) + ; (([RestartVM; RestartToolstack], []), []) + ; (([RestartVM], [EvacuateHost]), [EvacuateHost]) + ; (([RestartVM], [RebootHost; RestartVM]), [RebootHost]) + ; (([RestartVM], [RebootHost]), [RebootHost]) + ; (([RestartVM], [RestartDeviceModel]), []) + ; ( ([RestartVM], [RestartToolstack; EvacuateHost]) + , [RestartToolstack; EvacuateHost] + ) + ; ( ([RestartVM], [RestartToolstack; RestartDeviceModel]) + , [RestartToolstack] + ) + ; (([RestartVM], [RestartToolstack]), [RestartToolstack]) + ; (([RestartVM], [RestartVM; EvacuateHost]), [EvacuateHost]) + ; ( ([RestartVM], [RestartVM; RestartToolstack; EvacuateHost]) + , [RestartToolstack; EvacuateHost] + ) + ; (([RestartVM], [RestartVM; RestartToolstack]), [RestartToolstack]) + ; (([RestartVM], [RestartVM]), []) + ; (([RestartVM], []), []) + ; (([], [RestartVM; EvacuateHost]), [EvacuateHost; RestartVM]) + ; ( ([], [RestartVM; RestartToolstack; EvacuateHost]) + , [RestartToolstack; EvacuateHost; RestartVM] + ) + ; (([], [RestartVM; RestartToolstack]), [RestartToolstack; RestartVM]) + ; (([], [RestartVM]), [RestartVM]) + ] +end) + +module GuidanceSetReduceCascadedListTest = Generic.MakeStateless (struct + module Io = struct + type input_t = (Guidance.kind * Guidance.t list) list + + type output_t = input_t + + let string_of_input_t l = + let string_of_kind_guidances (kind, gs) = + Fmt.( + str "%a: %a" + Dump.(string) + (Guidance.kind_to_string kind) + Dump.(list string) + (List.map Guidance.to_string gs) + ) + in + Fmt.(str "%a" Dump.(list string)) (List.map string_of_kind_guidances l) + + let string_of_output_t = string_of_input_t + end + + let transform l = + l + |> List.map (fun (k, l') -> (k, GuidanceSet.of_list l')) + |> GuidanceSet.reduce_cascaded_list + |> List.map (fun (k, s') -> (k, GuidanceSet.elements s')) + + let tests = + let open Guidance in + `QuickAndAutoDocumented + [ + ([], []) + ; ( [(Mandatory, []); (Recommended, []); (Full, [])] + , [(Mandatory, []); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, [RestartToolstack; RestartDeviceModel]) + ] + , [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, [RestartToolstack; RestartDeviceModel]) + ] + ) + ; ( [ + (Mandatory, []) + ; (Recommended, [RestartToolstack]) + ; (Full, [RestartDeviceModel]) + ] + , [ + (Mandatory, []) + ; (Recommended, [RestartToolstack]) + ; (Full, [RestartDeviceModel]) + ] + ) + ; ( [ + (Mandatory, []) + ; (Recommended, [RestartToolstack]) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, []) + ; (Recommended, [RestartToolstack]) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, []) + ; (Recommended, [RestartToolstack; RestartDeviceModel]) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, []) + ; (Recommended, [RestartToolstack; RestartDeviceModel]) + ; (Full, [RebootHost]) + ] + ) + ; ( [(Mandatory, [RestartToolstack]); (Recommended, []); (Full, [])] + , [(Mandatory, [RestartToolstack]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartToolstack]) + ; (Recommended, []) + ; (Full, [RestartToolstack]) + ] + , [(Mandatory, [RestartToolstack]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartToolstack]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartToolstack]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack; RestartDeviceModel]) + ; (Recommended, []) + ; (Full, []) + ] + , [ + (Mandatory, [RestartToolstack; RestartDeviceModel]) + ; (Recommended, []) + ; (Full, []) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack; RestartDeviceModel]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartToolstack; RestartDeviceModel]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, [RestartDeviceModel]) + ] + , [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, []) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, [RestartDeviceModel]) + ; (Full, [RestartToolstack]) + ] + , [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, []) + ] + ) + ; ( [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, [RestartToolstack]) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, [RestartToolstack]) + ; (Full, [RebootHost]) + ] + ) + ; ( [(Mandatory, [RebootHost]); (Recommended, []); (Full, [])] + , [(Mandatory, [RebootHost]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, [RestartToolstack; RestartDeviceModel]) + ] + , [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, []) + ; (Full, [RestartToolstack]) + ] + ) + ; ( [ + (Mandatory, [RebootHost]) + ; (Recommended, []) + ; (Full, [RestartToolstack; RestartDeviceModel]) + ] + , [(Mandatory, [RebootHost]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RebootHost]) + ; (Recommended, [RestartDeviceModel]) + ; (Full, [RestartToolstack]) + ] + , [(Mandatory, [RebootHost]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [EvacuateHost]) + ; (Recommended, []) + ; (Full, [RestartDeviceModel]) + ] + , [(Mandatory, [EvacuateHost]); (Recommended, []); (Full, [])] + ) + ; ( [(Mandatory, [EvacuateHost]); (Recommended, []); (Full, [RebootHost])] + , [(Mandatory, [EvacuateHost]); (Recommended, []); (Full, [RebootHost])] + ) + ; ( [ + (Mandatory, [RebootHost; RestartVM]) + ; (Recommended, []) + ; (Full, [RestartVM]) + ] + , [(Mandatory, [RebootHost; RestartVM]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, [RebootHost; RestartVM]) + ] + , [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, [RebootHost; RestartVM]) + ] + ) + ; ( [ + (Mandatory, [RebootHost; RestartVM]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RebootHost; RestartVM]) + ] + , [(Mandatory, [RebootHost; RestartVM]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RebootHost]) + ; (Recommended, [RestartVM; EvacuateHost]) + ; (Full, [RebootHost]) + ] + , [(Mandatory, [RebootHost]); (Recommended, [RestartVM]); (Full, [])] + ) + ; ( [ + (Mandatory, [RebootHost]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RestartVM]) + ] + , [(Mandatory, [RebootHost]); (Recommended, []); (Full, [RestartVM])] + ) + ; ( [ + (Mandatory, [RebootHost; RestartVM]) + ; (Recommended, [RestartToolstack]) + ; (Full, [RebootHost; RestartVM]) + ] + , [(Mandatory, [RebootHost; RestartVM]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartToolstack]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RestartVM]) + ] + , [ + (Mandatory, [RestartToolstack]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RestartVM]) + ] + ) + ; ( [ + (Mandatory, [RestartVM; RestartToolstack]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartToolstack; RestartVM]) + ; (Recommended, []) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, [RestartVM]) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, [RestartVM]) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RebootHost; RestartVM]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RebootHost]) + ] + , [(Mandatory, [RebootHost; RestartVM]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartVM; RestartToolstack]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RebootHost; RestartVM]) + ] + , [ + (Mandatory, [RestartToolstack; RestartVM]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, [RestartVM]) + ] + , [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, [RestartVM]) + ] + ) + ; ( [ + (Mandatory, [RestartVM]) + ; (Recommended, [RestartToolstack]) + ; (Full, [RebootHost; RestartVM]) + ] + , [ + (Mandatory, [RestartVM]) + ; (Recommended, [RestartToolstack]) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RebootHost]) + ; (Recommended, []) + ; (Full, [RebootHost; RestartVM]) + ] + , [(Mandatory, [RebootHost]); (Recommended, []); (Full, [RestartVM])] + ) + ; ( [ + (Mandatory, [RebootHost]) + ; (Recommended, [RestartDeviceModel]) + ; (Full, [RestartVM]) + ] + , [(Mandatory, [RebootHost]); (Recommended, []); (Full, [RestartVM])] + ) + ; ( [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, [RestartToolstack]) + ; (Full, [RestartVM]) + ] + , [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, [RestartToolstack]) + ; (Full, [RestartVM]) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack]) + ; (Recommended, [RestartVM; EvacuateHost]) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartToolstack]) + ; (Recommended, [EvacuateHost; RestartVM]) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RebootHost]) + ; (Recommended, [RestartToolstack; EvacuateHost]) + ; (Full, [RebootHost; RestartVM]) + ] + , [(Mandatory, [RebootHost]); (Recommended, []); (Full, [RestartVM])] + ) + ; ( [ + (Mandatory, [RestartVM]) + ; (Recommended, [RestartDeviceModel]) + ; (Full, [RestartVM]) + ] + , [(Mandatory, [RestartVM]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartVM; RestartToolstack]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartToolstack; RestartVM]) + ; (Recommended, [EvacuateHost]) + ; (Full, [RebootHost]) + ] + ) + ; ( [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, [RebootHost]) + ; (Full, [RestartVM]) + ] + , [ + (Mandatory, [RestartDeviceModel]) + ; (Recommended, [RebootHost]) + ; (Full, [RestartVM]) + ] + ) + ; ( [ + (Mandatory, [RebootHost; RestartVM]) + ; (Recommended, [RestartToolstack; RestartDeviceModel]) + ; (Full, [RebootHost; RestartVM]) + ] + , [(Mandatory, [RebootHost; RestartVM]); (Recommended, []); (Full, [])] + ) + ; ( [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, [RestartDeviceModel]) + ; (Full, [RestartVM]) + ] + , [ + (Mandatory, [RestartToolstack; EvacuateHost]) + ; (Recommended, []) + ; (Full, [RestartVM]) + ] + ) + ; ( [ + (Mandatory, [RestartToolstack]) + ; (Recommended, [RestartVM]) + ; (Full, [RebootHost]) + ] + , [ + (Mandatory, [RestartToolstack]) + ; (Recommended, [RestartVM]) + ; (Full, [RebootHost]) + ] ) ] end) @@ -3141,13 +3863,12 @@ module PruneUpdateInfoForLivepatches = Generic.MakeStateless (struct id= "UPDATE-00" ; summary= "SUMMARY" ; description= "DESCRIPTION" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [(Mandatory, []); (Recommended, []); (Full, []); (Livepatch, [])] ; guidance_applicabilities= [] ; spec_info= "SPEC_INFO" ; url= "URL" ; update_type= "UPDATE_TYPE" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -3628,18 +4349,253 @@ module GetLatestUpdatesFromRedundancy = Generic.MakeStateless (struct ] end) +module SetPendingGuidance = Generic.MakeStateless (struct + module Io = struct + (* ([host pending guidance list], [VMs pending guidance lists]), [coming guidance list] *) + type input_t = + (Guidance.t list * (string * Guidance.t list) list) * Guidance.t list + + (* ([host pending guidance list], [VMs pending guidance lists]) *) + type output_t = Guidance.t list * (string * Guidance.t list) list + + let string_of_pending (host_pending, vms_pending) = + Fmt.( + str "Host: %a; VMs: %a" + Dump.(list string) + (List.map Guidance.to_string host_pending) + Dump.(list (pair string (list string))) + (List.map + (fun (vm, l) -> (vm, List.map Guidance.to_string l)) + vms_pending + ) + ) + + let string_of_input_t (pending, coming) = + Fmt.( + str "Pending: %s. Coming: %a" + (string_of_pending pending) + Dump.(list string) + (List.map Guidance.to_string coming) + ) + + let string_of_output_t = string_of_pending + end + + let transform ((host_pending, vms_pending), coming) = + (* Use two hash tables to simulate the host's pending list and the VMs' pending lists *) + let host_tbl : + ( string + , [ `reboot_host + | `restart_toolstack + | `reboot_host_on_livepatch_failure + | `reboot_host_on_xen_livepatch_failure + | `reboot_host_on_kernel_livepatch_failure ] + list + ) + Hashtbl.t = + Hashtbl.create 1 + in + let vms_tbl : (string, [`restart_device_model | `restart_vm] list) Hashtbl.t + = + Hashtbl.create 3 + in + (* Only one host in the table *) + let host_ref = "host_ref" in + let open Guidance in + let host_to_pending = function + | RebootHost -> + Some `reboot_host + | RebootHostOnLivePatchFailure -> + Some `reboot_host_on_livepatch_failure + | RebootHostOnXenLivePatchFailure -> + Some `reboot_host_on_xen_livepatch_failure + | RebootHostOnKernelLivePatchFailure -> + Some `reboot_host_on_kernel_livepatch_failure + | RestartToolstack -> + Some `restart_toolstack + | _ -> + None + in + let vm_to_pending = function + | RestartDeviceModel -> + Some `restart_device_model + | RestartVM -> + Some `restart_vm + | _ -> + None + in + let to_guidance = Guidance.of_pending_guidance in + Hashtbl.add host_tbl host_ref (List.filter_map host_to_pending host_pending) ; + let vm_mapper (vm_ref, l) = (vm_ref, List.filter_map vm_to_pending l) in + Hashtbl.add_seq vms_tbl (List.to_seq (List.map vm_mapper vms_pending)) ; + let ops = + let host_get () = + Hashtbl.find host_tbl host_ref |> List.map to_guidance + in + let host_add value = + Hashtbl.find host_tbl host_ref + |> List.cons value + |> Hashtbl.replace host_tbl host_ref + in + let host_remove value = + Hashtbl.find host_tbl host_ref + |> List.filter (fun g -> g <> value) + |> Hashtbl.replace host_tbl host_ref + in + let vms_get () = + Hashtbl.to_seq vms_tbl + |> List.of_seq + |> List.map (fun (vm_ref, l) -> (vm_ref, List.map to_guidance l)) + in + let vm_add vm_ref value = + Hashtbl.find vms_tbl vm_ref + |> List.cons value + |> Hashtbl.replace vms_tbl vm_ref + in + let vm_remove vm_ref value = + Hashtbl.find vms_tbl vm_ref + |> List.filter (fun g -> g <> value) + |> Hashtbl.replace vms_tbl vm_ref + in + {host_get; host_add; host_remove; vms_get; vm_add; vm_remove} + in + (* transform *) + set_pending_guidances ~ops ~coming ; + (* return result *) + ( ops.host_get () + |> List.sort (fun g1 g2 -> String.compare (to_string g1) (to_string g2)) + , ops.vms_get () |> List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) + ) + + let tests = + let open Guidance in + `QuickAndAutoDocumented + [ + ((([], []), []), ([], [])) + ; ((([], []), [RebootHost]), ([RebootHost], [])) + ; ( (([], [("vm1", [RestartDeviceModel]); ("vm2", [])]), [RebootHost]) + , ([RebootHost], [("vm1", [RestartDeviceModel]); ("vm2", [])]) + ) + ; ((([], []), [RestartDeviceModel]), ([], [])) + ; ( (([RebootHost], [("vm1", []); ("vm2", [])]), [RebootHost]) + , ([RebootHost], [("vm1", []); ("vm2", [])]) + ) + ; ( (([RestartToolstack], [("vm1", []); ("vm2", [])]), [RebootHost]) + , ([RebootHost; RestartToolstack], [("vm1", []); ("vm2", [])]) + ) + ; ( ( ([RestartToolstack], [("vm1", [RestartDeviceModel]); ("vm2", [])]) + , [RebootHost] + ) + , ( [RebootHost; RestartToolstack] + , [("vm1", [RestartDeviceModel]); ("vm2", [])] + ) + ) + ; ( ( ([RestartToolstack], [("vm1", [RestartDeviceModel]); ("vm2", [])]) + , [RestartDeviceModel] + ) + , ( [RestartToolstack] + , [("vm1", [RestartDeviceModel]); ("vm2", [RestartDeviceModel])] + ) + ) + ; ( (([RebootHostOnLivePatchFailure], [("vm1", [])]), [RebootHost]) + , ([RebootHost; RebootHostOnLivePatchFailure], [("vm1", [])]) + ) + ; ( (([RebootHost], [("vm1", [])]), [RebootHostOnLivePatchFailure]) + , ([RebootHost; RebootHostOnLivePatchFailure], [("vm1", [])]) + ) + ; ( ( ( [] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + , [RebootHost] + ) + , ( [RebootHost] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + ) + ; ( ( ( [RestartToolstack] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + , [RebootHost] + ) + , ( [RebootHost; RestartToolstack] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + ) + ; ( ( ( [RestartToolstack] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + , [RestartToolstack] + ) + , ( [RestartToolstack] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + ) + ; ( ( ( [RestartToolstack] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + , [RestartDeviceModel] + ) + , ( [RestartToolstack] + , [ + ("vm1", [RestartDeviceModel]) + ; ("vm2", [RestartDeviceModel]) + ; ("vm3", [RestartDeviceModel; RestartVM]) + ] + ) + ) + ; ( ( ( [RestartToolstack] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + , [RestartVM] + ) + , ( [RestartToolstack] + , [ + ("vm1", [RestartVM]) + ; ("vm2", [RestartVM; RestartDeviceModel]) + ; ("vm3", [RestartVM]) + ] + ) + ) + ; ( ( ( [RestartToolstack; RebootHostOnXenLivePatchFailure] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + , [RestartToolstack] + ) + , ( [RebootHostOnXenLivePatchFailure; RestartToolstack] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + ) + ; ( ( ( [RebootHost; RebootHostOnKernelLivePatchFailure] + , [("vm1", []); ("vm2", [RestartDeviceModel]); ("vm3", [RestartVM])] + ) + , [RestartToolstack; RestartVM] + ) + , ( [RebootHost; RebootHostOnKernelLivePatchFailure; RestartToolstack] + , [ + ("vm1", [RestartVM]) + ; ("vm2", [RestartVM; RestartDeviceModel]) + ; ("vm3", [RestartVM]) + ] + ) + ) + ] +end) + let tests = make_suite "repository_helpers_" [ ("update_of_json", UpdateOfJsonTest.tests) - ; ("assert_valid_guidances", GuidanceSetAssertValidGuidanceTest.tests) ; ("assert_url_is_valid", AssertUrlIsValid.tests) ; ("write_yum_config", WriteYumConfig.tests) ; ("eval_guidance_for_one_update", EvalGuidanceForOneUpdate.tests) ; ("get_update_in_json", GetUpdateInJson.tests) ; ("consolidate_updates_of_host", ConsolidateUpdatesOfHost.tests) ; ("parse_updateinfo_list", ParseUpdateInfoList.tests) - ; ("resort_guidances", GuidanceSetResortGuidancesTest.tests) + ; ("guidance_set_resort", GuidanceSetResortTest.tests) + ; ("guidance_set_reduce", GuidanceSetReduceTest.tests) + ; ( "guidance_set_reduce_cascaded_list" + , GuidanceSetReduceCascadedListTest.tests + ) ; ("prune_accumulative_updates", PruneAccumulativeUpdates.tests) ; ("prune_updateinfo_for_livepatches", PruneUpdateInfoForLivepatches.tests) ; ( "parse_output_of_yum_upgrade_dry_run" @@ -3648,6 +4604,7 @@ let tests = ; ( "get_latest_updates_from_redundancy" , GetLatestUpdatesFromRedundancy.tests ) + ; ("set_pending_guidances", SetPendingGuidance.tests) ] let () = Alcotest.run "Repository Helpers" tests diff --git a/ocaml/tests/test_updateinfo.ml b/ocaml/tests/test_updateinfo.ml index b0a6142f1ca..f37e374256c 100644 --- a/ocaml/tests/test_updateinfo.ml +++ b/ocaml/tests/test_updateinfo.ml @@ -422,11 +422,8 @@ let fields_of_updateinfo = field "id" (fun (r : UpdateInfo.t) -> r.id) string ; field "summary" (fun (r : UpdateInfo.t) -> r.summary) string ; field "description" (fun (r : UpdateInfo.t) -> r.description) string - ; field "rec_guidance" - (fun (r : UpdateInfo.t) -> UpdateInfo.guidance_to_string r.rec_guidance) - string - ; field "abs_guidance" - (fun (r : UpdateInfo.t) -> UpdateInfo.guidance_to_string r.abs_guidance) + ; field "guidance" + (fun (r : UpdateInfo.t) -> GuidanceInUpdateInfo.to_string r.guidance) string ; field "guidance_applicabilities" (fun (r : UpdateInfo.t) -> @@ -436,11 +433,6 @@ let fields_of_updateinfo = ; field "spec_info" (fun (r : UpdateInfo.t) -> r.spec_info) string ; field "url" (fun (r : UpdateInfo.t) -> r.url) string ; field "update_type" (fun (r : UpdateInfo.t) -> r.update_type) string - ; field "livepatch_guidance" - (fun (r : UpdateInfo.t) -> - UpdateInfo.guidance_to_string r.livepatch_guidance - ) - string ; field "livepatches" (fun (r : UpdateInfo.t) -> List.map @@ -479,6 +471,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct try Ok (UpdateInfo.of_xml (Xml.parse_string input)) with e -> Error e let tests = + let open Guidance in `QuickAndAutoDocumented [ (* No "updates" node *) @@ -561,13 +554,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -624,13 +621,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" @@ -674,13 +675,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" @@ -693,13 +698,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0001" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:50Z" @@ -708,7 +717,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ) ] ) - ; (* Single update with guidances *) + ; (* Single update with deprecated guidances only *) ( {| @@ -751,8 +760,13 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RestartDeviceModel - ; abs_guidance= Some Guidance.RebootHost + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] ; guidance_applicabilities= [ Applicability. @@ -777,7 +791,6 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" @@ -786,7 +799,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ) ] ) - ; (* Single update with new guidances *) + ; (* Single update with unknown guidance *) ( {| @@ -798,6 +811,18 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct https://update.details.info NewGuidance NewGuidance + + + NewGuidance + + + NewGuidance + RestartVM + + + NewGuidance + + xsconsole @@ -829,8 +854,13 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= Some Guidance.RebootHost - ; abs_guidance= Some Guidance.RebootHost + ; guidance= + [ + (Recommended, [RebootHost]) + ; (Full, [RebootHost; RestartVM]) + ; (Mandatory, [RebootHost]) + ; (Livepatch, []) + ] ; guidance_applicabilities= [ Applicability. @@ -855,7 +885,6 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= None ; livepatches= [] ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" @@ -864,7 +893,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ) ] ) - ; (* Single update with livepatches and livepatch_guidance *) + ; (* Single update with livepatches and livepatch guidance *) ( {| @@ -874,6 +903,11 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct description special information https://update.details.info + + + RestartToolstack + + RestartToolstack @@ -893,13 +927,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Livepatch, [RestartToolstack]) + ; (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartToolstack ; livepatches= [ LivePatch. @@ -930,7 +968,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ) ] ) - ; (* Single update with livepatches and new livepatch_guidance *) + ; (* Single update with livepatches and unknown livepatch guidance *) ( {| @@ -941,6 +979,11 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct special information https://update.details.info + + + NewGuidance + + NewGuidance @@ -959,13 +1002,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Livepatch, [RebootHost]) + ; (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RebootHost ; livepatches= [ LivePatch. @@ -996,7 +1043,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ) ] ) - ; (* Single update with livepatch_guidance but empty livepatches *) + ; (* Single update with livepatch guidance but empty livepatch *) ( {| @@ -1005,6 +1052,11 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct summary description special information + + + RestartDeviceModel + + https://update.details.info RestartDeviceModel @@ -1021,13 +1073,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Livepatch, [RestartDeviceModel]) + ; (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartDeviceModel ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None @@ -1035,7 +1091,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ) ] ) - ; (* Single update with invalid livepatches *) + ; (* Single update with valid livepatches *) ( {| @@ -1043,6 +1099,11 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct title summary description + + + RestartToolstack + + special information https://update.details.info @@ -1062,13 +1123,17 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Livepatch, [RestartToolstack]) + ; (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartToolstack ; livepatches= [ LivePatch. @@ -1096,6 +1161,11 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct title summary description + + + RestartToolstack + + special information https://update.details.info @@ -1115,13 +1185,340 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct id= "UPDATE-0000" ; summary= "summary" ; description= "description" - ; rec_guidance= None - ; abs_guidance= None + ; guidance= + [ + (Livepatch, [RestartToolstack]) + ; (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ] + ; guidance_applicabilities= [] + ; spec_info= "special information" + ; url= "https://update.details.info" + ; update_type= "security" + ; livepatches= [] + ; issued= Xapi_stdext_date.Date.epoch + ; severity= Severity.None + } + ) + ] + ) + ; (* guidance in new format: empty guidance *) + ( {| + + + UPDATE-0000 + title + summary + empty guidance + special information + https://update.details.info + EvacuateHost + RebootHost + + + RestartDeviceModel + + + + + + + |} + , Ok + [ + ( "UPDATE-0000" + , UpdateInfo. + { + id= "UPDATE-0000" + ; summary= "summary" + ; description= "empty guidance" + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] + ; guidance_applicabilities= [] + ; spec_info= "special information" + ; url= "https://update.details.info" + ; update_type= "security" + ; livepatches= [] + ; issued= Xapi_stdext_date.Date.epoch + ; severity= Severity.None + } + ) + ] + ) + ; (* guidance in new format only: empty guidance *) + ( {| + + + UPDATE-0000 + title + summary + guidance in new format only: empty guidance + special information + https://update.details.info + + + + + + + + + |} + , Ok + [ + ( "UPDATE-0000" + , UpdateInfo. + { + id= "UPDATE-0000" + ; summary= "summary" + ; description= "guidance in new format only: empty guidance" + ; guidance= + [ + (Mandatory, []) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] + ; guidance_applicabilities= [] + ; spec_info= "special information" + ; url= "https://update.details.info" + ; update_type= "security" + ; livepatches= [] + ; issued= Xapi_stdext_date.Date.epoch + ; severity= Severity.None + } + ) + ] + ) + ; (* guidance in new format: empty mandatory and full *) + ( {| + + + UPDATE-0000 + title + summary + empty mandatory and full + special information + https://update.details.info + EvacuateHost + RebootHost + + + + + + + RestartDeviceModel + + + + + + + |} + , Ok + [ + ( "UPDATE-0000" + , UpdateInfo. + { + id= "UPDATE-0000" + ; summary= "summary" + ; description= "empty mandatory and full" + ; guidance= + [ + (Full, []) + ; (Mandatory, []) + ; (Recommended, []) + ; (Livepatch, []) + ] + ; guidance_applicabilities= [] + ; spec_info= "special information" + ; url= "https://update.details.info" + ; update_type= "security" + ; livepatches= [] + ; issued= Xapi_stdext_date.Date.epoch + ; severity= Severity.None + } + ) + ] + ) + ; (* guidance in new format: mandatory only *) + ( {| + + + UPDATE-0000 + title + summary + mandatory only + special information + https://update.details.info + EvacuateHost + RebootHost + + + + RestartDeviceModel + EvacuateHost + RestartToolstack + + + RestartDeviceModel + + + + + + + |} + , Ok + [ + ( "UPDATE-0000" + , UpdateInfo. + { + id= "UPDATE-0000" + ; summary= "summary" + ; description= "mandatory only" + ; guidance= + [ + ( Mandatory + , [RestartDeviceModel; EvacuateHost; RestartToolstack] + ) + ; (Recommended, []) + ; (Full, []) + ; (Livepatch, []) + ] + ; guidance_applicabilities= [] + ; spec_info= "special information" + ; url= "https://update.details.info" + ; update_type= "security" + ; livepatches= [] + ; issued= Xapi_stdext_date.Date.epoch + ; severity= Severity.None + } + ) + ] + ) + ; (* guidance in new format: mandatory, recommended, full and livepatch *) + ( {| + + + UPDATE-0000 + title + summary + mandatory, recommended, full and livepatch + special information + https://update.details.info + EvacuateHost + RebootHost + + + + RestartToolstack + + + EvacuateHost + + + RestartDeviceModel + + + RebootHost + + + RestartDeviceModel + + + + + + + |} + , Ok + [ + ( "UPDATE-0000" + , UpdateInfo. + { + id= "UPDATE-0000" + ; summary= "summary" + ; description= "mandatory, recommended, full and livepatch" + ; guidance= + [ + (Full, [RebootHost]) + ; (Livepatch, [RestartDeviceModel]) + ; (Recommended, [EvacuateHost]) + ; (Mandatory, [RestartToolstack]) + ] + ; guidance_applicabilities= [] + ; spec_info= "special information" + ; url= "https://update.details.info" + ; update_type= "security" + ; livepatches= [] + ; issued= Xapi_stdext_date.Date.epoch + ; severity= Severity.None + } + ) + ] + ) + ; (* guidance in new format: mandatory, recommended, full and livepatch *) + ( {| + + + UPDATE-0000 + title + summary + RestartVM in mandatory + special information + https://update.details.info + EvacuateHost + RebootHost + + + + RestartVM + + + EvacuateHost + + + RestartDeviceModel + + + RebootHost + + + RestartDeviceModel + + + + + + + |} + , Ok + [ + ( "UPDATE-0000" + , UpdateInfo. + { + id= "UPDATE-0000" + ; summary= "summary" + ; description= "RestartVM in mandatory" + ; guidance= + [ + (Full, [RebootHost]) + ; (Livepatch, [RestartDeviceModel]) + ; (Recommended, [EvacuateHost]) + ; (Mandatory, [RestartVM]) + ] ; guidance_applicabilities= [] ; spec_info= "special information" ; url= "https://update.details.info" ; update_type= "security" - ; livepatch_guidance= Some Guidance.RestartToolstack ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None From 51d200a8b818081cb080a8965e45d01a0ba3f2ab Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 20 Dec 2023 05:54:26 +0000 Subject: [PATCH 07/39] Reformat with xs-opam-repo-6.76.0 Signed-off-by: Ming Lu --- ocaml/database/db_cache_impl.ml | 27 +++-- ocaml/database/master_connection.ml | 4 +- ocaml/database/parse_db_conf.ml | 4 +- ocaml/idl/datamodel_schema.ml | 4 +- ocaml/idl/json_backend/gen_json.ml | 12 +- ocaml/idl/markdown_backend.ml | 16 +-- ocaml/idl/ocaml_backend/gen_client.ml | 10 +- ocaml/idl/ocaml_backend/gen_db_actions.ml | 4 +- ocaml/idl/ocaml_backend/gen_server.ml | 30 ++--- ocaml/idl/ocaml_backend/ocaml_syntax.ml | 10 +- .../ezxenstore/watch/ez_xenstore_watch.ml | 4 +- ocaml/libs/http-lib/http_svr.ml | 8 +- ocaml/libs/stunnel/stunnel.ml | 8 +- ocaml/libs/uuid/uuidx.mli | 8 +- ocaml/libs/vhd/vhd_format/f.ml | 67 +++++------ ocaml/libs/vhd/vhd_format_lwt/iO.ml | 4 +- .../vhd/vhd_format_lwt_test/patterns_lwt.ml | 12 +- ocaml/message-switch/cli/main.ml | 66 ++++++----- ocaml/message-switch/switch/logging.ml | 4 +- ocaml/message-switch/switch/switch_main.ml | 6 +- ocaml/networkd/bin/network_server.ml | 1 - ocaml/networkd/bin/networkd.ml | 3 +- ocaml/networkd/lib/network_utils.ml | 22 ++-- .../test/network_test_lacp_properties.ml | 2 +- ocaml/perftest/createVM.ml | 4 +- ocaml/perftest/histogram.ml | 4 +- ocaml/perftest/tests.ml | 18 +-- ocaml/quicktest/quicktest_vdi.ml | 6 +- .../quicktest_vdi_ops_data_integrity.ml | 4 +- ocaml/sdk-gen/c/gen_c_binding.ml | 4 +- ocaml/sdk-gen/csharp/gen_csharp_binding.ml | 16 +-- ocaml/sdk-gen/java/main.ml | 18 +-- .../powershell/gen_powershell_binding.ml | 112 +++++++++--------- ocaml/squeezed/lib/squeeze.ml | 16 +-- ocaml/tests/common/test_vgpu_common.ml | 8 +- ocaml/tests/test_clustering.ml | 8 +- ocaml/tests/test_dbsync_master.ml | 4 +- ocaml/tests/test_observer.ml | 4 +- ocaml/tests/test_platformdata.ml | 4 +- ocaml/tests/test_repository_helpers.ml | 4 +- ocaml/tests/test_rpm.ml | 3 +- ocaml/tests/test_vdi_cbt.ml | 2 +- ocaml/vhd-tool/src/impl.ml | 16 +-- ocaml/vhd-tool/src/nbd_input.ml | 8 +- ocaml/xapi-cli-server/cli_operations.ml | 64 +++++----- ocaml/xapi-cli-server/cli_util.ml | 4 +- ocaml/xapi-cli-server/records.ml | 8 +- ocaml/xapi-idl/cluster/cluster_cli.ml | 1 - .../guard/privileged/xapiguard_cli.ml | 1 - .../xapi-idl/guard/varstored/varstored_cli.ml | 1 - ocaml/xapi-idl/memory/memory.ml | 8 +- ocaml/xapi-idl/memory/memory_cli.ml | 1 - ocaml/xapi-idl/network/network_cli.ml | 1 - ocaml/xapi-storage-script/main.ml | 4 - ocaml/xapi-storage/generator/lib/control.ml | 1 - ocaml/xapi-storage/generator/lib/data.ml | 1 - ocaml/xapi/certificates.ml | 4 +- ocaml/xapi/console.ml | 9 +- ocaml/xapi/export.ml | 20 ++-- ocaml/xapi/extauth_plugin_ADpbis.ml | 44 +++---- ocaml/xapi/import.ml | 15 +-- ocaml/xapi/importexport.ml | 4 +- ocaml/xapi/memory_check.ml | 4 +- ocaml/xapi/message_forwarding.ml | 2 +- ocaml/xapi/repository_helpers.ml | 3 +- ocaml/xapi/storage_access.ml | 4 +- ocaml/xapi/storage_smapiv1.ml | 4 +- ocaml/xapi/storage_smapiv1_wrapper.ml | 9 +- ocaml/xapi/vm_platform.ml | 2 +- ocaml/xapi/workload_balancing.ml | 4 +- ocaml/xapi/xapi_clustering.ml | 3 +- ocaml/xapi/xapi_diagnostics.ml | 12 +- ocaml/xapi/xapi_event.ml | 16 +-- ocaml/xapi/xapi_ha.ml | 4 +- ocaml/xapi/xapi_ha_vm_failover.ml | 12 +- ocaml/xapi/xapi_host.ml | 14 +-- ocaml/xapi/xapi_observer.ml | 23 ++-- ocaml/xapi/xapi_periodic_scheduler.ml | 4 +- ocaml/xapi/xapi_pif_helpers.ml | 3 +- ocaml/xapi/xapi_pool.ml | 3 +- ocaml/xapi/xapi_pool_update.ml | 4 +- ocaml/xapi/xapi_session.ml | 8 +- ocaml/xapi/xapi_sr_operations.ml | 4 +- ocaml/xapi/xapi_vif_helpers.ml | 4 +- ocaml/xapi/xapi_vm.ml | 9 +- ocaml/xapi/xapi_vm_clone.ml | 8 +- ocaml/xapi/xapi_vm_helpers.ml | 76 ++++++------ ocaml/xapi/xapi_vm_lifecycle.ml | 10 +- ocaml/xapi/xapi_xenops.ml | 66 +++++------ ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml | 4 +- ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml | 8 +- ocaml/xen-api-client/lib_test/xen_api_test.ml | 8 +- ocaml/xen-api-client/lwt/disk.ml | 4 +- ocaml/xenopsd/cli/xn.ml | 66 +++++------ ocaml/xenopsd/lib/xenops_server.ml | 12 +- ocaml/xenopsd/lib/xenops_server_simulator.ml | 8 +- ocaml/xenopsd/lib/xenopsd.ml | 4 +- ocaml/xenopsd/xc/device.ml | 16 +-- ocaml/xenopsd/xc/domain.ml | 8 +- ocaml/xenopsd/xc/memory_breakdown.ml | 16 +-- ocaml/xenopsd/xc/xenops_server_xen.ml | 19 +-- 101 files changed, 613 insertions(+), 665 deletions(-) diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index 791492f7091..b4f23b0af00 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -399,8 +399,8 @@ let spawn_db_flush_threads () = ( if dbconn.Parse_db_conf.mode <> Parse_db_conf.No_limit then "Write limited with coallesce_time=" ^ string_of_float coallesce_time - else - "" + else + "" ) ; (* check if we are currently in a coallescing_period *) let in_coallescing_period () = @@ -417,17 +417,18 @@ let spawn_db_flush_threads () = exceeded. *) ( if - !Db_connections.exit_on_next_flush - (* always flush straight away; this request is urgent *) - || (* otherwise, we only write if (i) "coalesscing period has come to an end"; and (ii) "write limiting requirements are met": *) - (not (in_coallescing_period ())) - (* see (i) above *) - && (!my_writes_this_period - < dbconn.Parse_db_conf.write_limit_write_cycles - || dbconn.Parse_db_conf.mode = Parse_db_conf.No_limit - (* (ii) above *) - ) - then (* debug "[%s] considering flush" db_path; *) + !Db_connections.exit_on_next_flush + (* always flush straight away; this request is urgent *) + || (* otherwise, we only write if (i) "coalesscing period has come to an end"; and (ii) "write limiting requirements are met": *) + (not (in_coallescing_period ())) + (* see (i) above *) + && (!my_writes_this_period + < dbconn.Parse_db_conf.write_limit_write_cycles + || dbconn.Parse_db_conf.mode + = Parse_db_conf.No_limit + (* (ii) above *) + ) + then (* debug "[%s] considering flush" db_path; *) let was_anything_flushed = Xapi_stdext_threads.Threadext.Mutex.execute Db_lock.global_flush_mutex (fun () -> diff --git a/ocaml/database/master_connection.ml b/ocaml/database/master_connection.ml index 6643f431e90..01a413a512d 100644 --- a/ocaml/database/master_connection.ml +++ b/ocaml/database/master_connection.ml @@ -301,8 +301,8 @@ let do_db_xml_rpc_persistent_with_reopen ~host:_ ~path (req : string) : time_sofar ( if !connection_timeout < 0. then "never timeout" - else - Printf.sprintf "timeout after '%f'" !connection_timeout + else + Printf.sprintf "timeout after '%f'" !connection_timeout ) ; if time_sofar > !connection_timeout && !connection_timeout >= 0. then if !restart_on_connection_timeout then ( diff --git a/ocaml/database/parse_db_conf.ml b/ocaml/database/parse_db_conf.ml index 0782b3208ac..852ace7d9f4 100644 --- a/ocaml/database/parse_db_conf.ml +++ b/ocaml/database/parse_db_conf.ml @@ -77,8 +77,8 @@ let from_block r = ; ( if r.mode = Write_limit then Printf.sprintf "write_limit_period:%d\nwrite_limit_write_cycles:%d\n" r.write_limit_period r.write_limit_write_cycles - else - "" + else + "" ) ; String.concat "" (List.map diff --git a/ocaml/idl/datamodel_schema.ml b/ocaml/idl/datamodel_schema.ml index 132d109cb1e..32bc3a94fc4 100644 --- a/ocaml/idl/datamodel_schema.ml +++ b/ocaml/idl/datamodel_schema.ml @@ -64,8 +64,8 @@ let of_datamodel () = default= ( if issetref then Some (Value.Set []) - else - Option.map Datamodel_values.to_db f.Datamodel_types.default_value + else + Option.map Datamodel_values.to_db f.Datamodel_types.default_value ) ; ty ; issetref diff --git a/ocaml/idl/json_backend/gen_json.ml b/ocaml/idl/json_backend/gen_json.ml index f96253531f2..d47db08514d 100644 --- a/ocaml/idl/json_backend/gen_json.ml +++ b/ocaml/idl/json_backend/gen_json.ml @@ -422,8 +422,8 @@ end = struct , obj.name , ( if doc = "" && transition = Lifecycle.Published then obj.description - else - doc + else + doc ) , "class" ) @@ -445,8 +445,8 @@ end = struct , obj.name ^ "." ^ m.msg_name , ( if doc = "" && transition = Lifecycle.Published then m.msg_doc - else - doc + else + doc ) , "message" ) @@ -474,8 +474,8 @@ end = struct , obj.name ^ "." ^ field_name , ( if doc = "" && transition = Lifecycle.Published then f.field_description - else - doc + else + doc ) , "field" ) diff --git a/ocaml/idl/markdown_backend.ml b/ocaml/idl/markdown_backend.ml index 5dc93a0963b..edd95d95d50 100644 --- a/ocaml/idl/markdown_backend.ml +++ b/ocaml/idl/markdown_backend.ml @@ -268,10 +268,10 @@ let print_field_table_of_obj printer ~is_class_deprecated ~is_class_removed x = let descr = ( if y.lifecycle.state = Removed_s || is_class_removed then "**Removed**. " - else if y.lifecycle.state = Deprecated_s || is_class_deprecated then - "**Deprecated**. " - else - "" + else if y.lifecycle.state = Deprecated_s || is_class_deprecated then + "**Deprecated**. " + else + "" ) ^ escape description in @@ -401,10 +401,10 @@ let print_classes api io = let get_descr obj = ( if obj.obj_lifecycle.state = Removed_s then "**Removed**. " - else if obj.obj_lifecycle.state = Deprecated_s then - "**Deprecated**. " - else - "" + else if obj.obj_lifecycle.state = Deprecated_s then + "**Deprecated**. " + else + "" ) ^ escape obj.description in diff --git a/ocaml/idl/ocaml_backend/gen_client.ml b/ocaml/idl/ocaml_backend/gen_client.ml index 93d2452c584..d456dd9d5d8 100644 --- a/ocaml/idl/ocaml_backend/gen_client.ml +++ b/ocaml/idl/ocaml_backend/gen_client.ml @@ -137,8 +137,8 @@ let gen_module api : O.Module.t = OU.alias_of_ty x | _ -> "unit" - else - OU.alias_of_ty (DT.Ref Datamodel_common._task) + else + OU.alias_of_ty (DT.Ref Datamodel_common._task) ) ~body:(x.msg_name :: "~rpc" :: all) () @@ -206,9 +206,9 @@ let gen_module api : O.Module.t = "rpc_wrapper rpc %s [ %s ] >>= fun x -> return (%s x)" ( if sync then Printf.sprintf "\"%s\"" wire_name - else - Printf.sprintf {|(Printf.sprintf "%%s%s" AQ.async_qualifier)|} - wire_name + else + Printf.sprintf {|(Printf.sprintf "%%s%s" AQ.async_qualifier)|} + wire_name ) (String.concat "; " rpc_args) (from_xmlrpc x.msg_result) diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index b149a86a4df..db222970b92 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/ocaml/idl/ocaml_backend/gen_db_actions.ml @@ -567,8 +567,8 @@ let db_action api : O.Module.t = ~elements: ( if obj.DT.in_database then [O.Module.Let (register_get_record obj)] - else - [] + else + [] ) () in diff --git a/ocaml/idl/ocaml_backend/gen_server.ml b/ocaml/idl/ocaml_backend/gen_server.ml index 88d8996c99b..e091e07b4d2 100644 --- a/ocaml/idl/ocaml_backend/gen_server.ml +++ b/ocaml/idl/ocaml_backend/gen_server.ml @@ -176,13 +176,13 @@ let operation (obj : obj) (x : message) = [ ( if Gen_empty_custom.operation_requires_side_effect x then ["(* has side-effect (with locks and no automatic DB action) *)"] - else - ["(* has no side-effect; should be handled by DB action *) "] + else + ["(* has no side-effect; should be handled by DB action *) "] ) ; ( if has_async then ["(* has asynchronous mode *)"] - else - ["(* has no asynchronous mode *)"] + else + ["(* has no asynchronous mode *)"] ) ] in @@ -270,16 +270,16 @@ let operation (obj : obj) (x : message) = because we know we don't need the arguments *) let ignore = x.DT.msg_forward_to <> None in ( if - (* If we're a constructor then unmarshall all the fields from the constructor record, passed as a struct *) - is_ctor - then + (* If we're a constructor then unmarshall all the fields from the constructor record, passed as a struct *) + is_ctor + then [from_rpc Client.session; from_ctor_record] (* Otherwise, go read non-default fields from pattern match; if we have default fields then we need to get those from the 'default_fields' arg *) - else - List.map - (fun a -> from_rpc ~ignore:(ignore && not (is_session_arg a)) a) - args_without_default_values + else + List.map + (fun a -> from_rpc ~ignore:(ignore && not (is_session_arg a)) a) + args_without_default_values ) (* and for every default value we try to get this from default_args or default it *) @ unmarshall_default_params @@ -380,8 +380,8 @@ let operation (obj : obj) (x : message) = Printf.sprintf "%s \"%s\";" ( if may_be_side_effecting x then "ApiLogSideEffect.debug" - else - "ApiLogRead.debug" + else + "ApiLogRead.debug" ) wire_name ] @@ -395,8 +395,8 @@ let operation (obj : obj) (x : message) = (if x.msg_session then "~session_id" else "") ( if Gen_empty_custom.operation_requires_side_effect x then "~forward_op" - else - "" + else + "" ) ; (* "P.debug \"Server RPC response: %s\" (Rpc.to_string (resp.Rpc.contents));"; *) "resp" diff --git a/ocaml/idl/ocaml_backend/ocaml_syntax.ml b/ocaml/idl/ocaml_backend/ocaml_syntax.ml index 01da3d662eb..634b7477830 100644 --- a/ocaml/idl/ocaml_backend/ocaml_syntax.ml +++ b/ocaml/idl/ocaml_backend/ocaml_syntax.ml @@ -142,9 +142,9 @@ module Module = struct ^ " = " ^ ( if x.args = [] then "" - else - String.concat " " - (List.map (fun x -> "functor(" ^ x ^ ") ->") x.args) + else + String.concat " " + (List.map (fun x -> "functor(" ^ x ^ ") ->") x.args) ) ^ "struct" in @@ -179,8 +179,8 @@ module Signature = struct [ ( if toplevel then Line ("module type " ^ x.name ^ " = sig") - else - Line ("module " ^ x.name ^ " : sig") + else + Line ("module " ^ x.name ^ " : sig") ) ; Indent (List.concat (List.map e x.elements)) ; Line "end" diff --git a/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml b/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml index cac3725b633..d65bc43d466 100644 --- a/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml +++ b/ocaml/libs/ezxenstore/watch/ez_xenstore_watch.ml @@ -158,8 +158,8 @@ module Make (Debug : DEBUG) = struct IntMap.find domid ( if IntMap.mem domid domains' then domains' - else - !domains + else + !domains ) in let id = Uuidm.to_string (uuid_of_di di) in diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 65c54292c70..c824277e5be 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -326,8 +326,8 @@ let escape uri = let aux h t = ( if List.mem_assoc h rules then List.assoc h rules - else - Astring.String.of_char h + else + Astring.String.of_char h ) :: t in @@ -761,8 +761,8 @@ let clean_addr_of_string ip = let ipv4_affix = "::ffff:" in ( if Astring.String.is_prefix ~affix:ipv4_affix ip then Astring.String.drop ~max:(String.length ipv4_affix) ip - else - ip + else + ip ) |> Ipaddr.of_string |> Stdlib.Result.to_option diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index ae4e341d16c..aaaf3dd7d2a 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -256,8 +256,8 @@ let disconnect_with_pid ?(wait = true) ?(force = false) pid = (fun () -> ( if wait then Forkhelpers.waitpid - else - Forkhelpers.waitpid_nohang + else + Forkhelpers.waitpid_nohang ) fpid ) @@ -267,8 +267,8 @@ let disconnect_with_pid ?(wait = true) ?(force = false) pid = (fun () -> ( if wait then Unix.waitpid [] - else - Unix.waitpid [Unix.WNOHANG] + else + Unix.waitpid [Unix.WNOHANG] ) pid ) diff --git a/ocaml/libs/uuid/uuidx.mli b/ocaml/libs/uuid/uuidx.mli index 17e3e5874f6..57b4058b8ca 100644 --- a/ocaml/libs/uuid/uuidx.mli +++ b/ocaml/libs/uuid/uuidx.mli @@ -48,11 +48,11 @@ val to_string : 'a t -> string (** Marshal a UUID to a string. *) val uuid_of_string : string -> 'a t option - [@@deprecated "Use of_string"] +[@@deprecated "Use of_string"] (** Deprecated alias for {! Uuidx.of_string} *) val string_of_uuid : 'a t -> string - [@@deprecated "Use to_string"] +[@@deprecated "Use to_string"] (** Deprecated alias for {! Uuidx.to_string} *) val of_int_array : int array -> 'a t option @@ -62,11 +62,11 @@ val to_int_array : 'a t -> int array (** Convert a UUID to an array. *) val uuid_of_int_array : int array -> 'a t option - [@@deprecated "Use Uuidx.of_int_array"] +[@@deprecated "Use Uuidx.of_int_array"] (** Deprecated alias for {! Uuidx.of_int_array} *) val int_array_of_uuid : 'a t -> int array - [@@deprecated "Use Uuidx.to_int_array"] +[@@deprecated "Use Uuidx.to_int_array"] (** Deprecated alias for {! Uuidx.to_int_array} *) val of_bytes : string -> 'a t option diff --git a/ocaml/libs/vhd/vhd_format/f.ml b/ocaml/libs/vhd/vhd_format/f.ml index 00d31ae66eb..ac9d945eba4 100644 --- a/ocaml/libs/vhd/vhd_format/f.ml +++ b/ocaml/libs/vhd/vhd_format/f.ml @@ -366,7 +366,8 @@ module UTF16 = struct ) else (c, ofs + 2, n + 1) in - string.(n) <- code ; inner ofs' n' + string.(n) <- code ; + inner ofs' n' in try Rresult.R.ok (inner pos 0) with e -> Rresult.R.error e end @@ -518,8 +519,8 @@ module Footer = struct magic magic' ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> let features = Feature.of_int32 (get_footer_features buf) in @@ -531,8 +532,8 @@ module Footer = struct expected_version format_version ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> let data_offset = get_footer_data_offset buf in @@ -570,8 +571,8 @@ module Footer = struct expected_checksum checksum ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> R.ok @@ -1019,8 +1020,8 @@ module Header = struct ( if magic' <> magic then R.error (Failure (Printf.sprintf "Expected cookie %s, got %s" magic magic')) - else - R.ok () + else + R.ok () ) >>= fun () -> let data_offset = get_header_data_offset buf in @@ -1031,8 +1032,8 @@ module Header = struct expected_data_offset data_offset ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> let table_offset = get_header_table_offset buf in @@ -1044,21 +1045,21 @@ module Header = struct expected_version header_version ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> let max_table_entries = get_header_max_table_entries buf in ( if Int64.of_int32 max_table_entries > Int64.of_int Sys.max_array_length - then + then R.error (Failure (Printf.sprintf "expected max_table_entries < %d, got %ld" Sys.max_array_length max_table_entries ) ) - else - R.ok (Int32.to_int max_table_entries) + else + R.ok (Int32.to_int max_table_entries) ) >>= fun max_table_entries -> let block_size = get_header_block_size buf in @@ -1116,8 +1117,8 @@ module Header = struct expected_checksum checksum ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> R.ok @@ -1284,8 +1285,8 @@ module Batmap_header = struct ( if magic' <> magic then R.error (Failure (Printf.sprintf "Expected cookie %s, got %s" magic magic')) - else - R.ok () + else + R.ok () ) >>= fun () -> let offset = get_header_offset buf in @@ -1293,17 +1294,17 @@ module Batmap_header = struct let major_version = get_header_major_version buf in let minor_version = get_header_minor_version buf in ( if - major_version <> current_major_version - || minor_version <> current_minor_version - then + major_version <> current_major_version + || minor_version <> current_minor_version + then R.error (Failure (Printf.sprintf "Unexpected BATmap version: %d.%d" major_version minor_version ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> let checksum = get_header_checksum buf in @@ -1357,8 +1358,8 @@ module Batmap = struct bh.Batmap_header.checksum checksum ) ) - else - R.ok () + else + R.ok () ) >>= fun () -> R.ok needed end @@ -2003,10 +2004,10 @@ functor let l_rounded = roundup_sector l in ( if l_rounded = 0 then return (Cstruct.create 0) - else - let platform_data = Memory.alloc l_rounded in - really_read fd t.platform_data_offset platform_data >>= fun () -> - return platform_data + else + let platform_data = Memory.alloc l_rounded in + really_read fd t.platform_data_offset platform_data >>= fun () -> + return platform_data ) >>= fun platform_data -> let platform_data = Cstruct.sub platform_data 0 l in @@ -2337,8 +2338,8 @@ functor (* We avoided rewriting the footer for speed, this is where it is repaired. *) ( if t.Vhd.rw then write_metadata t >>= fun _ -> return () - else - return () + else + return () ) >>= fun () -> let rec close t = diff --git a/ocaml/libs/vhd/vhd_format_lwt/iO.ml b/ocaml/libs/vhd/vhd_format_lwt/iO.ml index 875fb0c1b31..0940e6c56c3 100644 --- a/ocaml/libs/vhd/vhd_format_lwt/iO.ml +++ b/ocaml/libs/vhd/vhd_format_lwt/iO.ml @@ -34,8 +34,8 @@ let complete name offset op fd buffer = (match offset with Some x -> Int64.to_string x | None -> "None") ( if Cstruct.length buffer > 16 then String.escaped (Cstruct.to_string (Cstruct.sub buffer 0 13)) ^ "..." - else - String.escaped (Cstruct.to_string buffer) + else + String.escaped (Cstruct.to_string buffer) ) (Cstruct.length buffer) ; if n = 0 && len <> 0 then diff --git a/ocaml/libs/vhd/vhd_format_lwt_test/patterns_lwt.ml b/ocaml/libs/vhd/vhd_format_lwt_test/patterns_lwt.ml index ea829fa4c97..914bcfb2233 100644 --- a/ocaml/libs/vhd/vhd_format_lwt_test/patterns_lwt.ml +++ b/ocaml/libs/vhd/vhd_format_lwt_test/patterns_lwt.ml @@ -132,10 +132,10 @@ let check_raw_stream_contents t expected = ( if not (List.mem_assoc sector expected) then assert_equal ~printer:cstruct_to_string ~cmp:F.cstruct_equal empty_sector actual - else - let expected = List.assoc sector expected in - assert_equal ~printer:cstruct_to_string ~cmp:F.cstruct_equal - expected actual + else + let expected = List.assoc sector expected in + assert_equal ~printer:cstruct_to_string ~cmp:F.cstruct_equal + expected actual ) ; check (i + 1) in @@ -188,8 +188,8 @@ let verify t contents = t.Vhd.footer.Footer.current_size ) ) - else - return () + else + return () ) >>= fun () -> check_written_sectors t contents >>= fun () -> diff --git a/ocaml/message-switch/cli/main.ml b/ocaml/message-switch/cli/main.ml index ed314c30223..197061a17ea 100644 --- a/ocaml/message-switch/cli/main.ml +++ b/ocaml/message-switch/cli/main.ml @@ -212,37 +212,41 @@ let diagnostics common_opts = Printf.printf "Switch started %s\n" (time in_the_past d.Diagnostics.start_time) ; ( if d.Diagnostics.permanent_queues = [] then print_endline "There are no known services (yet)." - else - let not_started = - List.filter - (fun q -> classify q = `Not_started) - d.Diagnostics.permanent_queues - in - let crashed = - List.filter - (fun q -> - match classify q with `Crashed_or_deadlocked _ -> true | _ -> false - ) - d.Diagnostics.permanent_queues - in - let ok = - List.filter (fun q -> classify q = `Ok) d.Diagnostics.permanent_queues - in - if ok = [] then - print_endline "No known services are running." - else ( - print_endline "\nThe following services are running:" ; - List.iter queue ok - ) ; - if not_started <> [] then ( - print_endline - "\nThe following services have been called but have never started:" ; - List.iter queue not_started - ) ; - if crashed <> [] then ( - print_endline "\nThe following services have crashed or deadlocked:" ; - List.iter queue crashed - ) + else + let not_started = + List.filter + (fun q -> classify q = `Not_started) + d.Diagnostics.permanent_queues + in + let crashed = + List.filter + (fun q -> + match classify q with + | `Crashed_or_deadlocked _ -> + true + | _ -> + false + ) + d.Diagnostics.permanent_queues + in + let ok = + List.filter (fun q -> classify q = `Ok) d.Diagnostics.permanent_queues + in + if ok = [] then + print_endline "No known services are running." + else ( + print_endline "\nThe following services are running:" ; + List.iter queue ok + ) ; + if not_started <> [] then ( + print_endline + "\nThe following services have been called but have never started:" ; + List.iter queue not_started + ) ; + if crashed <> [] then ( + print_endline "\nThe following services have crashed or deadlocked:" ; + List.iter queue crashed + ) ) ; (* We don't show expected empty transient queues *) let expected = diff --git a/ocaml/message-switch/switch/logging.ml b/ocaml/message-switch/switch/logging.ml index 19aabf72ad6..37101ac88fe 100644 --- a/ocaml/message-switch/switch/logging.ml +++ b/ocaml/message-switch/switch/logging.ml @@ -51,8 +51,8 @@ let get (logger : logger) = return ( if dropped <> 0 then Printf.sprintf "<-- dropped %d log lines" dropped :: all - else - all + else + all ) in (* Grab as many elements as we can without blocking *) diff --git a/ocaml/message-switch/switch/switch_main.ml b/ocaml/message-switch/switch/switch_main.ml index 9ea08e0b745..9bf78973a85 100644 --- a/ocaml/message-switch/switch/switch_main.ml +++ b/ocaml/message-switch/switch/switch_main.ml @@ -142,9 +142,9 @@ let make_server config trace_config = let redo_log_path = Filename.concat statedir _redo_log in let dump_path = Filename.concat statedir _dump_file in ( if - (not (Sys.file_exists redo_log_path)) - || not (Sys.file_exists dump_path) - then ( + (not (Sys.file_exists redo_log_path)) + || not (Sys.file_exists dump_path) + then ( info "Writing an empty set of queues to %s" dump_path ; save statedir Q.empty >>= fun () -> info "Writing an empty redo-log to %s" redo_log_path ; diff --git a/ocaml/networkd/bin/network_server.ml b/ocaml/networkd/bin/network_server.ml index e45fe5de37e..2aa2ac94fc6 100644 --- a/ocaml/networkd/bin/network_server.ml +++ b/ocaml/networkd/bin/network_server.ml @@ -14,7 +14,6 @@ open Network_utils open Network_interface - module S = Network_interface.Interface_API (Idl.Exn.GenServer ()) module D = Debug.Make (struct let name = "network_server" end) diff --git a/ocaml/networkd/bin/networkd.ml b/ocaml/networkd/bin/networkd.ml index 53933cc95db..e36113580db 100644 --- a/ocaml/networkd/bin/networkd.ml +++ b/ocaml/networkd/bin/networkd.ml @@ -122,8 +122,7 @@ let options = ; ( "json-rpc-read-timeout" , Arg.Int (fun x -> - Jsonrpc_client.json_rpc_read_timeout := - Int64.(mul 1000000L (of_int x)) + Jsonrpc_client.json_rpc_read_timeout := Int64.(mul 1000000L (of_int x)) ) , (fun () -> Int64.(to_string (div !Jsonrpc_client.json_rpc_read_timeout 1000000L)) diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index e9a5a3149db..9fe4be9944d 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -1702,15 +1702,15 @@ module Ovs = struct :: ( if halgo = "src_mac" then ["bond_mode=balance-slb"] - else if halgo = "tcpudp_ports" then - ["bond_mode=balance-tcp"] - else ( - debug - "bond %s has invalid bond-hashing-algorithm '%s'; defaulting to \ - balance-tcp" - name halgo ; - ["bond_mode=balance-tcp"] - ) + else if halgo = "tcpudp_ports" then + ["bond_mode=balance-tcp"] + else ( + debug + "bond %s has invalid bond-hashing-algorithm '%s'; defaulting \ + to balance-tcp" + name halgo ; + ["bond_mode=balance-tcp"] + ) ) else ["lacp=off"; "bond_mode=" ^ mode] @@ -2054,8 +2054,8 @@ module Modprobe = struct |> Array.to_list |> String.concat "," ) - else - Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) + else + Result.Error (Other, "Fail to generate options for maxvfs for " ^ driver) ) >>= fun option -> let need_rebuild_initrd = ref false in diff --git a/ocaml/networkd/test/network_test_lacp_properties.ml b/ocaml/networkd/test/network_test_lacp_properties.ml index eacfcc732d5..c1bb8f64612 100644 --- a/ocaml/networkd/test/network_test_lacp_properties.ml +++ b/ocaml/networkd/test/network_test_lacp_properties.ml @@ -101,7 +101,7 @@ let test_lacp_defaults_bond_create () = Alcotest.( check bool "key=value argument pairs can't have missing values" true (let open Astring.String in - arg |> trim |> is_suffix ~affix:"=" |> not + arg |> trim |> is_suffix ~affix:"=" |> not ) ) ) diff --git a/ocaml/perftest/createVM.ml b/ocaml/perftest/createVM.ml index 55aaef2e2f1..e3496223488 100644 --- a/ocaml/perftest/createVM.ml +++ b/ocaml/perftest/createVM.ml @@ -119,8 +119,8 @@ let make ~rpc ~session_id ~pool:_ ~vm ~networks ~storages = Printf.sprintf "VM %d%s%s" j ( if Array.length storages > 1 then Printf.sprintf " in SR %d" i - else - "" + else + "" ) (if vm.tag <> "" then " - " ^ vm.tag else "") in diff --git a/ocaml/perftest/histogram.ml b/ocaml/perftest/histogram.ml index 748eaef990f..19afe0db278 100644 --- a/ocaml/perftest/histogram.ml +++ b/ocaml/perftest/histogram.ml @@ -209,8 +209,8 @@ let _ = ; normal_probability_y_axis= ( if !normal then Some (!min_percentile /. 100., !max_percentile /. 100.) - else - None + else + None ) } in diff --git a/ocaml/perftest/tests.ml b/ocaml/perftest/tests.ml index dfc7e1c1d3c..5262d4be0ec 100644 --- a/ocaml/perftest/tests.ml +++ b/ocaml/perftest/tests.ml @@ -117,15 +117,15 @@ let parallel_with_vms async_op opname n vms rpc session_id test subtest_name = "Ignoring completed task which doesn't correspond to a \ VM %s" opname - else - let uuid = Hashtbl.find tasks_to_vm task in - let started = Hashtbl.find vm_to_start_time uuid in - let time_taken = Unix.gettimeofday () -. started in - results := time_taken :: !results ; - debug "%sing VM uuid '%s'" opname uuid ; - debug "Elapsed time: %f" time_taken ; - Hashtbl.remove vm_to_start_time uuid ; - Hashtbl.remove tasks_to_vm task + else + let uuid = Hashtbl.find tasks_to_vm task in + let started = Hashtbl.find vm_to_start_time uuid in + let time_taken = Unix.gettimeofday () -. started in + results := time_taken :: !results ; + debug "%sing VM uuid '%s'" opname uuid ; + debug "Elapsed time: %f" time_taken ; + Hashtbl.remove vm_to_start_time uuid ; + Hashtbl.remove tasks_to_vm task ) ; active_tasks := List.filter (fun x -> x <> task) !active_tasks ; Condition.signal c ; diff --git a/ocaml/quicktest/quicktest_vdi.ml b/ocaml/quicktest/quicktest_vdi.ml index 8acb4eb7ab5..a648495eced 100644 --- a/ocaml/quicktest/quicktest_vdi.ml +++ b/ocaml/quicktest/quicktest_vdi.ml @@ -417,8 +417,7 @@ let tests () = ) ; [("test_vdi_snapshot", `Slow, test_vdi_snapshot)] |> conn - |> sr - SR.(all |> has_capabilities Sr_capabilities.[vdi_snapshot; vdi_update]) + |> sr SR.(all |> has_capabilities Sr_capabilities.[vdi_snapshot; vdi_update]) ; [("test_vdi_clone", `Slow, test_vdi_clone)] |> conn |> sr @@ -429,8 +428,7 @@ let tests () = ) ; [("vdi_snapshot_in_pool", `Slow, vdi_snapshot_in_pool)] |> conn - |> sr - SR.(all |> has_capabilities Sr_capabilities.[vdi_snapshot; vdi_update]) + |> sr SR.(all |> has_capabilities Sr_capabilities.[vdi_snapshot; vdi_update]) ; [ ( "vdi_create_destroy_plug_checksize" , `Slow diff --git a/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml b/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml index 1d5cdab14c8..5b385d9b34e 100644 --- a/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml +++ b/ocaml/quicktest/quicktest_vdi_ops_data_integrity.ml @@ -159,9 +159,7 @@ let large_data_integrity_tests vdi_op op_name = ] let sr_with_vdi_create_destroy = - Qt_filter.SR.( - all |> allowed_operations [`vdi_create; `vdi_destroy] |> not_iso - ) + Qt_filter.SR.(all |> allowed_operations [`vdi_create; `vdi_destroy] |> not_iso) let supported_srs test_case = let open Qt_filter in diff --git a/ocaml/sdk-gen/c/gen_c_binding.ml b/ocaml/sdk-gen/c/gen_c_binding.ml index 9a920721379..0c84af4ac93 100644 --- a/ocaml/sdk-gen/c/gen_c_binding.ml +++ b/ocaml/sdk-gen/c/gen_c_binding.ml @@ -1110,8 +1110,8 @@ and write_impl {name= classname; contents; messages; _} out_chan = String.concat "\n" (( if is_event then [] - else - [sprintf "XEN_FREE(%s)" tn; sprintf "XEN_SET_ALLOC_FREE(%s)" tn] + else + [sprintf "XEN_FREE(%s)" tn; sprintf "XEN_SET_ALLOC_FREE(%s)" tn] ) @ [ sprintf "XEN_ALLOC(%s)" record_tn diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml index b432c153fac..2d7f254fad9 100644 --- a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml @@ -1349,14 +1349,14 @@ and get_default_value_per_type ty thing = sprintf " = new %s() {%s}" (exposed_type ty) ( if thing = [] then "" - else - String.concat ", " - (List.map - (fun x -> - sprintf "new XenRef<%s>(%s)" (exposed_class_name name) x - ) - thing - ) + else + String.concat ", " + (List.map + (fun x -> + sprintf "new XenRef<%s>(%s)" (exposed_class_name name) x + ) + thing + ) ) | Set _ -> sprintf " = new %s() {%s}" (exposed_type ty) (String.concat ", " thing) diff --git a/ocaml/sdk-gen/java/main.ml b/ocaml/sdk-gen/java/main.ml index 1c8a77af57c..8efaafed4f3 100644 --- a/ocaml/sdk-gen/java/main.ml +++ b/ocaml/sdk-gen/java/main.ml @@ -306,15 +306,15 @@ let gen_method file cls message params async_version = ( if async_version then fprintf file " * @return Task\n" - else - match message.msg_result with - | None -> - () - | Some (_, "") -> - fprintf file " * @return %s\n" - (get_java_type_or_void message.msg_result) - | Some (_, desc) -> - fprintf file " * @return %s\n" desc + else + match message.msg_result with + | None -> + () + | Some (_, "") -> + fprintf file " * @return %s\n" + (get_java_type_or_void message.msg_result) + | Some (_, desc) -> + fprintf file " * @return %s\n" desc ) ; List.iter diff --git a/ocaml/sdk-gen/powershell/gen_powershell_binding.ml b/ocaml/sdk-gen/powershell/gen_powershell_binding.ml index da89c34d043..2701e190767 100644 --- a/ocaml/sdk-gen/powershell/gen_powershell_binding.ml +++ b/ocaml/sdk-gen/powershell/gen_powershell_binding.ml @@ -184,8 +184,8 @@ and gen_arg_param = function "\n [Parameter%s]\n public string %s { get; set; }\n" ( if String.lowercase_ascii x = "uuid" then "(ValueFromPipelineByPropertyName = true)" - else - "" + else + "" ) (pascal_case_ x) | Int64_query_arg x -> @@ -425,8 +425,8 @@ and print_methods_class classname has_uuid has_name = \ results.Add(record.Value);\n\ \ }\n\ \ }" - else - "" + else + "" ) ( if has_uuid then sprintf @@ -440,8 +440,8 @@ and print_methods_class classname has_uuid has_name = \ break;\n\ \ }\n\ \ }" - else - "" + else + "" ) (*********************************) @@ -478,8 +478,8 @@ and print_header_constructor message classname = (qualified_class_name classname) ( if message.msg_async then "\n [OutputType(typeof(XenAPI.Task))]" - else - "" + else + "" ) (ocaml_class_to_csharp_class classname) @@ -498,8 +498,8 @@ and print_params_constructor message obj classname = (qualified_class_name classname) ( if is_real_constructor message then gen_fields (DU.fields_of_obj obj) - else - gen_constructor_params message.msg_params + else + gen_constructor_params message.msg_params ) ( if message.msg_async then "\n\ @@ -507,8 +507,8 @@ and print_params_constructor message obj classname = \ {\n\ \ get { return true; }\n\ \ }\n" - else - "" + else + "" ) and gen_constructor_params params = @@ -562,8 +562,8 @@ and print_methods_constructor message obj classname = }\n" ( if is_real_constructor message then gen_make_record obj classname - else - gen_make_fields message obj + else + gen_make_fields message obj ) (gen_shouldprocess "New" message classname) (gen_csharp_api_call message classname "New" "passthru") @@ -786,8 +786,8 @@ and gen_destructor obj classname messages = (qualified_class_name classname) ( if List.length asyncMessages > 0 then "\n [OutputType(typeof(XenAPI.Task))]" - else - "" + else + "" ) (ocaml_class_to_csharp_class classname) (print_xenobject_params obj classname true true true) @@ -798,8 +798,8 @@ and gen_destructor obj classname messages = \ {\n\ \ get { return true; }\n\ \ }\n" - else - "" + else + "" ) (ocaml_class_to_csharp_local_var classname) (ocaml_class_to_csharp_property classname) @@ -867,8 +867,8 @@ and gen_remover obj classname messages = (qualified_class_name classname) ( if List.length asyncMessages > 0 then "\n [OutputType(typeof(XenAPI.Task))]" - else - "" + else + "" ) (ocaml_class_to_csharp_class classname) (print_xenobject_params obj classname true true true) @@ -932,8 +932,8 @@ and gen_setter obj classname messages = (qualified_class_name classname) ( if List.length asyncMessages > 0 then "\n [OutputType(typeof(XenAPI.Task))]" - else - "" + else + "" ) (ocaml_class_to_csharp_class classname) (print_xenobject_params obj classname true true true) @@ -997,8 +997,8 @@ and gen_adder obj classname messages = (qualified_class_name classname) ( if List.length asyncMessages > 0 then "\n [OutputType(typeof(XenAPI.Task))]" - else - "" + else + "" ) (ocaml_class_to_csharp_class classname) (print_xenobject_params obj classname true true true) @@ -1291,8 +1291,8 @@ and print_dynamic_params classname enum commonVerb messagesWithParams = "\n\ \ [Parameter]\n\ \ public SwitchParameter Async { get; set; }\n" - else - "" + else + "" ) (print_dynamic_param_members classname hd.msg_params commonVerb) (print_dynamic_params classname enum commonVerb tl) @@ -1398,8 +1398,8 @@ and print_xenobject_params obj classname mandatoryRef includeXenObject %s%s\n" ( if includeXenObject then print_param_xen_object (qualified_class_name classname) publicName - else - "" + else + "" ) (if mandatoryRef then ", Mandatory = true" else "") (qualified_class_name classname) @@ -1570,8 +1570,8 @@ and print_parse_xenobject_private_method obj classname includeUuidAndName = \ }" (qualified_class_name classname) localVar - else - sprintf "" + else + sprintf "" ) ( if has_name obj && includeUuidAndName then sprintf @@ -1592,14 +1592,14 @@ and print_parse_xenobject_private_method obj classname includeUuidAndName = (qualified_class_name classname) localVar (qualified_class_name classname) - else - sprintf "" + else + sprintf "" ) localVar publicProperty ( if has_uuid obj then sprintf ", 'Uuid'" - else - sprintf "" + else + sprintf "" ) publicProperty localVar @@ -1683,12 +1683,12 @@ and gen_csharp_api_call message classname commonVerb switch = sprintf "Xen%sAction%sDynamicParameters" (ocaml_class_to_csharp_class classname) (cut_msg_name (pascal_case message.msg_name) "Invoke") - else if commonVerb = "Get" then - sprintf "Xen%sProperty%sDynamicParameters" - (ocaml_class_to_csharp_class classname) - (cut_msg_name (pascal_case message.msg_name) "Get") - else - "XenServerCmdletDynamicParameters" + else if commonVerb = "Get" then + sprintf "Xen%sProperty%sDynamicParameters" + (ocaml_class_to_csharp_class classname) + (cut_msg_name (pascal_case message.msg_name) "Get") + else + "XenServerCmdletDynamicParameters" ) (gen_csharp_api_call_async message classname commonVerb) passThruTask @@ -1697,9 +1697,9 @@ and gen_csharp_api_call message classname commonVerb switch = else sprintf "%s%s%s" ( if - commonVerb = "Invoke" - && is_message_with_dynamic_params classname message - then + commonVerb = "Invoke" + && is_message_with_dynamic_params classname message + then sprintf "\n\ \ var contxt = _context as \ @@ -1708,19 +1708,19 @@ and gen_csharp_api_call message classname commonVerb switch = \ return;" (ocaml_class_to_csharp_class classname) (cut_msg_name (pascal_case message.msg_name) "Invoke") - else if - commonVerb = "Get" && is_message_with_dynamic_params classname message - then - sprintf - "\n\ - \ var contxt = _context as \ - Xen%sProperty%sDynamicParameters;\n\ - \ if (contxt == null)\n\ - \ return;" - (ocaml_class_to_csharp_class classname) - (cut_msg_name (pascal_case message.msg_name) "Get") - else - "" + else if + commonVerb = "Get" && is_message_with_dynamic_params classname message + then + sprintf + "\n\ + \ var contxt = _context as \ + Xen%sProperty%sDynamicParameters;\n\ + \ if (contxt == null)\n\ + \ return;" + (ocaml_class_to_csharp_class classname) + (cut_msg_name (pascal_case message.msg_name) "Get") + else + "" ) (gen_csharp_api_call_sync message classname commonVerb) passThruResult diff --git a/ocaml/squeezed/lib/squeeze.ml b/ocaml/squeezed/lib/squeeze.ml index 770147dbb53..e41575c1d97 100644 --- a/ocaml/squeezed/lib/squeeze.ml +++ b/ocaml/squeezed/lib/squeeze.ml @@ -348,8 +348,8 @@ module Proportional = struct surplus_memory_kib gamma ( if total_range = 0L then 0L - else - Int64.of_float (Int64.to_float total_range *. (gamma' -. gamma)) + else + Int64.of_float (Int64.to_float total_range *. (gamma' -. gamma)) ) ) ; List.map @@ -473,12 +473,12 @@ module Squeezer = struct host.free_mem_kib host_target_kib ( if success then " OK" - else if target_too_big then - " cannot free enough" - else if cant_allocate_any_more then - " cannot allocate enough" - else - "" + else if target_too_big then + " cannot free enough" + else if cant_allocate_any_more then + " cannot allocate enough" + else + "" ) (if all_targets_reached then "" else " not") (if no_target_changes then "" else "; however about to adjust targets") diff --git a/ocaml/tests/common/test_vgpu_common.ml b/ocaml/tests/common/test_vgpu_common.ml index 15c0da96c91..56dbfad4a4c 100644 --- a/ocaml/tests/common/test_vgpu_common.ml +++ b/ocaml/tests/common/test_vgpu_common.ml @@ -235,10 +235,10 @@ let make_vgpu ~__context ?(vm_ref = Ref.null) ?(gPU_group = Ref.null) Test_common.make_vm ~__context () in ( if - Xapi_vgpu_type.requires_passthrough ~__context ~self:vgpu_type_ref - = Some `PF - && Db.is_valid_ref __context resident_on - then + Xapi_vgpu_type.requires_passthrough ~__context ~self:vgpu_type_ref + = Some `PF + && Db.is_valid_ref __context resident_on + then let pci_ref = Db.PGPU.get_PCI ~__context ~self:resident_on in Db.PCI.add_attached_VMs ~__context ~self:pci_ref ~value:vm_ref ) ; diff --git a/ocaml/tests/test_clustering.ml b/ocaml/tests/test_clustering.ml index 07e67f452d8..05980045a11 100644 --- a/ocaml/tests/test_clustering.ml +++ b/ocaml/tests/test_clustering.ml @@ -310,9 +310,7 @@ let test_assert_cluster_host_is_enabled_for_matching_sms_fails_if_cluster_host_i in Alcotest.check_raises "test_assert_cluster_host_is_enabled_for_matching_sms_fails_if_cluster_host_is_disabled" - Api_errors.( - Server_error (clustering_disabled, [Ref.string_of cluster_host]) - ) + Api_errors.(Server_error (clustering_disabled, [Ref.string_of cluster_host])) (fun () -> Xapi_clustering.assert_cluster_host_is_enabled_for_matching_sms ~__context ~host ~sr_sm_type:"gfs2" @@ -468,9 +466,7 @@ let test_assert_pif_prerequisites () = Alcotest.check_raises "test_assert_pif_prerequisites : disallow_unplug set, IP and \ currently_attached to go " - Api_errors.( - Server_error (required_pif_is_unplugged, [Ref.string_of pifref]) - ) + Api_errors.(Server_error (required_pif_is_unplugged, [Ref.string_of pifref])) (fun () -> Xapi_clustering.assert_pif_prerequisites pif) ; (* Plug in PIF *) Db.PIF.set_currently_attached ~__context ~self:pifref ~value:true ; diff --git a/ocaml/tests/test_dbsync_master.ml b/ocaml/tests/test_dbsync_master.ml index c66a1de69c6..6cd17d12b8b 100644 --- a/ocaml/tests/test_dbsync_master.ml +++ b/ocaml/tests/test_dbsync_master.ml @@ -21,9 +21,7 @@ module CreateToolsSR = Generic.MakeStateful (struct type output_t = (string * string * (string * string) list) list let string_of_input_t = - Test_printers.( - list (tuple4 string string (assoc_list string string) bool) - ) + Test_printers.(list (tuple4 string string (assoc_list string string) bool)) let string_of_output_t = Test_printers.(list (tuple3 string string (assoc_list string string))) diff --git a/ocaml/tests/test_observer.ml b/ocaml/tests/test_observer.ml index 0dff6f2d340..0ea0031bb48 100644 --- a/ocaml/tests/test_observer.ml +++ b/ocaml/tests/test_observer.ml @@ -223,9 +223,7 @@ let test_endpoints ~__context ~self = (fun invalid_endpoint -> Alcotest.check_raises "Xapi_observer.set_components should fail on invalid component" - Api_errors.( - Server_error (invalid_value, ["endpoint"; invalid_endpoint]) - ) + Api_errors.(Server_error (invalid_value, ["endpoint"; invalid_endpoint])) (fun () -> Xapi_observer.set_endpoints ~__context ~self ~value:[invalid_endpoint] |> ignore diff --git a/ocaml/tests/test_platformdata.ml b/ocaml/tests/test_platformdata.ml index 8af47320199..36611a5cd5a 100644 --- a/ocaml/tests/test_platformdata.ml +++ b/ocaml/tests/test_platformdata.ml @@ -172,9 +172,7 @@ module SanityCheck = Generic.MakeStateless (struct Fmt.(Dump.list @@ pair ~sep:(any "=") fmt_fst fmt_snd) let string_of_output_t x = - Fmt.( - str "%a" Dump.(result ~ok:(pp_list_assoc string string) ~error:exn) x - ) + Fmt.(str "%a" Dump.(result ~ok:(pp_list_assoc string string) ~error:exn) x) end let transform diff --git a/ocaml/tests/test_repository_helpers.ml b/ocaml/tests/test_repository_helpers.ml index 0eee649056a..b0b430f2b65 100644 --- a/ocaml/tests/test_repository_helpers.ml +++ b/ocaml/tests/test_repository_helpers.ml @@ -4131,9 +4131,7 @@ module GetLatestUpdatesFromRedundancy = Generic.MakeStateless (struct let string_of_output_t = function | Ok pkgs -> - Fmt.( - str "%a" Dump.(list (pair (record @@ fields_of_pkg) string)) pkgs - ) + Fmt.(str "%a" Dump.(list (pair (record @@ fields_of_pkg) string)) pkgs) | Error e -> Fmt.(str "%a" exn) e end diff --git a/ocaml/tests/test_rpm.ml b/ocaml/tests/test_rpm.ml index d5cdcc61ba4..da47d9a0ce8 100644 --- a/ocaml/tests/test_rpm.ml +++ b/ocaml/tests/test_rpm.ml @@ -39,8 +39,7 @@ module PkgOfFullnameTest = Generic.MakeStateless (struct let string_of_output_t = Fmt.( - str "%a" - Dump.(result ~ok:(option @@ record @@ fields_of_pkg) ~error:exn) + str "%a" Dump.(result ~ok:(option @@ record @@ fields_of_pkg) ~error:exn) ) end diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index 8e89179e423..566fa18fbf5 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -61,7 +61,7 @@ let make_smapiv2_storage_server ?vdi_enable_cbt ?vdi_disable_cbt let clone = default Storage_skeleton.VDI.clone vdi_snapshot end end : Storage_interface.Server_impl - ) +) let register_smapiv2_server ?vdi_enable_cbt ?vdi_disable_cbt ?vdi_list_changed_blocks ?vdi_data_destroy ?vdi_snapshot ?vdi_clone sr_ref = diff --git a/ocaml/vhd-tool/src/impl.ml b/ocaml/vhd-tool/src/impl.ml index 7eb7b337ca7..6e699650cfc 100644 --- a/ocaml/vhd-tool/src/impl.ml +++ b/ocaml/vhd-tool/src/impl.ml @@ -477,8 +477,8 @@ let stream_tar _common c s _ prefix ?(progress = no_progress_bar) () = return {state with ctx; header= None} | None -> return state - else - return state + else + return state ) >>= fun state -> (* If we have unwritten data then output the next header *) @@ -1015,8 +1015,8 @@ let write_stream common s destination destination_protocol prezeroed progress let open Cohttp in ( if use_ssl then Channels.of_ssl_fd sock good_ciphersuites verify_cert - else - Channels.of_raw_fd sock + else + Channels.of_raw_fd sock ) >>= fun c -> let module Request = Request.Make (Cohttp_unbuffered_io) in @@ -1276,8 +1276,8 @@ let serve_raw_to_raw common size c dest _ progress _ _ = let block = Cstruct.sub buffer 0 rounded_n in ( if n <> rounded_n then Vhd_format_lwt.IO.really_read dest offset block - else - Lwt.return () + else + Lwt.return () ) >>= fun () -> (* Create a cstruct that's an alias to the above block, @@ -1369,8 +1369,8 @@ let serve common_options source source_fd source_format source_protocol ( if not (Sys.file_exists path) then Lwt_unix.openfile path [Unix.O_CREAT; Unix.O_RDONLY] 0o0644 >>= fun fd -> Lwt_unix.close fd - else - return () + else + return () ) >>= fun () -> Vhd_format_lwt.IO.openfile path true >>= fun fd -> diff --git a/ocaml/vhd-tool/src/nbd_input.ml b/ocaml/vhd-tool/src/nbd_input.ml index 119cce665f8..0bc88fa4c18 100644 --- a/ocaml/vhd-tool/src/nbd_input.ml +++ b/ocaml/vhd-tool/src/nbd_input.ml @@ -74,8 +74,8 @@ let raw ?(extent_reader = "/opt/xensource/libexec/get_nbd_extents.py") raw finished at incorrect offset %Ld," offset length final_offset ) - else - Lwt.return_unit + else + Lwt.return_unit ) >|= fun () -> ops in @@ -89,8 +89,8 @@ let raw ?(extent_reader = "/opt/xensource/libexec/get_nbd_extents.py") raw "Nbd_input.raw finished with offset=%Ld <> size=%Ld" offset size ) - else - Lwt.return_unit + else + Lwt.return_unit ) >>= fun () -> Lwt.return F.End | [], _ -> diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 010dad9680c..cfffb9c09d2 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -120,8 +120,8 @@ let waiter printer rpc session_id params task = (fun () -> ( if List.mem_assoc "progress" params then wait_with_progress_bar - else - wait + else + wait ) printer rpc session_id task ) @@ -3277,9 +3277,9 @@ let do_vm_op ?(include_control_vms = false) ?(include_template_vms = false) ( if not multiple then "Multiple matches VMs found. Operation can only be performed \ on one VM at a time" - else - "Multiple matches VMs found. --multiple required to complete the \ - operation" + else + "Multiple matches VMs found. --multiple required to complete \ + the operation" ) with Records.CLI_failed_to_find_param name -> failwith @@ -3303,9 +3303,9 @@ let do_host_op rpc session_id op params ?(multiple = true) ignore_params = ( if not multiple then "Multiple matching hosts found. Operation can only be performed \ on one host at a time" - else - "Multiple matching hosts found. --multiple required to complete \ - the operation" + else + "Multiple matching hosts found. --multiple required to complete \ + the operation" ) let do_sr_op rpc session_id op params ?(multiple = true) ignore_params = @@ -3323,9 +3323,9 @@ let do_sr_op rpc session_id op params ?(multiple = true) ignore_params = ( if not multiple then "Multiple matching SRs found. Operation can only be performed on \ one SR at a time" - else - "Multiple matching SRs found. --multiple required to complete the \ - operation" + else + "Multiple matching SRs found. --multiple required to complete \ + the operation" ) (* Execute f; if we get a no_hosts_available error then print a vm diagnostic table and reraise exception *) @@ -4144,8 +4144,8 @@ let vm_uninstall_common fd _printer rpc session_id params vms = Printf.sprintf "VDI: %s (%s) %s" r.API.vDI_uuid r.API.vDI_name_label ( if List.length r.API.vDI_VBDs <= 1 then "" - else - " ** WARNING: disk is shared by other VMs" + else + " ** WARNING: disk is shared by other VMs" ) in let string_of_vm vm = @@ -4413,13 +4413,13 @@ let vm_shutdown printer rpc session_id params = |> waiter printer rpc session_id params ) params ["progress"] - else - do_vm_op printer rpc session_id - (fun vm -> - Client.Async.VM.clean_shutdown ~rpc ~session_id ~vm:(vm.getref ()) - |> waiter printer rpc session_id params - ) - params ["progress"] + else + do_vm_op printer rpc session_id + (fun vm -> + Client.Async.VM.clean_shutdown ~rpc ~session_id ~vm:(vm.getref ()) + |> waiter printer rpc session_id params + ) + params ["progress"] ) let vm_reboot printer rpc session_id params = @@ -4429,10 +4429,10 @@ let vm_reboot printer rpc session_id params = do_vm_op printer rpc session_id (fun vm -> Client.VM.hard_reboot ~rpc ~session_id ~vm:(vm.getref ())) params [] - else - do_vm_op printer rpc session_id - (fun vm -> Client.VM.clean_reboot ~rpc ~session_id ~vm:(vm.getref ())) - params [] + else + do_vm_op printer rpc session_id + (fun vm -> Client.VM.clean_reboot ~rpc ~session_id ~vm:(vm.getref ())) + params [] ) let vm_compute_maximum_memory printer rpc session_id params = @@ -4897,8 +4897,8 @@ let vm_disk_list_aux vm is_cd_list printer rpc session_id params = select_fields params' vbdrecords ( if is_cd_list then ["uuid"; "vm-name-label"; "userdevice"; "empty"] - else - ["uuid"; "vm-name-label"; "userdevice"] + else + ["uuid"; "vm-name-label"; "userdevice"] ) in let params' = @@ -5636,8 +5636,8 @@ let vm_import fd _printer rpc session_id params = prefix ( if vm_metadata_only then Constants.import_metadata_uri - else - Constants.import_uri + else + Constants.import_uri ) (Ref.string_of session_id) (Ref.string_of task_id) full_restore force dry_run @@ -5897,8 +5897,8 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b&export_snapshots=%b" ( if vm_metadata_only then Constants.export_metadata_uri - else - Constants.export_uri + else + Constants.export_uri ) (Ref.string_of session_id) (Ref.string_of exporttask) (Ref.string_of (vm.getref ())) @@ -7273,8 +7273,8 @@ let audit_log_get fd _printer rpc session_id params = (if since = "" then " " else Printf.sprintf " (since \"%s\") " since) ( if String.length filename <= 255 then filename (* make sure filename has a reasonable length in the logs *) - else - String.sub filename 0 255 + else + String.sub filename 0 255 ) in let query = diff --git a/ocaml/xapi-cli-server/cli_util.ml b/ocaml/xapi-cli-server/cli_util.ml index ddb077fabb6..86e3401b57a 100644 --- a/ocaml/xapi-cli-server/cli_util.ml +++ b/ocaml/xapi-cli-server/cli_util.ml @@ -154,8 +154,8 @@ let track_http_operation ?use_existing_task ?(progress_bar = false) fd rpc (* Wait for the task to complete *) ( if progress_bar then wait_for_task_completion_with_progress fd - else - wait_for_task_completion + else + wait_for_task_completion ) rpc session_id task_id ; Thread.join receive_heartbeats ; diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 168c59795cb..28fdefd56c2 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -2991,8 +2991,8 @@ let host_record rpc session_id host = ~value: ( if s = "" then Ref.null - else - Client.SR.get_by_uuid ~rpc ~session_id ~uuid:s + else + Client.SR.get_by_uuid ~rpc ~session_id ~uuid:s ) ) () @@ -3003,8 +3003,8 @@ let host_record rpc session_id host = ~value: ( if s = "" then Ref.null - else - Client.SR.get_by_uuid ~rpc ~session_id ~uuid:s + else + Client.SR.get_by_uuid ~rpc ~session_id ~uuid:s ) ) () diff --git a/ocaml/xapi-idl/cluster/cluster_cli.ml b/ocaml/xapi-idl/cluster/cluster_cli.ml index cf9690ba9fa..1f9380bc081 100644 --- a/ocaml/xapi-idl/cluster/cluster_cli.ml +++ b/ocaml/xapi-idl/cluster/cluster_cli.ml @@ -1,7 +1,6 @@ (* Cluster CLI *) open Cluster_interface - module Cmds = LocalAPI (Cmdlinergen.Gen ()) let doc = diff --git a/ocaml/xapi-idl/guard/privileged/xapiguard_cli.ml b/ocaml/xapi-idl/guard/privileged/xapiguard_cli.ml index bb1ad85f59b..5df31b268b6 100644 --- a/ocaml/xapi-idl/guard/privileged/xapiguard_cli.ml +++ b/ocaml/xapi-idl/guard/privileged/xapiguard_cli.ml @@ -14,7 +14,6 @@ module I = Xapi_idl_guard_privileged.Interface module C = Xapi_idl_guard_privileged.Client - module Cmds = I.RPC_API (Cmdlinergen.Gen ()) let doc = diff --git a/ocaml/xapi-idl/guard/varstored/varstored_cli.ml b/ocaml/xapi-idl/guard/varstored/varstored_cli.ml index c8440187147..7e1e4c6837b 100644 --- a/ocaml/xapi-idl/guard/varstored/varstored_cli.ml +++ b/ocaml/xapi-idl/guard/varstored/varstored_cli.ml @@ -13,7 +13,6 @@ *) module Cmds = Xapi_idl_guard_varstored.Interface.RPC_API (Cmdlinergen.Gen ()) - open! Cmdliner let cli () = diff --git a/ocaml/xapi-idl/memory/memory.ml b/ocaml/xapi-idl/memory/memory.ml index 8b4f50e113e..99951f7e3e8 100644 --- a/ocaml/xapi-idl/memory/memory.ml +++ b/ocaml/xapi-idl/memory/memory.ml @@ -106,9 +106,9 @@ let mib_of_bytes_used value = divide_rounding_up value bytes_per_mib let mib_of_kib_used value = divide_rounding_up value kib_per_mib let mib_of_pages_used value = divide_rounding_up value pages_per_mib - (* === Domain memory breakdown - ======================================================= *) - (* +(* === Domain memory breakdown + ======================================================= *) +(* ╤ ╔══════════╗ ╤ │ ║ shadow ║ │ │ ╠══════════╣ │ @@ -133,7 +133,7 @@ let mib_of_pages_used value = divide_rounding_up value pages_per_mib │ ║ ║ │ ╧ ╚══════════╝ ╧ *) - [@@ocamlformat "wrap-comments=false"] +[@@ocamlformat "wrap-comments=false"] (* === Domain memory breakdown: HVM guests =========================================== *) diff --git a/ocaml/xapi-idl/memory/memory_cli.ml b/ocaml/xapi-idl/memory/memory_cli.ml index 987101e4708..0aa2719ed10 100644 --- a/ocaml/xapi-idl/memory/memory_cli.ml +++ b/ocaml/xapi-idl/memory/memory_cli.ml @@ -1,7 +1,6 @@ (* Memory CLI *) open Memory_interface - module Cmds = API (Cmdlinergen.Gen ()) let doc = diff --git a/ocaml/xapi-idl/network/network_cli.ml b/ocaml/xapi-idl/network/network_cli.ml index 7bf0010928a..4e328c8818d 100644 --- a/ocaml/xapi-idl/network/network_cli.ml +++ b/ocaml/xapi-idl/network/network_cli.ml @@ -1,7 +1,6 @@ (* Network CLI *) open Network_interface - module Cmds = Interface_API (Cmdlinergen.Gen ()) let doc = diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 4a56577c031..f708bb30dfc 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -17,13 +17,9 @@ module B = Backtrace open Core open Async open Xapi_storage_script_types - module Plugin_client = Xapi_storage.Plugin.Plugin (Rpc_async.GenClient ()) - module Volume_client = Xapi_storage.Control.Volume (Rpc_async.GenClient ()) - module Sr_client = Xapi_storage.Control.Sr (Rpc_async.GenClient ()) - module Datapath_client = Xapi_storage.Data.Datapath (Rpc_async.GenClient ()) let ( >>>= ) = Deferred.Result.( >>= ) diff --git a/ocaml/xapi-storage/generator/lib/control.ml b/ocaml/xapi-storage/generator/lib/control.ml index 8e70614da2b..93b2800a766 100644 --- a/ocaml/xapi-storage/generator/lib/control.ml +++ b/ocaml/xapi-storage/generator/lib/control.ml @@ -589,7 +589,6 @@ module Sr (R : RPC) = struct end module V = Volume (Codegen.Gen ()) - module S = Sr (Codegen.Gen ()) let interfaces = diff --git a/ocaml/xapi-storage/generator/lib/data.ml b/ocaml/xapi-storage/generator/lib/data.ml index fb77cc9ce18..142848b4d6d 100644 --- a/ocaml/xapi-storage/generator/lib/data.ml +++ b/ocaml/xapi-storage/generator/lib/data.ml @@ -362,7 +362,6 @@ To mirror a VDI a sequence of these API calls is required: end module DPCode = Datapath (Codegen.Gen ()) - module DCode = Data (Codegen.Gen ()) let interfaces = diff --git a/ocaml/xapi/certificates.ml b/ocaml/xapi/certificates.ml index 7907c302225..6b871e686c5 100644 --- a/ocaml/xapi/certificates.ml +++ b/ocaml/xapi/certificates.ml @@ -237,9 +237,7 @@ end = struct | [] -> D.error "unable to find certificate with name='%s'" name ; raise - Api_errors.( - Server_error (invalid_value, ["certificate:name"; name]) - ) + Api_errors.(Server_error (invalid_value, ["certificate:name"; name])) | xs -> let ref_str = xs |> List.map Ref.short_string_of |> String.concat ", " diff --git a/ocaml/xapi/console.ml b/ocaml/xapi/console.ml index 149cc3a997f..f682289163d 100644 --- a/ocaml/xapi/console.ml +++ b/ocaml/xapi/console.ml @@ -51,9 +51,8 @@ let address_of_console __context console : address option = let id = Xapi_xenops.id_of_vm ~__context ~self:vm in let dbg = Context.string_of_task __context in let open Xapi_xenops_queue in - let module Client = ( val make_client (queue_of_vm ~__context ~self:vm) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in let _, s = Client.VM.stat dbg id in let proto = @@ -71,8 +70,8 @@ let address_of_console __context console : address option = Some ( if console.Vm.path = "" then Port console.Vm.port - else - Path console.Vm.path + else + Path console.Vm.path ) with e -> debug "%s" (Printexc.to_string e) ; diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index f00edb1a31a..49ccc7b0c57 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -223,16 +223,16 @@ let make_vm ?(with_snapshot_metadata = false) ~preserve_power_state table ; API.vM_suspend_VDI= ( if preserve_power_state then lookup table (Ref.string_of vm.API.vM_suspend_VDI) - else - Ref.null + else + Ref.null ) ; API.vM_is_a_snapshot= (if with_snapshot_metadata then vm.API.vM_is_a_snapshot else false) ; API.vM_snapshot_of= ( if with_snapshot_metadata then lookup table (Ref.string_of vm.API.vM_snapshot_of) - else - Ref.null + else + Ref.null ) ; API.vM_snapshots= (if with_snapshot_metadata then vm.API.vM_snapshots else []) @@ -241,14 +241,14 @@ let make_vm ?(with_snapshot_metadata = false) ~preserve_power_state table ; API.vM_transportable_snapshot_id= ( if with_snapshot_metadata then vm.API.vM_transportable_snapshot_id - else - "" + else + "" ) ; API.vM_parent= ( if with_snapshot_metadata then lookup table (Ref.string_of vm.API.vM_parent) - else - Ref.null + else + Ref.null ) ; API.vM_current_operations= [] ; API.vM_allowed_operations= [] @@ -398,8 +398,8 @@ let make_vgpu table ~preserve_power_state __context self = API.vGPU_currently_attached= ( if preserve_power_state then vgpu.API.vGPU_currently_attached - else - false + else + false ) ; API.vGPU_GPU_group= lookup table (Ref.string_of vgpu.API.vGPU_GPU_group) ; API.vGPU_type= lookup table (Ref.string_of vgpu.API.vGPU_type) diff --git a/ocaml/xapi/extauth_plugin_ADpbis.ml b/ocaml/xapi/extauth_plugin_ADpbis.ml index 9191cd08f7b..dd14ab6df4c 100644 --- a/ocaml/xapi/extauth_plugin_ADpbis.ml +++ b/ocaml/xapi/extauth_plugin_ADpbis.ml @@ -1039,11 +1039,11 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct let pbis_failure = try ( if - not - (List.mem_assoc "user" config_params - && List.mem_assoc "pass" config_params - ) - then + not + (List.mem_assoc "user" config_params + && List.mem_assoc "pass" config_params + ) + then (* no windows admin+pass have been provided: leave the pbis host in the AD database *) (* execute the pbis domain-leave cmd *) (* this function will raise an exception if something goes wrong *) @@ -1051,23 +1051,23 @@ module AuthADlw : Auth_signature.AUTH_MODULE = struct pbis_common !Xapi_globs.domain_join_cli_cmd ["leave"] in () - else - (* windows admin+pass have been provided: ask pbis to remove host from AD database *) - let _user = List.assoc "user" config_params in - let pass = List.assoc "pass" config_params in - (* we need to make sure that the user passed to domaijoin-cli command is in the UPN syntax (user@domain.com) *) - let user = - convert_nt_to_upn_username - (get_full_subject_name ~use_nt_format:false _user) - in - (* execute the pbis domain-leave cmd *) - (* this function will raise an exception if something goes wrong *) - let (_ : (string * string) list) = - pbis_common_with_password pass - !Xapi_globs.domain_join_cli_cmd - ["leave"; user] - in - () + else + (* windows admin+pass have been provided: ask pbis to remove host from AD database *) + let _user = List.assoc "user" config_params in + let pass = List.assoc "pass" config_params in + (* we need to make sure that the user passed to domaijoin-cli command is in the UPN syntax (user@domain.com) *) + let user = + convert_nt_to_upn_username + (get_full_subject_name ~use_nt_format:false _user) + in + (* execute the pbis domain-leave cmd *) + (* this function will raise an exception if something goes wrong *) + let (_ : (string * string) list) = + pbis_common_with_password pass + !Xapi_globs.domain_join_cli_cmd + ["leave"; user] + in + () ) ; None (* no failure observed in pbis *) with e -> diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index cf1996e598e..5cd275d57d5 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -1020,8 +1020,8 @@ module VDI : HandlerTools = struct vdi_record.API.vDI_location ( if config.force then "ignoring error because '--force' is set" - else - "treating as fatal and abandoning import" + else + "treating as fatal and abandoning import" ) ; if config.force then Skip @@ -1326,9 +1326,9 @@ module VBD : HandlerTools = struct (false, false) in ( if - vbd_record.API.vBD_currently_attached - && not (exists vbd_record.API.vBD_VDI state.table) - then + vbd_record.API.vBD_currently_attached + && not (exists vbd_record.API.vBD_VDI state.table) + then (* It's only ok if it's a CDROM attached to an HVM guest, or it's part of SXM and we know the sender would eject it. *) let will_eject = dry_run && live && original_vm.API.vM_power_state <> `Suspended @@ -1943,8 +1943,9 @@ let update_snapshot_and_parent_links ~__context state = let aux (cls, _, ref) = let ref = Ref.of_string ref in ( if - cls = Datamodel_common._vm && Db.VM.get_is_a_snapshot ~__context ~self:ref - then + cls = Datamodel_common._vm + && Db.VM.get_is_a_snapshot ~__context ~self:ref + then let snapshot_of = Db.VM.get_snapshot_of ~__context ~self:ref in if snapshot_of <> Ref.null then ( debug "lookup for snapshot_of = '%s'" (Ref.string_of snapshot_of) ; diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index b4cb2466ef3..a7354fce45e 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -412,8 +412,8 @@ let base_vdi_of_req ~__context (req : Http.Request.t) = Some ( if Db.is_valid_ref __context (Ref.of_string base) then Ref.of_string base - else - Db.VDI.get_by_uuid ~__context ~uuid:base + else + Db.VDI.get_by_uuid ~__context ~uuid:base ) else None diff --git a/ocaml/xapi/memory_check.ml b/ocaml/xapi/memory_check.ml index 16a541e1779..51bc945904a 100644 --- a/ocaml/xapi/memory_check.ml +++ b/ocaml/xapi/memory_check.ml @@ -222,8 +222,8 @@ let host_compute_free_memory_with_maximum_compression ?(dump_stats = false) (Db.VM.get_uuid ~__context ~self:v) ( if List.mem v summary.resident then "resident here" - else - "scheduled to be resident here" + else + "scheduled to be resident here" ) reqd (mib reqd) ) diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 4d08bb5933a..bcf427fdfdd 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -2236,7 +2236,7 @@ functor the suspend VDI: we want to minimise the probability that the operation fails part-way through. *) ( if Db.VM.get_power_state ~__context ~self:snapshot = `Suspended - then + then let suspend_VDI = Db.VM.get_suspend_VDI ~__context ~self:snapshot in diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index af11dc4dc0a..1d990253651 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -196,8 +196,7 @@ let assert_url_is_valid ~url = ) ) | _, None -> - raise - Api_errors.(Server_error (internal_error, ["invalid host in url"])) + raise Api_errors.(Server_error (internal_error, ["invalid host in url"])) | _ -> raise Api_errors.(Server_error (internal_error, ["invalid scheme in url"])) diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index da8c07d4646..292c96b4f52 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -726,8 +726,8 @@ let refresh_local_vdi_activations ~__context = info "Unlocking VDI %s (because %s)" (Ref.string_of vdi_ref) ( if i_locked_it then "I locked it and then restarted" - else - "it was leaked (pool join?)" + else + "it was leaked (pool join?)" ) ; try List.iter diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index 8705896d719..67fecb21e6b 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -87,8 +87,8 @@ let vdi_info_of_vdi_rec __context vdi_rec = ; snapshot_of= ( if Db.is_valid_ref __context vdi_rec.API.vDI_snapshot_of then Db.VDI.get_uuid ~__context ~self:vdi_rec.API.vDI_snapshot_of - else - "" + else + "" ) |> Storage_interface.Vdi.of_string ; read_only= vdi_rec.API.vDI_read_only diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 3f2cdc7f619..cf53f2082f0 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -625,8 +625,8 @@ functor (Vdi_automaton.Attach ( if read_write then Vdi_automaton.RW - else - Vdi_automaton.RO + else + Vdi_automaton.RO ) ) in @@ -1107,8 +1107,8 @@ functor let errors = ( if errors <> [] then "The following errors have been logged:" - else - "No errors have been logged." + else + "No errors have been logged." ) :: errors in @@ -1404,5 +1404,4 @@ let initialise () = !host_state_path module Impl = Wrapper (Storage_smapiv1.SMAPIv1) - module Server = Storage_interface.Server (Impl) () diff --git a/ocaml/xapi/vm_platform.ml b/ocaml/xapi/vm_platform.ml index a4cd195bcce..ae43c033685 100644 --- a/ocaml/xapi/vm_platform.ml +++ b/ocaml/xapi/vm_platform.ml @@ -191,7 +191,7 @@ let sanity_check ~platformdata ~firmware ~vcpu_max ~vcpu_at_startup:_ () ) ; ( if check_cores_per_socket && List.mem_assoc "cores-per-socket" platformdata - then + then let cps_str = List.assoc "cores-per-socket" platformdata in let vcpus = Int64.to_int vcpu_max in try diff --git a/ocaml/xapi/workload_balancing.ml b/ocaml/xapi/workload_balancing.ml index 4a1f0a37b75..2d8300c45f1 100644 --- a/ocaml/xapi/workload_balancing.ml +++ b/ocaml/xapi/workload_balancing.ml @@ -266,8 +266,8 @@ let parse_result_code meth xml_data response initial_error enable_log = ) ( if enable_log then response - else - "Logging output disabled for this call." + else + "Logging output disabled for this call." ) in let message = diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index 4e498da91a2..36fe872bec6 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -175,8 +175,7 @@ let find_cluster_host ~__context ~host = (* should never happen; this indicates a bug *) let msg = "Multiple cluster_hosts found for host" in error "%s %s" msg (Db.Host.get_uuid ~__context ~self:host) ; - raise - Api_errors.(Server_error (internal_error, [msg; Ref.string_of host])) + raise Api_errors.(Server_error (internal_error, [msg; Ref.string_of host])) | _ -> None diff --git a/ocaml/xapi/xapi_diagnostics.ml b/ocaml/xapi/xapi_diagnostics.ml index 5c88358bca1..4c709f0d055 100644 --- a/ocaml/xapi/xapi_diagnostics.ml +++ b/ocaml/xapi/xapi_diagnostics.ml @@ -69,18 +69,18 @@ let network_stats ~__context ~host:_ ~params = ; (if has_param "uri" then [uri] else []) ; ( if has_param "requests" then [string_of_int stats.Http_svr.Stats.n_requests] - else - [] + else + [] ) ; ( if has_param "connections" then [string_of_int stats.Http_svr.Stats.n_connections] - else - [] + else + [] ) ; ( if has_param "framed" then [string_of_int stats.Http_svr.Stats.n_framed] - else - [] + else + [] ) ] ) diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 4d30c8d9069..5e10d5590a1 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -550,16 +550,16 @@ let from_inner __context session subs from from_t deadline = (* mtime guaranteed to always be larger than ctime *) ( ( if created > !last_generation then (table, objref, created) :: creates - else - creates + else + creates ) , ( if - modified > !last_generation - && not (created > !last_generation) - then + modified > !last_generation + && not (created > !last_generation) + then (table, objref, modified) :: mods - else - mods + else + mods ) , (* Only have a mod event if we don't have a created event *) deletes @@ -603,7 +603,7 @@ let from_inner __context session subs from from_t deadline = with_call session subs (fun sub -> let rec grab_nonempty_range () = let ( (msg_gen, messages, _tableset, (creates, mods, deletes, last)) - as result + as result ) = Db_lock.with_lock (fun () -> grab_range (Db_backend.make ())) in diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml index d5840f2ddb9..bc99f854768 100644 --- a/ocaml/xapi/xapi_ha.ml +++ b/ocaml/xapi/xapi_ha.ml @@ -1697,8 +1697,8 @@ let disable_internal __context = then we need to try the without-statefile procedure: *) ( if i_have_statefile_access () then exn_to_bool attempt_disable_through_statefile - else - false + else + false ) || exn_to_bool attempt_disable_without_statefile in diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 043063340b3..4fbf46860f2 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -507,10 +507,10 @@ let compute_restart_plan ~__context ~all_protected_vms ~live_set (fun (_, (vm_ref, snapshot)) -> total_memory_of_vm ~__context ( if not $ Db.VM.get_is_control_domain ~__context ~self:vm_ref - then + then Memory_check.Static_max - else - Memory_check.Dynamic_max + else + Memory_check.Dynamic_max ) snapshot ) @@ -526,10 +526,10 @@ let compute_restart_plan ~__context ~all_protected_vms ~live_set (fun (_, (vm_ref, snapshot)) -> total_memory_of_vm ~__context ( if not $ Db.VM.get_is_control_domain ~__context ~self:vm_ref - then + then Memory_check.Static_max - else - Memory_check.Dynamic_max + else + Memory_check.Dynamic_max ) snapshot ) diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index c1fed8daeb3..d609690871c 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1075,8 +1075,8 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address ~virtual_hardware_platform_versions: ( if host_is_us then Xapi_globs.host_virtual_hardware_platform_versions - else - [0L] + else + [0L] ) ~control_domain:Ref.null ~updates_requiring_reboot:[] ~iscsi_iqn:"" ~multipathing:false ~uefi_certificates:"" ~editions:[] ~pending_guidances:[] @@ -2230,9 +2230,9 @@ let reset_networking ~__context ~host = (fun self -> debug "destroying PIF %s" (Db.PIF.get_uuid ~__context ~self) ; ( if - Db.PIF.get_physical ~__context ~self = true - || Db.PIF.get_bond_master_of ~__context ~self <> [] - then + Db.PIF.get_physical ~__context ~self = true + || Db.PIF.get_bond_master_of ~__context ~self <> [] + then let metrics = Db.PIF.get_metrics ~__context ~self in Db.PIF_metrics.destroy ~__context ~self:metrics ) ; @@ -2897,9 +2897,7 @@ let set_sched_gran ~__context ~self ~value = with e -> error "Failed to update sched-gran: %s" (Printexc.to_string e) ; raise - Api_errors.( - Server_error (internal_error, ["Failed to update sched-gran"]) - ) + Api_errors.(Server_error (internal_error, ["Failed to update sched-gran"])) let get_sched_gran ~__context ~self = if Helpers.get_localhost ~__context <> self then diff --git a/ocaml/xapi/xapi_observer.ml b/ocaml/xapi/xapi_observer.ml index 1aac6abb0d6..b3f4d36e0dc 100644 --- a/ocaml/xapi/xapi_observer.ml +++ b/ocaml/xapi/xapi_observer.ml @@ -250,15 +250,16 @@ let startup_components = List.filter (( <> ) Component.Xapi_clusterd) Component.all let get_forwarder c = - let module Forwarder = ( val match c with - | Component.Xapi -> - (module Observer) - | Component.Xenopsd -> - (module Xapi_xenops.Observer) - | Component.Xapi_clusterd -> - (module Xapi_cluster.Observer) - : ObserverInterface - ) + let module Forwarder = + ( val match c with + | Component.Xapi -> + (module Observer) + | Component.Xenopsd -> + (module Xapi_xenops.Observer) + | Component.Xapi_clusterd -> + (module Xapi_cluster.Observer) + : ObserverInterface + ) in (module Forwarder : ObserverInterface) @@ -275,9 +276,7 @@ let assert_valid_hosts ~__context hosts = (fun self -> if not (Db.is_valid_ref __context self) then raise - Api_errors.( - Server_error (invalid_value, ["host"; Ref.string_of self]) - ) + Api_errors.(Server_error (invalid_value, ["host"; Ref.string_of self])) ) hosts diff --git a/ocaml/xapi/xapi_periodic_scheduler.ml b/ocaml/xapi/xapi_periodic_scheduler.ml index c560ad43309..1edcb938857 100644 --- a/ocaml/xapi/xapi_periodic_scheduler.ml +++ b/ocaml/xapi/xapi_periodic_scheduler.ml @@ -39,9 +39,7 @@ module Clock = struct t | None -> raise - Api_errors.( - Server_error (internal_error, ["clock overflow"; __LOC__]) - ) + Api_errors.(Server_error (internal_error, ["clock overflow"; __LOC__])) end let add_to_queue ?(signal = true) name ty start newfunc = diff --git a/ocaml/xapi/xapi_pif_helpers.ml b/ocaml/xapi/xapi_pif_helpers.ml index 29c91cc8055..fc6c9708511 100644 --- a/ocaml/xapi/xapi_pif_helpers.ml +++ b/ocaml/xapi/xapi_pif_helpers.ml @@ -244,8 +244,7 @@ let assert_not_vlan_slave ~__context ~self = List.map (fun self -> Db.VLAN.get_uuid ~__context ~self) vlans |> String.concat "; " |> debug "PIF has associated VLANs: [ %s ]" ; - raise - Api_errors.(Server_error (pif_vlan_still_exists, [Ref.string_of self])) + raise Api_errors.(Server_error (pif_vlan_still_exists, [Ref.string_of self])) ) let is_device_underneath_same_type ~__context pif1 pif2 = diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 11a9dd76e47..04aac2ef09c 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -3536,8 +3536,7 @@ let configure_repository_proxy ~__context ~self ~url ~username ~password = | u, p when u <> "" && p <> "" -> if String.contains u '\n' || String.contains p '\n' then ( error "getting invalid username/password of the repository proxy" ; - raise - Api_errors.(Server_error (invalid_repository_proxy_credential, [])) + raise Api_errors.(Server_error (invalid_repository_proxy_credential, [])) ) | _ -> () diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index d1dfecf122e..1a9b8544bad 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -255,8 +255,8 @@ let create_yum_config ~__context ~self ~url = ; Printf.sprintf "baseurl=%s" url ; ( if signed then Printf.sprintf "gpgkey=file:///etc/pki/rpm-gpg/%s" key - else - "" + else + "" ) ; "" (* Newline at the end of the file *) ] diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 2c1b33bb675..455dcef9c55 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -292,9 +292,7 @@ let do_local_auth uname pwd = try Pam.authenticate uname (Bytes.unsafe_to_string pwd) with Failure msg -> raise - Api_errors.( - Server_error (session_authentication_failed, [uname; msg]) - ) + Api_errors.(Server_error (session_authentication_failed, [uname; msg])) ) let do_local_change_password uname newpwd = @@ -1295,8 +1293,8 @@ let logout_subject_identifier ~__context ~subject_identifier = (trackid current_session) ( if Db.Session.get_is_local_superuser ~__context ~self:current_session then local_superuser - else - "" + else + "" ) (Db.Session.get_auth_user_sid ~__context ~self:current_session) subject_identifier diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 4a2b5e1cebe..b44c8bf5916 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -142,9 +142,7 @@ let valid_operations ~__context ?op record _ref' : table = List.filter (fun f -> not - Smint.( - List.mem (capability_of_feature f) [Vdi_create; Vdi_delete] - ) + Smint.(List.mem (capability_of_feature f) [Vdi_create; Vdi_delete]) ) sm_features else diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 9e5788895b1..5144ef7ef7a 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -350,8 +350,8 @@ let copy ~__context ~vm ~preserve_mac_address vif = ~mAC: ( if preserve_mac_address then all.API.vIF_MAC - else - "" (* leave blank = generate new mac from vm random seed *) + else + "" (* leave blank = generate new mac from vm random seed *) ) ~mTU:all.API.vIF_MTU ~other_config:all.API.vIF_other_config ~qos_algorithm_type:all.API.vIF_qos_algorithm_type diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index cf02d593f7e..11c6c94859b 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -440,8 +440,8 @@ let shutdown ~__context ~vm = clean_shutdown_with_timeout ~__context ~vm ( if db_timeout > 0L then Int64.to_float db_timeout - else - !Xapi_globs.domain_shutdown_total_timeout + else + !Xapi_globs.domain_shutdown_total_timeout ) with e -> warn @@ -479,9 +479,8 @@ let power_state_reset ~__context ~vm = if resident = localhost then ( let open Xenops_interface in let open Xapi_xenops_queue in - let module Client = ( val make_client (queue_of_vm ~__context ~self:vm) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in let running = try diff --git a/ocaml/xapi/xapi_vm_clone.ml b/ocaml/xapi/xapi_vm_clone.ml index 8aac784002e..169d0b3d987 100644 --- a/ocaml/xapi/xapi_vm_clone.ml +++ b/ocaml/xapi/xapi_vm_clone.ml @@ -70,9 +70,7 @@ let wait_for_subtask ?progress_minmax ~__context task = Db.Task.get_by_uuid ~__context ~uuid:task_rec.API.task_uuid in raise - Api_errors.( - Server_error (task_cancelled, [Ref.string_of task_id]) - ) + Api_errors.(Server_error (task_cancelled, [Ref.string_of task_id])) | `failure -> ( match task_rec.API.task_error_info with | code :: params -> @@ -346,8 +344,8 @@ let copy_vm_record ?snapshot_info_record ~__context ~vm ~disk_op ~new_name ~snapshot_time: ( if is_a_snapshot then Date.of_float (Unix.gettimeofday ()) - else - Date.never + else + Date.never ) ~snapshot_info: ( match snapshot_info_record with diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index d6cca3b128a..538dda7bb01 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -82,45 +82,45 @@ let set_is_a_template ~__context ~self ~value = with _ -> warn "Could not update VM install time because metrics object was missing" - else - (* VM must be halted, or we couldn't have got this far. - * If we have a halted VM with ha_always_run = true, ha_restart_priority = "restart" - * and HA is enabled on the pool, then HA is about to restart the VM and we should - * block converting it into a template. - * - * This logic can't live in the allowed_operations code, or we'd have to update VM.allowed_operations - * across the pool when enabling or disabling HA. *) - let ha_enabled = - Db.Pool.get_ha_enabled ~__context ~self:(Helpers.get_pool ~__context) - in - if ha_enabled && Helpers.is_xha_protected ~__context ~self then - raise - (Api_errors.Server_error - (Api_errors.vm_is_protected, [Ref.string_of self]) - ) - (* If the VM is not protected then we can convert the VM to a template, - * but we should clear the ha_always_run flag - * (which will be true if the VM has ha_restart_priority = "restart" and was shut down from inside). - * - * We don't want templates to have this flag, or HA will try to start them. *) else - Db.VM.set_ha_always_run ~__context ~self ~value:false ; - (* Detach all VUSBs before set VM as a template *) - let vusbs = Db.VM.get_VUSBs ~__context ~self in - List.iter - (fun vusb -> try Db.VUSB.destroy ~__context ~self:vusb with _ -> ()) - vusbs ; - (* Destroy any attached pvs proxies *) - Db.VM.get_VIFs ~__context ~self - |> List.filter_map (fun vif -> - Pvs_proxy_control.find_proxy_for_vif ~__context ~vif - ) - |> List.rev - |> List.iter (fun p -> Db.PVS_proxy.destroy ~__context ~self:p) ; - (* delete the vm metrics associated with the vm if it exists, when we templat'ize it *) - finally - (fun () -> Db.VM_metrics.destroy ~__context ~self:m) - (fun () -> Db.VM.set_metrics ~__context ~self ~value:Ref.null) + (* VM must be halted, or we couldn't have got this far. + * If we have a halted VM with ha_always_run = true, ha_restart_priority = "restart" + * and HA is enabled on the pool, then HA is about to restart the VM and we should + * block converting it into a template. + * + * This logic can't live in the allowed_operations code, or we'd have to update VM.allowed_operations + * across the pool when enabling or disabling HA. *) + let ha_enabled = + Db.Pool.get_ha_enabled ~__context ~self:(Helpers.get_pool ~__context) + in + if ha_enabled && Helpers.is_xha_protected ~__context ~self then + raise + (Api_errors.Server_error + (Api_errors.vm_is_protected, [Ref.string_of self]) + ) + (* If the VM is not protected then we can convert the VM to a template, + * but we should clear the ha_always_run flag + * (which will be true if the VM has ha_restart_priority = "restart" and was shut down from inside). + * + * We don't want templates to have this flag, or HA will try to start them. *) + else + Db.VM.set_ha_always_run ~__context ~self ~value:false ; + (* Detach all VUSBs before set VM as a template *) + let vusbs = Db.VM.get_VUSBs ~__context ~self in + List.iter + (fun vusb -> try Db.VUSB.destroy ~__context ~self:vusb with _ -> ()) + vusbs ; + (* Destroy any attached pvs proxies *) + Db.VM.get_VIFs ~__context ~self + |> List.filter_map (fun vif -> + Pvs_proxy_control.find_proxy_for_vif ~__context ~vif + ) + |> List.rev + |> List.iter (fun p -> Db.PVS_proxy.destroy ~__context ~self:p) ; + (* delete the vm metrics associated with the vm if it exists, when we templat'ize it *) + finally + (fun () -> Db.VM_metrics.destroy ~__context ~self:m) + (fun () -> Db.VM.set_metrics ~__context ~self ~value:Ref.null) ) ; Db.VM.set_is_a_template ~__context ~self ~value diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index 05c7b2879e3..53f6076e89d 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -69,12 +69,12 @@ let allowed_power_states ~__context ~vmr ~(op : API.vm_operations) = `Halted :: ( if - vmr.Db_actions.vM_is_a_snapshot - || Helpers.clone_suspended_vm_enabled ~__context - then + vmr.Db_actions.vM_is_a_snapshot + || Helpers.clone_suspended_vm_enabled ~__context + then [`Suspended] - else - [] + else + [] ) | `create_template (* Don't touch until XMLRPC unmarshal code is able to pre-blank fields on input. *) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 6aa703eb933..73cb08de2cb 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -455,8 +455,8 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu = (* XSI-804 avoid boot orders which are the empty string, as qemu * will silently fail to start the VM *) (let open Constants in - assume_default_if_null_empty vm.API.vM_HVM_boot_params - hvm_default_boot_order hvm_boot_params_order + assume_default_if_null_empty vm.API.vM_HVM_boot_params + hvm_default_boot_order hvm_boot_params_order ) ; qemu_disk_cmdline= bool vm.API.vM_platform false "qemu_disk_cmdline" ; qemu_stubdom= false (* Obsolete: implementation removed *) @@ -635,10 +635,10 @@ module MD = struct string_of_int ( if value < min then min - else if value > max then - max - else - value + else if value > max then + max + else + value ) ) ) @@ -1658,9 +1658,8 @@ module Xenopsd_metadata = struct let txt = md |> rpc_of Metadata.t |> Jsonrpc.to_string in info "xenops: VM.import_metadata %s" txt ; let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client (queue_of_vm ~__context ~self) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self) : XENOPS) in let id = Client.VM.import_metadata dbg txt in maybe_persist_md ~__context ~self txt ; @@ -1673,11 +1672,10 @@ module Xenopsd_metadata = struct let dbg = Context.string_of_task_and_tracing __context in info "xenops: VM.remove %s" id ; try - let module Client = ( val make_client - (queue_of_vm ~__context - ~self:(vm_of_id ~__context id) - ) : XENOPS - ) + let module Client = + ( val make_client (queue_of_vm ~__context ~self:(vm_of_id ~__context id)) + : XENOPS + ) in Client.VM.remove dbg id ; (* Once the VM has been successfully removed from xenopsd, remove the caches *) @@ -1698,11 +1696,11 @@ module Xenopsd_metadata = struct with_lock metadata_m (fun () -> info "xenops: VM.export_metadata %s" id ; let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client - (queue_of_vm ~__context - ~self:(vm_of_id ~__context id) - ) : XENOPS - ) + let module Client = + ( val make_client + (queue_of_vm ~__context ~self:(vm_of_id ~__context id)) + : XENOPS + ) in let md = match @@ -1872,9 +1870,8 @@ let update_vm ~__context id = else let previous = Xenops_cache.find_vm id in let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client (queue_of_vm ~__context ~self) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self) : XENOPS) in let info = try Some (Client.VM.stat dbg id) with _ -> None in if Option.map snd info = previous then @@ -2429,9 +2426,8 @@ let update_vbd ~__context (id : string * string) = else let previous = Xenops_cache.find_vbd id in let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client (queue_of_vm ~__context ~self:vm) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in let info = try Some (Client.VBD.stat dbg id) with _ -> None in if Option.map snd info = previous then @@ -2541,9 +2537,8 @@ let update_vif ~__context id = else let previous = Xenops_cache.find_vif id in let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client (queue_of_vm ~__context ~self:vm) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in let info = try Some (Client.VIF.stat dbg id) with _ -> None in if Option.map snd info = previous then @@ -2657,9 +2652,8 @@ let update_pci ~__context id = else let previous = Xenops_cache.find_pci id in let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client (queue_of_vm ~__context ~self:vm) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in let info = try Some (Client.PCI.stat dbg id) with _ -> None in if Option.map snd info = previous then @@ -2733,9 +2727,8 @@ let update_vgpu ~__context id = else let previous = Xenops_cache.find_vgpu id in let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client (queue_of_vm ~__context ~self:vm) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in let info = try Some (Client.VGPU.stat dbg id) with _ -> None in if Option.map snd info = previous then @@ -2805,9 +2798,8 @@ let update_vusb ~__context (id : string * string) = else let previous = Xenops_cache.find_vusb id in let dbg = Context.string_of_task_and_tracing __context in - let module Client = ( val make_client (queue_of_vm ~__context ~self:vm) - : XENOPS - ) + let module Client = + (val make_client (queue_of_vm ~__context ~self:vm) : XENOPS) in let info = try Some (Client.VUSB.stat dbg id) with _ -> None in if Option.map snd info = previous then diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml index 92ca8e8170e..9265084e020 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml @@ -149,9 +149,7 @@ let get_host_stats ?(json = false) ~(start : int64) ~(interval : int64) let sr_rrds_altered = Seq.map (fun (k, v) -> ("sr:" ^ k ^ ":", v.rrd)) srsandrrds in - List.( - concat [host_rrds; of_seq vm_rrds_altered; of_seq sr_rrds_altered] - ) + List.(concat [host_rrds; of_seq vm_rrds_altered; of_seq sr_rrds_altered]) in Rrd_updates.export ~json prefixandrrds start interval cfopt ) diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml index 1168f602188..844ad7f8a17 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml @@ -667,14 +667,14 @@ module Stats_value = struct ; rd_avg_usecs= ( if stats_diff_get 0 > 0L then Int64.div (stats_diff_get 3) (stats_diff_get 0) - else - 0L + else + 0L ) ; wr_avg_usecs= ( if stats_diff_get 4 > 0L then Int64.div (stats_diff_get 7) (stats_diff_get 4) - else - 0L + else + 0L ) ; io_throughput_read_mb= to_float (stats_diff_get 13) /. 1048576. ; io_throughput_write_mb= to_float (stats_diff_get 14) /. 1048576. diff --git a/ocaml/xen-api-client/lib_test/xen_api_test.ml b/ocaml/xen-api-client/lib_test/xen_api_test.ml index 58c5c6f1831..16d4c36128e 100644 --- a/ocaml/xen-api-client/lib_test/xen_api_test.ml +++ b/ocaml/xen-api-client/lib_test/xen_api_test.ml @@ -60,10 +60,10 @@ module Fake_IO = struct return ( if Queue.is_empty ic then false - else - let chunk = Queue.pop ic in - String.blit chunk 0 buf off len ; - true + else + let chunk = Queue.pop ic in + String.blit chunk 0 buf off len ; + true ) let read_exactly ic len = diff --git a/ocaml/xen-api-client/lwt/disk.ml b/ocaml/xen-api-client/lwt/disk.ml index 053d6840a85..fb8f4fc9500 100644 --- a/ocaml/xen-api-client/lwt/disk.ml +++ b/ocaml/xen-api-client/lwt/disk.ml @@ -70,8 +70,8 @@ let start_upload ~chunked ~uri = let open Cohttp in ( if use_ssl then Data_channel.of_ssl_fd sock - else - Data_channel.of_fd ~seekable:false sock + else + Data_channel.of_fd ~seekable:false sock ) >>= fun c -> let module Request = Request.Make (Cohttp_unbuffered_io) in diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index ba1d9f456d9..ec883f3deed 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -403,8 +403,8 @@ let parse_vif vm_id (x, idx) = ; backend= ( if List.mem_assoc _bridge kvpairs then Network.Local (List.assoc _bridge kvpairs) - else - Network.Local "xenbr0" + else + Network.Local "xenbr0" ) ; other_config= [] ; locking_mode= Vif.default_locking_mode @@ -553,35 +553,35 @@ let add' _copts x () = ; bootloader_args= "" ; devices } - else if mem _kernel then - Direct - { - kernel= - find _kernel |> string |> canonicalise_filename - ; cmdline= - (if mem _root then find _root |> string else "") - ; ramdisk= - ( if mem _ramdisk then - Some - (find _ramdisk - |> string - |> canonicalise_filename - ) - else - None - ) - } - else ( - List.iter - (Printf.fprintf stderr "%s\n") - [ - "I couldn't determine how to start this VM." - ; Printf.sprintf - "A PV guest needs either %s or %s and %s" - _bootloader _kernel _ramdisk - ] ; - exit 1 - ) + else if mem _kernel then + Direct + { + kernel= + find _kernel |> string |> canonicalise_filename + ; cmdline= + (if mem _root then find _root |> string else "") + ; ramdisk= + ( if mem _ramdisk then + Some + (find _ramdisk + |> string + |> canonicalise_filename + ) + else + None + ) + } + else ( + List.iter + (Printf.fprintf stderr "%s\n") + [ + "I couldn't determine how to start this VM." + ; Printf.sprintf + "A PV guest needs either %s or %s and %s" + _bootloader _kernel _ramdisk + ] ; + exit 1 + ) ) } | false -> @@ -895,8 +895,8 @@ let export copts metadata xm filename (x : Vm.id option) () = | Some f -> ( if xm then export_metadata_xm - else - export_metadata + else + export_metadata ) copts f x ; `Ok () diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 52f3f2acdcb..0d85c59c383 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -928,10 +928,10 @@ module Redirector = struct (string_of_operation (fst item)) ( if aliased then "aliased " - else if redirected then - "redirected " - else - "" + else if redirected then + "redirected " + else + "" ) real_tag (String.concat ", " @@ -2676,8 +2676,8 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) ] ; ( if compress_memory then [(cookie_mem_compression, cookie_mem_compression_value)] - else - [] + else + [] ) ; extra_cookies ] diff --git a/ocaml/xenopsd/lib/xenops_server_simulator.ml b/ocaml/xenopsd/lib/xenops_server_simulator.ml index 0ad9caa4bc7..c12a929392f 100644 --- a/ocaml/xenopsd/lib/xenops_server_simulator.ml +++ b/ocaml/xenopsd/lib/xenops_server_simulator.ml @@ -431,8 +431,8 @@ let set_ipv4_configuration vm vif ipv4_configuration () = Vif.ipv4_configuration= ( if this_one vif then ipv4_configuration - else - vif.Vif.ipv4_configuration + else + vif.Vif.ipv4_configuration ) } ) @@ -451,8 +451,8 @@ let set_ipv6_configuration vm vif ipv6_configuration () = Vif.ipv6_configuration= ( if this_one vif then ipv6_configuration - else - vif.Vif.ipv6_configuration + else + vif.Vif.ipv6_configuration ) } ) diff --git a/ocaml/xenopsd/lib/xenopsd.ml b/ocaml/xenopsd/lib/xenopsd.ml index 0f08581b9eb..09b936d6b1c 100644 --- a/ocaml/xenopsd/lib/xenopsd.ml +++ b/ocaml/xenopsd/lib/xenopsd.ml @@ -459,8 +459,8 @@ let main backend = (Some ( if !persist then (module Xenops_utils.FileFS : Xenops_utils.FS) - else - (module Xenops_utils.MemFS : Xenops_utils.FS) + else + (module Xenops_utils.MemFS : Xenops_utils.FS) ) ) ; Xenops_server.register_objects () ; diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index b547b6bcd46..775320ac466 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -1313,8 +1313,8 @@ module PCI = struct callscript "flr-pre" device ; ( if Sys.file_exists device_reset_file then try write_string_to_file device_reset_file "1" with _ -> () - else - try write_string_to_file doflr device with _ -> () + else + try write_string_to_file doflr device with _ -> () ) ; callscript "flr-post" device @@ -2355,12 +2355,12 @@ module Dm_Common = struct ] | None -> [] - else - match info.xen_platform with - | Some (device_id, _) -> - [sprintf "device-id=0x%04x" device_id] - | None -> - [] + else + match info.xen_platform with + | Some (device_id, _) -> + [sprintf "device-id=0x%04x" device_id] + | None -> + [] ) ] ) diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index 177d25937c5..ca1e7bcc421 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -1811,8 +1811,8 @@ let suspend (task : Xenops_task.task_handle) ~xc ~xs ~domain_type ~is_uefi ~dm ( if is_uefi then write_varstored_record task ~xs domid main_fd >>= fun () -> write_vtpm_record task ~xs ~vtpm domid main_fd - else - return () + else + return () ) >>= fun () -> (* Qemu record (if this is a hvm domain) *) @@ -1821,8 +1821,8 @@ let suspend (task : Xenops_task.task_handle) ~xc ~xs ~domain_type ~is_uefi ~dm suspend-image-writing *) ( if domain_type = `hvm then write_qemu_record domid uuid main_fd - else - return () + else + return () ) >>= fun () -> debug "Qemu record written" ; diff --git a/ocaml/xenopsd/xc/memory_breakdown.ml b/ocaml/xenopsd/xc/memory_breakdown.ml index 4af9f433508..29a287865c0 100644 --- a/ocaml/xenopsd/xc/memory_breakdown.ml +++ b/ocaml/xenopsd/xc/memory_breakdown.ml @@ -299,14 +299,14 @@ let pad_value_list guest_ids_all guest_ids values default_value = (Invalid_argument ( if List.length guest_ids <> List.length values then "Expected: length (guest_ids) = length (values)" - else if not (is_sorted String.compare guest_ids) then - "Expected: sorted (guest_ids)" - else if not (is_sorted String.compare guest_ids_all) then - "Expected: sorted (guest_ids_all)" - else if not (is_subset guest_ids guest_ids_all) then - "Expected: guest_ids subset of guest_ids_all" - else - "Unknown failure" + else if not (is_sorted String.compare guest_ids) then + "Expected: sorted (guest_ids)" + else if not (is_sorted String.compare guest_ids_all) then + "Expected: sorted (guest_ids_all)" + else if not (is_subset guest_ids guest_ids_all) then + "Expected: guest_ids subset of guest_ids_all" + else + "Unknown failure" ) ) in diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 4a83e9b18eb..31c3f97c42c 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -2834,8 +2834,8 @@ module VM = struct Memory.bytes_of_mib ( if di.Xenctrl.hvm_guest then Memory.HVM.xen_max_offset_mib - else - Memory.Linux.xen_max_offset_mib + else + Memory.Linux.xen_max_offset_mib ) in let raw_bytes = @@ -2961,11 +2961,12 @@ module VM = struct di.Xenctrl.domid ; try xs.Xs.write path "t" with _ -> () ) - else - try - let (_ : string) = xs.Xs.read path in - xs.Xs.rm path - with _ -> () (* do not RM the 'warned' path to prevent flood *) + else + try + let (_ : string) = xs.Xs.read path in + xs.Xs.rm path + with _ -> + () (* do not RM the 'warned' path to prevent flood *) ) ; let shadow_multiplier_target = if not di.Xenctrl.hvm_guest then @@ -4408,8 +4409,8 @@ module VIF = struct (fun () -> ( if force then Device.hard_shutdown - else - Device.clean_shutdown + else + Device.clean_shutdown ) task ~xs device ) ; From 52a020f3cb49f431137780b9b5c90e7b8dc3c5d5 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 14 Dec 2023 17:01:42 +0800 Subject: [PATCH 08/39] CP-46747: Expose 'title' field in updateinfo.xml to HTTP /updates Signed-off-by: Ming Lu --- ocaml/tests/test_repository_helpers.ml | 29 ++++++++++++++++++++++++++ ocaml/tests/test_updateinfo.ml | 18 ++++++++++++++++ ocaml/xapi/updateinfo.ml | 5 +++++ ocaml/xapi/updateinfo.mli | 1 + 4 files changed, 53 insertions(+) diff --git a/ocaml/tests/test_repository_helpers.ml b/ocaml/tests/test_repository_helpers.ml index b0b430f2b65..9194a2950f9 100644 --- a/ocaml/tests/test_repository_helpers.ml +++ b/ocaml/tests/test_repository_helpers.ml @@ -503,6 +503,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -525,6 +526,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -572,6 +574,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -618,6 +621,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -640,6 +644,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -686,6 +691,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -721,6 +727,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -767,6 +774,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -813,6 +821,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -859,6 +868,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -894,6 +904,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -940,6 +951,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -974,6 +986,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1020,6 +1033,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -1066,6 +1080,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1134,6 +1149,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1192,6 +1208,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1252,6 +1269,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -1286,6 +1304,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1344,6 +1363,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -1388,6 +1408,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1446,6 +1467,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -1468,6 +1490,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1526,6 +1549,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -1548,6 +1572,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1616,6 +1641,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ; ( "UPDATE-0001" @@ -1650,6 +1676,7 @@ module EvalGuidanceForOneUpdate = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } ) ] @@ -1992,6 +2019,7 @@ module ConsolidateUpdatesOfHost = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } let updates_info = @@ -3872,6 +3900,7 @@ module PruneUpdateInfoForLivepatches = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } let tests = diff --git a/ocaml/tests/test_updateinfo.ml b/ocaml/tests/test_updateinfo.ml index f37e374256c..def4fe0f65e 100644 --- a/ocaml/tests/test_updateinfo.ml +++ b/ocaml/tests/test_updateinfo.ml @@ -446,6 +446,7 @@ let fields_of_updateinfo = ; field "severity" (fun (r : UpdateInfo.t) -> Severity.to_string r.severity) string + ; field "title" (fun (r : UpdateInfo.t) -> r.title) string ] module UpdateInfoOfXml = Generic.MakeStateless (struct @@ -568,6 +569,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -636,6 +638,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" ; severity= Severity.High + ; title= "title" } ) ] @@ -690,6 +693,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" ; severity= Severity.High + ; title= "title" } ) ; ( "UPDATE-0001" @@ -713,6 +717,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:50Z" ; severity= Severity.None + ; title= "title" } ) ] @@ -795,6 +800,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" ; severity= Severity.High + ; title= "title" } ) ] @@ -889,6 +895,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" ; severity= Severity.High + ; title= "title" } ) ] @@ -964,6 +971,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" ; severity= Severity.High + ; title= "title" } ) ] @@ -1039,6 +1047,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; issued= Xapi_stdext_date.Date.of_string "2023-05-12T08:37:49Z" ; severity= Severity.High + ; title= "title" } ) ] @@ -1087,6 +1096,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1149,6 +1159,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1199,6 +1210,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1247,6 +1259,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1292,6 +1305,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1344,6 +1358,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1400,6 +1415,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1461,6 +1477,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] @@ -1522,6 +1539,7 @@ module UpdateInfoOfXml = Generic.MakeStateless (struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "title" } ) ] diff --git a/ocaml/xapi/updateinfo.ml b/ocaml/xapi/updateinfo.ml index 6c58e23a452..092af683232 100644 --- a/ocaml/xapi/updateinfo.ml +++ b/ocaml/xapi/updateinfo.ml @@ -543,6 +543,7 @@ module UpdateInfo = struct ; livepatches: LivePatch.t list ; issued: Xapi_stdext_date.Date.t ; severity: Severity.t + ; title: string } let guidance_to_string o = @@ -563,6 +564,7 @@ module UpdateInfo = struct , `List (List.map (fun x -> LivePatch.to_json x) ui.livepatches) ) ; ("guidance", GuidanceInUpdateInfo.to_json ui.guidance) + ; ("title", `String ui.title) ] let to_string ui = to_json ui |> Yojson.Basic.to_string @@ -580,6 +582,7 @@ module UpdateInfo = struct ; livepatches= [] ; issued= Xapi_stdext_date.Date.epoch ; severity= Severity.None + ; title= "" } let assert_valid_updateinfo = function @@ -673,6 +676,8 @@ module UpdateInfo = struct warn "%s" (ExnHelper.string_of_exn e) ; acc ) + | Xml.Element ("title", _, [Xml.PCData v]) -> + {acc with title= v} | _ -> acc ) diff --git a/ocaml/xapi/updateinfo.mli b/ocaml/xapi/updateinfo.mli index 5d666144358..7a348db598c 100644 --- a/ocaml/xapi/updateinfo.mli +++ b/ocaml/xapi/updateinfo.mli @@ -155,6 +155,7 @@ module UpdateInfo : sig ; livepatches: LivePatch.t list ; issued: Xapi_stdext_date.Date.t ; severity: Severity.t + ; title: string } val to_json : t -> Yojson.Basic.t From cefc486f97c03a859a0d47e7eb0322b25da7f694 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 5 Dec 2023 17:51:18 +0800 Subject: [PATCH 09/39] CP-45567: Set recommended and full pending guidance lists This commit adds logic to set pending recommended and full guidance lists. What's more, the livepatch failures are merged with the pending livepatch failures. Livepatch failures are placed in pending recommended guidance list. Signed-off-by: Ming Lu --- ocaml/xapi/repository.ml | 40 +++++-- ocaml/xapi/repository_helpers.ml | 184 ++++++++++++++++++++++++++----- 2 files changed, 187 insertions(+), 37 deletions(-) diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index 9e2aad855f4..68bebeb1168 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -674,18 +674,25 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates = (* This function runs on coordinator host *) let open Guidance in - let get_guidances kind = - eval_guidances ~updates_info ~updates:acc_rpm_updates ~kind ~livepatches - |> GuidanceSet.remove EvacuateHost - |> GuidanceSet.elements + let guidance = + reduce_guidance ~updates_info ~updates:acc_rpm_updates ~livepatches + (* EvacuateHost should be carried out before host.apply_updates *) + |> List.map (fun (k, l) -> (k, List.filter (fun x -> x <> EvacuateHost) l)) + in + let mandatory = + match List.assoc_opt Mandatory guidance with + | Some tasks -> + tasks + | None -> + warn "No mandatory guidance found. Ignore it." ; + [] in - let mandatory = get_guidances Mandatory in (* Install RPM updates *) Helpers.call_api_functions ~__context (fun rpc session_id -> Client.Client.Repository.apply ~rpc ~session_id ~host ) ; (* Apply livepatches *) - let _, failed_livepatches = + let applied_livepatches, failed_livepatches = match List.mem RebootHost mandatory with | true -> (* Not apply any livepatches as the host will reboot *) @@ -695,11 +702,22 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates in (* Update states in cache *) update_cache ~host ~failed_livepatches ; - List.iter - (fun g -> debug "mandatory pending_guidance: %s" (to_string g)) - mandatory ; - let ops = get_ops_of_pending ~__context ~host ~kind:Mandatory in - set_pending_guidances ~ops ~coming:mandatory ; + (* Set pending guidance lists *) + let set_guidance ~kind ~coming = + List.iter + (fun g -> + debug "setting %s pending guidance: %s" (kind_to_string kind) + (to_string g) + ) + coming ; + let ops = get_ops_of_pending ~__context ~host ~kind in + set_pending_guidances ~ops ~coming + in + guidance |> List.iter (fun (kind, coming) -> set_guidance ~kind ~coming) ; + let get_livepatch_component (lp, _) = lp.LivePatch.component in + let applied = List.map get_livepatch_component applied_livepatches in + let failed = List.map get_livepatch_component failed_livepatches in + update_livepatch_failure_guidance ~__context ~host ~applied ~failed ; List.map (fun (lp, _) -> [Api_errors.apply_livepatch_failed; LivePatch.to_string lp]) failed_livepatches diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 1d990253651..e9053cc86b5 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -1224,6 +1224,16 @@ let merge_livepatches ~livepatches = ) (UpdateIdSet.empty, []) +let reduce_guidance ~updates_info ~updates ~livepatches = + let open Guidance in + (* The order does matter with the following reducing *) + [Mandatory; Recommended; Full] + |> List.map (fun kind -> + (kind, eval_guidances ~updates_info ~updates ~kind ~livepatches) + ) + |> GuidanceSet.reduce_cascaded_list + |> List.map (fun (kind, s) -> (kind, GuidanceSet.elements s)) + let consolidate_updates_of_host ~repository_name ~updates_info host updates_of_host = let latest_updates = @@ -1257,16 +1267,7 @@ let consolidate_updates_of_host ~repository_name ~updates_info host let livepatches = retrieve_livepatches_from_updateinfo ~updates_info ~updates:updates_of_host in - let guidance = - let open Guidance in - (* The order does matter with the following reducing *) - [Mandatory; Recommended; Full] - |> List.map (fun kind -> - (kind, eval_guidances ~updates_info ~updates ~kind ~livepatches) - ) - |> GuidanceSet.reduce_cascaded_list - |> List.map (fun (kind, s) -> (kind, GuidanceSet.elements s)) - in + let guidance = reduce_guidance ~updates_info ~updates ~livepatches in let upd_ids_of_livepatches, lps = merge_livepatches ~livepatches in let upd_ids = UpdateIdSet.union ids_of_updates upd_ids_of_livepatches in let host_updates = @@ -1407,22 +1408,12 @@ type pending_ops = { let get_ops_of_pending ~__context ~host ~kind = let get_pending_guidances_of_host ~db_get = db_get ~__context ~self:host - |> List.map (fun g -> Guidance.of_pending_guidance g) + |> List.map Guidance.of_pending_guidance in let get_pending_guidances_of_vms ~db_get = Db.Host.get_resident_VMs ~__context ~self:host - |> List.map (fun self -> (self, Db.VM.get_record ~__context ~self)) - |> List.filter_map (fun (ref, record) -> - match - ( record.API.vM_is_control_domain - , record.API.vM_power_state - , Helpers.has_qemu_currently ~__context ~self:ref - ) - with - | false, `Running, true | false, `Paused, true -> - Some ref - | _ -> - None + |> List.filter (fun self -> + not (Db.VM.get_is_control_domain ~__context ~self) ) |> List.map (fun vm_ref -> let pending_guidances = @@ -1432,6 +1423,15 @@ let get_ops_of_pending ~__context ~host ~kind = (Ref.string_of vm_ref, pending_guidances) ) in + let is_vm_applicable ~self = function + | `restart_device_model -> + Helpers.has_qemu_currently ~__context ~self + | `restart_vm -> + (* RestartVM will be set in host.apply_updates when updating the coordinator. + * To avoid confusions, not setting it here. + *) + false + in match kind with | Guidance.Mandatory -> let host_get () = @@ -1447,15 +1447,66 @@ let get_ops_of_pending ~__context ~host ~kind = get_pending_guidances_of_vms ~db_get:Db.VM.get_pending_guidances in let vm_add vm value = - Db.VM.add_pending_guidances ~__context ~self:(Ref.of_string vm) ~value + let self = Ref.of_string vm in + if is_vm_applicable ~self value then + Db.VM.add_pending_guidances ~__context ~self:(Ref.of_string vm) ~value in let vm_remove vm value = Db.VM.remove_pending_guidances ~__context ~self:(Ref.of_string vm) ~value in {host_get; host_add; host_remove; vms_get; vm_add; vm_remove} - | _ -> - raise Api_errors.(Server_error (internal_error, ["Not implemented kind"])) + | Guidance.Recommended -> + let host_get () = + get_pending_guidances_of_host + ~db_get:Db.Host.get_pending_guidances_recommended + in + let host_add value = + Db.Host.add_pending_guidances_recommended ~__context ~self:host ~value + in + let host_remove value = + Db.Host.remove_pending_guidances_recommended ~__context ~self:host + ~value + in + let vms_get () = + get_pending_guidances_of_vms + ~db_get:Db.VM.get_pending_guidances_recommended + in + let vm_add vm value = + let self = Ref.of_string vm in + if is_vm_applicable ~self value then + Db.VM.add_pending_guidances_recommended ~__context ~self ~value + in + let vm_remove vm value = + Db.VM.remove_pending_guidances_recommended ~__context + ~self:(Ref.of_string vm) ~value + in + {host_get; host_add; host_remove; vms_get; vm_add; vm_remove} + | Guidance.Full -> + let host_get () = + get_pending_guidances_of_host ~db_get:Db.Host.get_pending_guidances_full + in + let host_add value = + Db.Host.add_pending_guidances_full ~__context ~self:host ~value + in + let host_remove value = + Db.Host.remove_pending_guidances_full ~__context ~self:host ~value + in + let vms_get () = + get_pending_guidances_of_vms ~db_get:Db.VM.get_pending_guidances_full + in + let vm_add vm value = + let self = Ref.of_string vm in + if is_vm_applicable ~self value then + Db.VM.add_pending_guidances_full ~__context ~self ~value + in + let vm_remove vm value = + Db.VM.remove_pending_guidances_full ~__context ~self:(Ref.of_string vm) + ~value + in + {host_get; host_add; host_remove; vms_get; vm_add; vm_remove} + | Guidance.Livepatch -> + raise Api_errors.(Server_error (internal_error, ["No pending operations for Livepatch guidance"])) let set_pending_guidances ~ops ~coming = let pending_of_host = @@ -1477,3 +1528,84 @@ let set_pending_guidances ~ops ~coming = to_be_removed ; do_with_vm_pending_guidances ~op:ops.vm_add ~vm:vm_ref_str to_be_added ) + +let failure_of_livepatch_component = function + | Livepatch.Xen -> + Guidance.RebootHostOnXenLivePatchFailure + | Livepatch.Kernel -> + Guidance.RebootHostOnKernelLivePatchFailure + +let component_of_livepatch_failure = function + | Guidance.RebootHostOnXenLivePatchFailure -> + Some Livepatch.Xen + | Guidance.RebootHostOnKernelLivePatchFailure -> + Some Livepatch.Kernel + | _ -> + None + +let merge_livepatch_failures ~previous_failures ~applied ~failed = + let current_failures = List.map failure_of_livepatch_component failed in + (* Determine how to deal with previous livepatch failures *) + List.fold_left + (fun acc_fails prev_fail -> + match component_of_livepatch_failure prev_fail with + | Some prev_failed_component -> ( + let comp_str = Livepatch.string_of_component prev_failed_component in + match + ( List.mem prev_fail current_failures + , List.mem prev_failed_component applied + ) + with + | true, false -> + debug "%s Livepatch failed again." comp_str ; + acc_fails + | false, true -> + (* applied in this update. No changes on current failures *) + debug + "%s Livepatch (failed in previous updates) has been applied." + comp_str ; + acc_fails + | true, true -> + (* Impossible case: a component is in both failed and applied *) + warn "%s Livepatch shouldn't be in both applied and failed lists." + comp_str ; + acc_fails + | false, false -> + (* Didn't try in this update. Keep previous failure in current list *) + debug "%s Livepatch failed in previous updates." comp_str ; + prev_fail :: acc_fails + ) + | None -> + warn "Unknown livepatch failure." ; + acc_fails + ) + current_failures previous_failures + |> fun failures -> + let open GuidanceSet in + let to_be_removed = + diff (of_list previous_failures) (of_list failures) |> elements + in + let to_be_added = + diff (of_list failures) (of_list previous_failures) |> elements + in + (to_be_removed, to_be_added) + +let update_livepatch_failure_guidance ~__context ~host ~applied ~failed = + let previous_failures = + Db.Host.get_pending_guidances_recommended ~__context ~self:host + |> List.map Guidance.of_pending_guidance + |> List.filter is_livepatch_failure + in + let to_be_removed, to_be_added = + merge_livepatch_failures ~previous_failures ~applied ~failed + in + (* The livepatch failure guidance is in host pending recommended list *) + let host_remove value = + Db.Host.remove_pending_guidances_recommended ~__context ~self:host ~value + in + let host_add value = + Db.Host.add_pending_guidances_recommended ~__context ~self:host ~value + in + List.iter host_remove + (List.filter_map Guidance.to_pending_guidance to_be_removed) ; + List.iter host_add (List.filter_map Guidance.to_pending_guidance to_be_added) From 7bc74d698e8396fe6c916bf467a9291815350e39 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 8 Dec 2023 19:20:22 +0800 Subject: [PATCH 10/39] CP-45567: Unit tests for livepatch failures Add unit tests for merge_livepatch_failures. Signed-off-by: Ming Lu --- ocaml/tests/test_repository_helpers.ml | 142 +++++++++++++++++++++++++ 1 file changed, 142 insertions(+) diff --git a/ocaml/tests/test_repository_helpers.ml b/ocaml/tests/test_repository_helpers.ml index b0b430f2b65..8342fefcfd1 100644 --- a/ocaml/tests/test_repository_helpers.ml +++ b/ocaml/tests/test_repository_helpers.ml @@ -4579,6 +4579,147 @@ module SetPendingGuidance = Generic.MakeStateless (struct ] end) +module MergeLivepatchFailures = Generic.MakeStateless (struct + module Io = struct + (* (previous_failures, (applied, failed)) *) + type input_t = + Guidance.t list * (Livepatch.component list * Livepatch.component list) + + (* to_be_removed, to_be_added *) + type output_t = Guidance.t list * Guidance.t list + + let string_of_input_t (previous_failures, (applied, failed)) = + Fmt.( + str "%a" Dump.(pair (list string) (pair (list string) (list string))) + ) + ( List.map Guidance.to_string previous_failures + , ( List.map Livepatch.string_of_component applied + , List.map Livepatch.string_of_component failed + ) + ) + + let string_of_output_t (to_be_removed, to_be_added) = + Fmt.(str "%a" Dump.(pair (list string) (list string))) + ( List.map Guidance.to_string to_be_removed + , List.map Guidance.to_string to_be_added + ) + end + + let transform (previous_failures, (applied, failed)) = + merge_livepatch_failures ~previous_failures ~applied ~failed + + let tests = + let open Guidance in + let open Livepatch in + `QuickAndAutoDocumented + [ + (([], ([Xen; Kernel], [])), ([], [])) + ; (([], ([Kernel], [Xen])), ([], [RebootHostOnXenLivePatchFailure])) + ; (([], ([Kernel], [])), ([], [])) + ; (([], ([Xen], [Kernel])), ([], [RebootHostOnKernelLivePatchFailure])) + ; (([], ([Xen], [])), ([], [])) + ; ( ([], ([], [Xen; Kernel])) + , ( [] + , [ + RebootHostOnKernelLivePatchFailure; RebootHostOnXenLivePatchFailure + ] + ) + ) + ; (([], ([], [Kernel])), ([], [RebootHostOnKernelLivePatchFailure])) + ; (([], ([], [Xen])), ([], [RebootHostOnXenLivePatchFailure])) + ; (([], ([], [])), ([], [])) + ; ( ([RebootHostOnXenLivePatchFailure], ([Xen; Kernel], [])) + , ([RebootHostOnXenLivePatchFailure], []) + ) + ; (([RebootHostOnXenLivePatchFailure], ([Kernel], [Xen])), ([], [])) + ; (([RebootHostOnXenLivePatchFailure], ([Kernel], [])), ([], [])) + ; ( ([RebootHostOnXenLivePatchFailure], ([Xen], [Kernel])) + , ( [RebootHostOnXenLivePatchFailure] + , [RebootHostOnKernelLivePatchFailure] + ) + ) + ; ( ([RebootHostOnXenLivePatchFailure], ([Xen], [])) + , ([RebootHostOnXenLivePatchFailure], []) + ) + ; ( ([RebootHostOnXenLivePatchFailure], ([], [Xen; Kernel])) + , ([], [RebootHostOnKernelLivePatchFailure]) + ) + ; ( ([RebootHostOnXenLivePatchFailure], ([], [Kernel])) + , ([], [RebootHostOnKernelLivePatchFailure]) + ) + ; (([RebootHostOnXenLivePatchFailure], ([], [Xen])), ([], [])) + ; (([RebootHostOnXenLivePatchFailure], ([], [])), ([], [])) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([Xen; Kernel], []) + ) + , ( [RebootHostOnKernelLivePatchFailure; RebootHostOnXenLivePatchFailure] + , [] + ) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([Kernel], [Xen]) + ) + , ([RebootHostOnKernelLivePatchFailure], []) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([Kernel], []) + ) + , ([RebootHostOnKernelLivePatchFailure], []) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([Xen], [Kernel]) + ) + , ([RebootHostOnXenLivePatchFailure], []) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([Xen], []) + ) + , ([RebootHostOnXenLivePatchFailure], []) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([], [Xen; Kernel]) + ) + , ([], []) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([], [Kernel]) + ) + , ([], []) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([], [Xen]) + ) + , ([], []) + ) + ; ( ( [RebootHostOnXenLivePatchFailure; RebootHostOnKernelLivePatchFailure] + , ([], []) + ) + , ([], []) + ) + ; ( ([RebootHostOnKernelLivePatchFailure], ([Xen; Kernel], [])) + , ([RebootHostOnKernelLivePatchFailure], []) + ) + ; ( ([RebootHostOnKernelLivePatchFailure], ([Kernel], [Xen])) + , ( [RebootHostOnKernelLivePatchFailure] + , [RebootHostOnXenLivePatchFailure] + ) + ) + ; ( ([RebootHostOnKernelLivePatchFailure], ([Kernel], [])) + , ([RebootHostOnKernelLivePatchFailure], []) + ) + ; (([RebootHostOnKernelLivePatchFailure], ([Xen], [Kernel])), ([], [])) + ; (([RebootHostOnKernelLivePatchFailure], ([Xen], [])), ([], [])) + ; ( ([RebootHostOnKernelLivePatchFailure], ([], [Xen; Kernel])) + , ([], [RebootHostOnXenLivePatchFailure]) + ) + ; (([RebootHostOnKernelLivePatchFailure], ([], [Kernel])), ([], [])) + ; ( ([RebootHostOnKernelLivePatchFailure], ([], [Xen])) + , ([], [RebootHostOnXenLivePatchFailure]) + ) + ; (([RebootHostOnKernelLivePatchFailure], ([], [])), ([], [])) + ] +end) + let tests = make_suite "repository_helpers_" [ @@ -4603,6 +4744,7 @@ let tests = , GetLatestUpdatesFromRedundancy.tests ) ; ("set_pending_guidances", SetPendingGuidance.tests) + ; ("merge_livepatch_failures", MergeLivepatchFailures.tests) ] let () = Alcotest.run "Repository Helpers" tests From 3d00a4d5b9325b34df120e56cd366acba4379b1b Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 7 Dec 2023 14:42:12 +0800 Subject: [PATCH 11/39] CP-45567: Add safety check in host.apply_updates In host.apply_updates, some safety checks are added in this commit: - disallow if there is any outstanding mandatory guidance on the host. - disallow if new mandatory guidance includes EvacuateHost or RebootHost and there are any running or paused VMs on the host. - automatically disable host (if not yet disabled). Signed-off-by: Ming Lu --- ocaml/idl/datamodel_errors.ml | 3 +++ ocaml/xapi-consts/api_errors.ml | 2 ++ ocaml/xapi/repository.ml | 2 ++ ocaml/xapi/repository_helpers.ml | 31 +++++++++++++++++++++++++++++++ ocaml/xapi/xapi_host.ml | 4 ++++ 5 files changed, 42 insertions(+) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 1d841ccdb21..5b511dd7b57 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1965,6 +1965,9 @@ let _ = its pending mandatory guidances got applied." () ; + error Api_errors.host_evacuation_is_required ["host"] + ~doc:"Host evacuation is required before applying updates." () ; + message (fst Api_messages.ha_pool_overcommitted) ~doc: diff --git a/ocaml/xapi-consts/api_errors.ml b/ocaml/xapi-consts/api_errors.ml index 58e4d52fd05..43fff504a3d 100644 --- a/ocaml/xapi-consts/api_errors.ml +++ b/ocaml/xapi-consts/api_errors.ml @@ -1288,6 +1288,8 @@ let no_repositories_configured = "NO_REPOSITORIES_CONFIGURED" let host_pending_mandatory_guidances_not_empty = "HOST_PENDING_MANDATORY_GUIDANCE_NOT_EMPTY" +let host_evacuation_is_required = "HOST_EVACUATION_IS_REQUIRED" + (* VTPMs *) let vtpm_max_amount_reached = "VTPM_MAX_AMOUNT_REACHED" diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index 68bebeb1168..3ffcebc421d 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -687,6 +687,7 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates warn "No mandatory guidance found. Ignore it." ; [] in + assert_host_evacuation_if_required ~__context ~host ~mandatory ; (* Install RPM updates *) Helpers.call_api_functions ~__context (fun rpc session_id -> Client.Client.Repository.apply ~rpc ~session_id ~host @@ -724,6 +725,7 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates let apply_updates ~__context ~host ~hash = (* This function runs on coordinator host *) + assert_no_host_pending_mandatory_guidance ~__context ~host ; try let repository = get_single_enabled_update_repository ~__context in if hash = "" || hash <> Db.Repository.get_hash ~__context ~self:repository diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index e9053cc86b5..52cb04c3769 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -1609,3 +1609,34 @@ let update_livepatch_failure_guidance ~__context ~host ~applied ~failed = List.iter host_remove (List.filter_map Guidance.to_pending_guidance to_be_removed) ; List.iter host_add (List.filter_map Guidance.to_pending_guidance to_be_added) + +let assert_no_host_pending_mandatory_guidance ~__context ~host = + match Db.Host.get_pending_guidances ~__context ~self:host with + | [] -> + () + | _ :: _ -> + raise + Api_errors.( + Server_error + (host_pending_mandatory_guidances_not_empty, [Ref.string_of host]) + ) + +let assert_host_evacuation_if_required ~__context ~host ~mandatory = + let open Guidance in + let need_evacuation = + List.exists (fun g -> g = RebootHost || g = EvacuateHost) mandatory + in + let resident_vms = + Db.Host.get_resident_VMs ~__context ~self:host + |> List.filter (fun self -> + not (Db.VM.get_is_control_domain ~__context ~self) + ) + in + match (need_evacuation, resident_vms <> []) with + | true, true -> + raise + Api_errors.( + Server_error (host_evacuation_is_required, [Ref.string_of host]) + ) + | _ -> + () diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index d609690871c..74aa521d76a 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -3027,6 +3027,10 @@ let apply_updates ~__context ~self ~hash = let pool = Helpers.get_pool ~__context in if Db.Pool.get_ha_enabled ~__context ~self:pool then raise Api_errors.(Server_error (ha_is_enabled, [])) ; + if Db.Host.get_enabled ~__context ~self then ( + disable ~__context ~host:self ; + Xapi_host_helpers.update_allowed_operations ~__context ~self + ) ; Xapi_host_helpers.with_host_operation ~__context ~self ~doc:"Host.apply_updates" ~op:`apply_updates @@ fun () -> Repository.apply_updates ~__context ~host:self ~hash From 538da2c802166428b38b79a1d57275006d75ea8d Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 7 Dec 2023 19:18:33 +0800 Subject: [PATCH 12/39] CP-45567: Set pending RestartVM for all VMs in the pool RestartVM is a task specified in update guidance. It has to be done on an updated host. Unlike other VM tasks in update guidance, a VM may escape from the tracking on individual host. E.g. a host evacuation will migrate a VM to aother host before host.apply_updates call setting the pending guidance on it. It's also not good to expose an API to set the pending guidance lists by clients. The solution in this commit is to set it for all running/paused/suspended VMs in the pool when the host.apply_updates is called for the coordinator host which is always the first one to be updated in a pool update. Signed-off-by: Ming Lu --- ocaml/xapi/repository.ml | 117 ++++++++++++++++++++++++++++++--------- 1 file changed, 91 insertions(+), 26 deletions(-) diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index 3ffcebc421d..d7c722070d0 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -532,6 +532,20 @@ let get_repository_handler (req : Http.Request.t) s _ = Http_svr.response_forbidden ~req s ) +let consolidate_updates_of_hosts ~repository_name ~updates_info ~hosts = + Hashtbl.fold + (fun host updates_of_host (acc1, acc2) -> + if List.mem host hosts then + let updates_of_host, upd_ids = + consolidate_updates_of_host ~repository_name ~updates_info + (Ref.string_of host) updates_of_host + in + (updates_of_host :: acc1, UpdateIdSet.union upd_ids acc2) + else + (acc1, acc2) + ) + updates_in_cache ([], UpdateIdSet.empty) + let get_pool_updates_in_json ~__context ~hosts = try let repository = get_single_enabled_update_repository ~__context in @@ -543,18 +557,7 @@ let get_pool_updates_in_json ~__context ~hosts = parse_updateinfo ~__context ~self:repository ~check:true in let updates_of_hosts, ids_of_updates = - Hashtbl.fold - (fun host updates_of_host (acc1, acc2) -> - if List.mem host hosts then - let updates_of_host, upd_ids = - consolidate_updates_of_host ~repository_name ~updates_info - (Ref.string_of host) updates_of_host - in - (updates_of_host :: acc1, UpdateIdSet.union upd_ids acc2) - else - (acc1, acc2) - ) - updates_in_cache ([], UpdateIdSet.empty) + consolidate_updates_of_hosts ~repository_name ~updates_info ~hosts in let lps = updates_of_hosts @@ -670,6 +673,55 @@ let update_cache ~host ~failed_livepatches = ] ) +let maybe_set_restart_for_all_vms ~__context ~updates_of_hosts = + let open Guidance in + let add_restart_to_vms ~__context ~vms ~kind = + let ( let* ) = Option.bind in + let* op = + match kind with + | Mandatory -> + Some Db.VM.add_pending_guidances + | Recommended -> + Some Db.VM.add_pending_guidances_recommended + | Full -> + Some Db.VM.add_pending_guidances_full + | Livepatch -> + None + in + Some + (List.iter + (fun self -> + debug "add RestartVM for VM %s" (Ref.string_of self) ; + op ~__context ~self ~value:`restart_vm + ) + vms + ) + in + if updates_of_hosts <> [] then + let vms = + Db.VM.get_all ~__context + |> List.filter (fun self -> + not (Db.VM.get_is_control_domain ~__context ~self) + ) + in + (* fold each guidance kind from all hosts *) + updates_of_hosts + |> List.concat_map (fun HostUpdates.{guidance; _} -> guidance) + |> List.fold_left + (fun acc (kind, l) -> + if List.mem RestartVM l && not (List.mem kind acc) then + kind :: acc + else + acc + ) + [] + |> List.iter (fun kind -> + (* set RestartVM for all VMs if it is presented from at least one host *) + debug "add RestartVM for all VMs' pending %s guidance list" + (kind_to_string kind) ; + add_restart_to_vms ~__context ~vms ~kind |> ignore + ) + let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates = (* This function runs on coordinator host *) @@ -728,6 +780,7 @@ let apply_updates ~__context ~host ~hash = assert_no_host_pending_mandatory_guidance ~__context ~host ; try let repository = get_single_enabled_update_repository ~__context in + let repository_name = get_repository_name ~__context ~self:repository in if hash = "" || hash <> Db.Repository.get_hash ~__context ~self:repository then raise Api_errors.(Server_error (updateinfo_hash_mismatch, [])) ; @@ -735,6 +788,17 @@ let apply_updates ~__context ~host ~hash = let updates_info = parse_updateinfo ~__context ~self:repository ~check:true in + let updates_of_hosts = + if Helpers.is_pool_master ~__context ~host then ( + (* save available updates before applying on coordinator *) + if Hashtbl.length updates_in_cache = 0 then + set_available_updates ~__context |> ignore ; + let hosts = Db.Host.get_all ~__context in + consolidate_updates_of_hosts ~repository_name ~updates_info ~hosts + |> fst + ) else + [] + in let host_updates = http_get_host_updates_in_json ~__context ~host ~installed:true in @@ -747,20 +811,21 @@ let apply_updates ~__context ~host ~hash = retrieve_livepatches_from_updateinfo ~updates_info ~updates:host_updates in - match (rpm_updates, livepatches) with - | [], [] -> - let host' = Ref.string_of host in - info "Host ref='%s' is already up to date." host' ; - [] - | _ -> - let repository_name = - get_repository_name ~__context ~self:repository - in - let _, acc_rpm_updates = - merge_updates ~repository_name ~updates:host_updates - in - apply_updates' ~__context ~host ~updates_info ~livepatches - ~acc_rpm_updates + let ret = + match (rpm_updates, livepatches) with + | [], [] -> + let host' = Ref.string_of host in + info "Host ref='%s' is already up to date." host' ; + [] + | _ -> + let _, acc_rpm_updates = + merge_updates ~repository_name ~updates:host_updates + in + apply_updates' ~__context ~host ~updates_info ~livepatches + ~acc_rpm_updates + in + maybe_set_restart_for_all_vms ~__context ~updates_of_hosts ; + ret ) with | Api_errors.(Server_error (code, _)) as e From 85343f3e0f6404000077032ead8e89752e93c827 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 21 Dec 2023 10:15:20 +0000 Subject: [PATCH 13/39] Format with new ocamlformat Signed-off-by: Ming Lu --- ocaml/tests/test_repository_helpers.ml | 4 +--- ocaml/xapi/repository_helpers.ml | 9 ++++++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/ocaml/tests/test_repository_helpers.ml b/ocaml/tests/test_repository_helpers.ml index 8342fefcfd1..bf21479f38d 100644 --- a/ocaml/tests/test_repository_helpers.ml +++ b/ocaml/tests/test_repository_helpers.ml @@ -4589,9 +4589,7 @@ module MergeLivepatchFailures = Generic.MakeStateless (struct type output_t = Guidance.t list * Guidance.t list let string_of_input_t (previous_failures, (applied, failed)) = - Fmt.( - str "%a" Dump.(pair (list string) (pair (list string) (list string))) - ) + Fmt.(str "%a" Dump.(pair (list string) (pair (list string) (list string)))) ( List.map Guidance.to_string previous_failures , ( List.map Livepatch.string_of_component applied , List.map Livepatch.string_of_component failed diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 52cb04c3769..11d557ef7c4 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -1407,8 +1407,7 @@ type pending_ops = { let get_ops_of_pending ~__context ~host ~kind = let get_pending_guidances_of_host ~db_get = - db_get ~__context ~self:host - |> List.map Guidance.of_pending_guidance + db_get ~__context ~self:host |> List.map Guidance.of_pending_guidance in let get_pending_guidances_of_vms ~db_get = Db.Host.get_resident_VMs ~__context ~self:host @@ -1506,7 +1505,11 @@ let get_ops_of_pending ~__context ~host ~kind = in {host_get; host_add; host_remove; vms_get; vm_add; vm_remove} | Guidance.Livepatch -> - raise Api_errors.(Server_error (internal_error, ["No pending operations for Livepatch guidance"])) + raise + Api_errors.( + Server_error + (internal_error, ["No pending operations for Livepatch guidance"]) + ) let set_pending_guidances ~ops ~coming = let pending_of_host = From ae20712bdeba2c0671d193bcc2a739134e50dcbc Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 4 Jan 2024 11:13:06 +0800 Subject: [PATCH 14/39] CA-387034: RestartVM is added to pending guidances of shutdown VMs The RestartVM will be cleared when a VM's power state transits to Halted. So it is not good to add this update guidance action into shutdown VMs' pending guidance list, although it could be cleared in VM start also. Signed-off-by: Ming Lu --- ocaml/xapi/repository.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index d7c722070d0..0b211d09f78 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -701,7 +701,8 @@ let maybe_set_restart_for_all_vms ~__context ~updates_of_hosts = let vms = Db.VM.get_all ~__context |> List.filter (fun self -> - not (Db.VM.get_is_control_domain ~__context ~self) + Db.VM.get_power_state ~__context ~self <> `Halted + && not (Db.VM.get_is_control_domain ~__context ~self) ) in (* fold each guidance kind from all hosts *) From 5cd2ba94df77dde36216fda3672e9e2de28bb319 Mon Sep 17 00:00:00 2001 From: Gang Ji <62988402+gangj@users.noreply.github.com> Date: Fri, 5 Jan 2024 20:20:12 +0800 Subject: [PATCH 15/39] CA-387033: Update xapi error document Update document for error: "host_pending_mandatory_guidances_not_empty" as it is used not only when enabling host. Signed-off-by: Gang Ji --- ocaml/idl/datamodel_errors.ml | 4 ++-- ocaml/xapi/repository_helpers.ml | 28 +++++++++++++++++++--------- ocaml/xapi/xapi_host.ml | 24 ++---------------------- 3 files changed, 23 insertions(+), 33 deletions(-) diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 5b511dd7b57..0a0166dfe93 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -1961,8 +1961,8 @@ let _ = error Api_errors.host_pending_mandatory_guidances_not_empty ["host"] ~doc: - "The specified server is disabled and cannot be re-enabled until all of \ - its pending mandatory guidances got applied." + "Operation could not be performed on the host because there is pending \ + mandatory update guidance on it." () ; error Api_errors.host_evacuation_is_required ["host"] diff --git a/ocaml/xapi/repository_helpers.ml b/ocaml/xapi/repository_helpers.ml index 11d557ef7c4..f67e8647822 100644 --- a/ocaml/xapi/repository_helpers.ml +++ b/ocaml/xapi/repository_helpers.ml @@ -1614,15 +1614,25 @@ let update_livepatch_failure_guidance ~__context ~host ~applied ~failed = List.iter host_add (List.filter_map Guidance.to_pending_guidance to_be_added) let assert_no_host_pending_mandatory_guidance ~__context ~host = - match Db.Host.get_pending_guidances ~__context ~self:host with - | [] -> - () - | _ :: _ -> - raise - Api_errors.( - Server_error - (host_pending_mandatory_guidances_not_empty, [Ref.string_of host]) - ) + let host_pending_mandatory_guidances = + Db.Host.get_pending_guidances ~__context ~self:host + in + if host_pending_mandatory_guidances <> [] then ( + error "%s: %d mandatory guidances are pending for host %s: [%s]" + __FUNCTION__ + (List.length host_pending_mandatory_guidances) + (Ref.string_of host) + (host_pending_mandatory_guidances + |> List.map Updateinfo.Guidance.of_pending_guidance + |> List.map Updateinfo.Guidance.to_string + |> String.concat ";" + ) ; + raise + Api_errors.( + Server_error + (host_pending_mandatory_guidances_not_empty, [Ref.string_of host]) + ) + ) let assert_host_evacuation_if_required ~__context ~host ~mandatory = let open Guidance in diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 74aa521d76a..76710bdf53b 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -75,28 +75,8 @@ let set_power_on_mode ~__context ~self ~power_on_mode ~power_on_config = *) let assert_safe_to_reenable ~__context ~self = assert_startup_complete () ; - let host_pending_mandatory_guidances = - Db.Host.get_pending_guidances ~__context ~self - in - if host_pending_mandatory_guidances <> [] then ( - error "%s: %d mandatory guidances are pending for host %s: [%s]" - __FUNCTION__ - (List.length host_pending_mandatory_guidances) - (Ref.string_of self) - (String.concat ";" - (List.map Updateinfo.Guidance.to_string - (List.map Updateinfo.Guidance.of_pending_guidance - host_pending_mandatory_guidances - ) - ) - ) ; - raise - (Api_errors.Server_error - ( Api_errors.host_pending_mandatory_guidances_not_empty - , [Ref.string_of self] - ) - ) - ) ; + Repository_helpers.assert_no_host_pending_mandatory_guidance ~__context + ~host:self ; let host_disabled_until_reboot = try bool_of_string (Localdb.get Constants.host_disabled_until_reboot) with _ -> false From 9829c901c6c8cc115685ce13aaabf664c34e89a2 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Mon, 8 Jan 2024 16:12:41 +0800 Subject: [PATCH 16/39] CP-43875: Record the repository hash on the host object when updating Add field "last_update_hash" on host object to record the SHA256 checksum of updateinfo of the most recently applied update on the host. Signed-off-by: Gang Ji --- ocaml/idl/datamodel_host.ml | 4 ++++ ocaml/idl/schematest.ml | 2 +- ocaml/tests/common/test_common.ml | 3 ++- ocaml/xapi-cli-server/records.ml | 3 +++ ocaml/xapi/xapi_host.ml | 3 ++- 5 files changed, 12 insertions(+), 3 deletions(-) diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 574742f2764..6ac1f2c6d9e 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -2176,6 +2176,10 @@ let t = user should follow to make some updates, e.g. specific hardware \ drivers or CPU features, fully effective, but the 'average user' \ doesn't need to" + ; field ~qualifier:DynamicRO ~lifecycle:[] ~ty:String + ~default_value:(Some (VString "")) "last_update_hash" + "The SHA256 checksum of updateinfo of the most recently applied \ + update on the host" ] ) () diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 6f31434e7dd..f96237c6f89 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -2,7 +2,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 = "9c650ad57273c375b9f82f26f82aa75f" +let last_known_schema_hash = "a2378b3ff9c452cb61f0cab7d9f84a46" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/tests/common/test_common.ml b/ocaml/tests/common/test_common.ml index 4e4ad470788..76494c286e8 100644 --- a/ocaml/tests/common/test_common.ml +++ b/ocaml/tests/common/test_common.ml @@ -211,7 +211,8 @@ let make_host2 ~__context ?(ref = Ref.make ()) ?(uuid = make_uuid ()) ~tls_verification_enabled ~last_software_update:(Xapi_host.get_servertime ~__context ~host:ref) ~recommended_guidances:[] ~latest_synced_updates_applied:`unknown - ~pending_guidances_recommended:[] ~pending_guidances_full:[] ; + ~pending_guidances_recommended:[] ~pending_guidances_full:[] + ~last_update_hash:"" ; ref let make_pif ~__context ~network ~host ?(device = "eth0") diff --git a/ocaml/xapi-cli-server/records.ml b/ocaml/xapi-cli-server/records.ml index 28fdefd56c2..2597b78646a 100644 --- a/ocaml/xapi-cli-server/records.ml +++ b/ocaml/xapi-cli-server/records.ml @@ -3256,6 +3256,9 @@ let host_record rpc session_id host = (x ()).API.host_pending_guidances_full ) () + ; make_field ~name:"last-update-hash" + ~get:(fun () -> (x ()).API.host_last_update_hash) + () ] } diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 76710bdf53b..0356ca5678f 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -1062,7 +1062,7 @@ let create ~__context ~uuid ~name_label ~name_description:_ ~hostname ~address ~multipathing:false ~uefi_certificates:"" ~editions:[] ~pending_guidances:[] ~tls_verification_enabled ~last_software_update ~recommended_guidances:[] ~latest_synced_updates_applied:`unknown ~pending_guidances_recommended:[] - ~pending_guidances_full:[] ; + ~pending_guidances_full:[] ~last_update_hash:"" ; (* If the host we're creating is us, make sure its set to live *) Db.Host_metrics.set_last_updated ~__context ~self:metrics ~value:(Date.of_float (Unix.gettimeofday ())) ; @@ -3018,6 +3018,7 @@ let apply_updates ~__context ~self ~hash = Db.Host.set_last_software_update ~__context ~self ~value:(get_servertime ~__context ~host:self) ; Db.Host.set_latest_synced_updates_applied ~__context ~self ~value:`yes ; + Db.Host.set_last_update_hash ~__context ~self ~value:hash ; warnings let cc_prep () = From c670474eda2e77acb8291ded7db43f8c3615737c Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Mon, 25 Dec 2023 15:30:51 +0800 Subject: [PATCH 17/39] CP-45569: Add API Host.emergency_clear_mandatory_guidance The non-empty host pending mandatory guidance will result in the host blocked from being enabled or updated. This commit introduces a new API to clear the pending mandatory guidance in emergency cases. Otherwise, the host might be stuck in such a situation. Signed-off-by: Ming Lu --- ocaml/idl/datamodel.ml | 1 + ocaml/idl/datamodel_host.ml | 7 +++++++ ocaml/xapi-cli-server/cli_frontend.ml | 11 +++++++++++ ocaml/xapi-cli-server/cli_operations.ml | 3 +++ ocaml/xapi/message_forwarding.ml | 4 ++++ ocaml/xapi/xapi_host.ml | 11 +++++++++++ ocaml/xapi/xapi_host.mli | 2 ++ 7 files changed, 39 insertions(+) diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index aa19b1ab347..7a8d134c6e1 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -7966,6 +7966,7 @@ let emergency_calls = ; (Datamodel_host.t, Datamodel_host.emergency_reset_server_certificate) ; (Datamodel_host.t, Datamodel_host.emergency_disable_tls_verification) ; (Datamodel_host.t, Datamodel_host.emergency_reenable_tls_verification) + ; (Datamodel_host.t, Datamodel_host.emergency_clear_mandatory_guidance) ] (** Whitelist of calls that will not get forwarded from the slave to master via the unix domain socket *) diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 6ac1f2c6d9e..4e1fd8a70ee 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -1779,6 +1779,12 @@ let apply_recommended_guidances = ] ~allowed_roles:_R_POOL_OP () +let emergency_clear_mandatory_guidance = + call ~flags:[`Session] ~name:"emergency_clear_mandatory_guidance" + ~lifecycle:[] ~in_oss_since:None ~params:[] + ~doc:"Clear the pending mandatory guidance on this host" + ~allowed_roles:_R_LOCAL_ROOT_ONLY () + let latest_synced_updates_applied_state = Enum ( "latest_synced_updates_applied_state" @@ -1932,6 +1938,7 @@ let t = ; copy_primary_host_certs ; set_https_only ; apply_recommended_guidances + ; emergency_clear_mandatory_guidance ] ~contents: ([ diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 1803a8af640..f8aa043eb5a 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -1036,6 +1036,17 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [Host_selectors] } ) + ; ( "host-emergency-clear-mandatory-guidance" + , { + reqd= [] + ; optn= [] + ; help= "Clear the pending mandatory guidance on this host" + ; implementation= + No_fd_local_session + Cli_operations.host_emergency_clear_mandatory_guidance + ; flags= [Neverforward] + } + ) ; ( "patch-upload" , { reqd= ["file-name"] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index d90c244ba37..6a054697896 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -7110,6 +7110,9 @@ let host_reset_server_certificate _printer rpc session_id params = params [] ) +let host_emergency_clear_mandatory_guidance _printer rpc session_id _params = + Client.Host.emergency_clear_mandatory_guidance ~rpc ~session_id + let host_management_reconfigure _printer rpc session_id params = let pif = Client.PIF.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "pif-uuid" params) diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index bcf427fdfdd..42f86f94166 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -4031,6 +4031,10 @@ functor do_op_on ~local_fn ~__context ~host:self (fun session_id rpc -> Client.Host.set_https_only ~rpc ~session_id ~self ~value ) + + let emergency_clear_mandatory_guidance ~__context = + info "Host.emergency_clear_mandatory_guidance" ; + Local.Host.emergency_clear_mandatory_guidance ~__context end module Host_crashdump = struct diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 0356ca5678f..cd8389dbdae 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -3048,3 +3048,14 @@ let set_https_only ~__context ~self ~value = | true -> (* it is illegal changing the firewall/https config in CC/FIPS mode *) raise (Api_errors.Server_error (Api_errors.illegal_in_fips_mode, [])) + +let emergency_clear_mandatory_guidance ~__context = + debug "Host.emergency_clear_mandatory_guidance" ; + let self = Helpers.get_localhost ~__context in + Db.Host.get_pending_guidances ~__context ~self + |> List.iter (fun g -> + let open Updateinfo.Guidance in + let s = g |> of_pending_guidance |> to_string in + info "%s: %s is cleared" __FUNCTION__ s + ) ; + Db.Host.set_pending_guidances ~__context ~self ~value:[] diff --git a/ocaml/xapi/xapi_host.mli b/ocaml/xapi/xapi_host.mli index 15d79072765..3b8264ece7b 100644 --- a/ocaml/xapi/xapi_host.mli +++ b/ocaml/xapi/xapi_host.mli @@ -551,3 +551,5 @@ val copy_primary_host_certs : __context:Context.t -> host:API.ref_host -> unit val set_https_only : __context:Context.t -> self:API.ref_host -> value:bool -> unit + +val emergency_clear_mandatory_guidance : __context:Context.t -> unit From 9fa558e3c699300f9667b481f4ea9f7052be0155 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 9 Jan 2024 08:37:51 +0000 Subject: [PATCH 18/39] Fixup: filter out EvacuateHost before safety check A safety check in host.apply_updates will raise error if there is a mandatory EvacuateHost guidance but some VMs are running on the host. Meanwhile, EvacuateHost should not be added into pending list as it should be be carried out before host.apply_updates. Hence it needs to be filtered out. This commit fixes a bug that filering out the EvacuateHost before the safety check. It should be filtered out after the safety check. Signed-off-by: Ming Lu --- ocaml/xapi/repository.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index 0b211d09f78..843dfc3a9b1 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -727,13 +727,11 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates = (* This function runs on coordinator host *) let open Guidance in - let guidance = + let guidance' = reduce_guidance ~updates_info ~updates:acc_rpm_updates ~livepatches - (* EvacuateHost should be carried out before host.apply_updates *) - |> List.map (fun (k, l) -> (k, List.filter (fun x -> x <> EvacuateHost) l)) in let mandatory = - match List.assoc_opt Mandatory guidance with + match List.assoc_opt Mandatory guidance' with | Some tasks -> tasks | None -> @@ -741,6 +739,11 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates [] in assert_host_evacuation_if_required ~__context ~host ~mandatory ; + let guidance = + (* EvacuateHost should be carried out before host.apply_updates *) + guidance' + |> List.map (fun (k, l) -> (k, List.filter (fun x -> x <> EvacuateHost) l)) + in (* Install RPM updates *) Helpers.call_api_functions ~__context (fun rpc session_id -> Client.Client.Repository.apply ~rpc ~session_id ~host From 04975d2df57b89923677bd9d0fdd7ea80c249b08 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 11 Jan 2024 18:26:16 +0800 Subject: [PATCH 19/39] CA-387201: Pool.last_sync_date not reset if the user changes the update channel When a user adds more update repositories as enabled ones, the pool.last_update_sync will be invalid as at the moment not all the enabled repositories have been synced at the time which is recorded in pool.last_update_sync. To avoid confusion, this commit resets the field to epoch so that the user can be notified to do a pool.sync_updates soon. Disabling an update repository will not make the pool.last_update_sync be invalid unless no enabled repositories after the disabling. Signed-off-by: Ming Lu --- ocaml/xapi/xapi_pool.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 04aac2ef09c..fac2a123cb6 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -3352,11 +3352,14 @@ let set_repositories ~__context ~self ~value = (fun x -> if not (List.mem x existings) then ( Db.Repository.set_hash ~__context ~self:x ~value:"" ; - Repository.reset_updates_in_cache () + Repository.reset_updates_in_cache () ; + Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch ) ) value ; - Db.Pool.set_repositories ~__context ~self ~value + Db.Pool.set_repositories ~__context ~self ~value ; + if Db.Pool.get_repositories ~__context ~self = [] then + Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch let add_repository ~__context ~self ~value = Xapi_pool_helpers.with_pool_operation ~__context ~self @@ -3366,7 +3369,8 @@ let add_repository ~__context ~self ~value = if not (List.mem value existings) then ( Db.Pool.add_repositories ~__context ~self ~value ; Db.Repository.set_hash ~__context ~self:value ~value:"" ; - Repository.reset_updates_in_cache () + Repository.reset_updates_in_cache () ; + Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch ) let remove_repository ~__context ~self ~value = @@ -3381,7 +3385,9 @@ let remove_repository ~__context ~self ~value = ) ) (Db.Pool.get_repositories ~__context ~self) ; - Db.Pool.remove_repositories ~__context ~self ~value + Db.Pool.remove_repositories ~__context ~self ~value ; + if Db.Pool.get_repositories ~__context ~self = [] then + Db.Pool.set_last_update_sync ~__context ~self ~value:Date.epoch let sync_updates ~__context ~self ~force ~token ~token_id = Pool_features.assert_enabled ~__context ~f:Features.Updates ; From ff251546935423c87e6f34af8638cdf48376d663 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Wed, 20 Dec 2023 13:55:02 +0800 Subject: [PATCH 20/39] CP-45570: Clear host update guidance There were 2 problems about host update guidance: 1. RestartToolstack guidance in pool member was cleared when there was a xapi restart in pool coordinator. This is because "consider_enabling_host_request" in pool member would be called when there is a xapi restart in pool coordinator, as the db connection to the coordinator will be re-established then. 2. CA-387695: RebootHost guidance in pool member got cleared when there was a xapi restart in pool coordinator. When xapi is started with a host (re)boot, its command line looks like: /opt/xensource/bin/xapi -nowatchdog -writereadyfile /var/run/xapi_startup.cookie -writeinitcomplete /var/run/xapi_init_complete.cookie -onsystemboot then "!Xapi_globs.on_system_boot" will always be true. Same as above, "consider_enabling_host_request" in pool member would be called when there is a xapi restart in pool coordinator. And when "!Xapi_globs.on_system_boot" is true for xapi in the pool member, the RebootHost guidance in pool member would be cleared when there was a xapi restart in pool coordinator. These 2 problems are resolved by clearing host update guidance in function "Dbsync_slave.update_env", which is called only during xapi startup. Signed-off-by: Gang Ji --- ocaml/xapi/dbsync_slave.ml | 19 +++++++++++- ocaml/xapi/xapi_host_helpers.ml | 51 +++++++++++++++++++++++--------- ocaml/xapi/xapi_host_helpers.mli | 14 +++++++++ 3 files changed, 69 insertions(+), 15 deletions(-) diff --git a/ocaml/xapi/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml index 594cdd83075..84af29bbf7f 100644 --- a/ocaml/xapi/dbsync_slave.ml +++ b/ocaml/xapi/dbsync_slave.ml @@ -232,6 +232,21 @@ let resynchronise_pif_params ~__context = (* Ensure that all DHCP PIFs have their IP address updated in the DB *) Helpers.update_pif_addresses ~__context +let remove_pending_guidances ~__context = + let localhost = Helpers.get_localhost ~__context in + Xapi_host_helpers.remove_pending_guidance ~__context ~self:localhost + ~value:`restart_toolstack ; + if !Xapi_globs.on_system_boot then ( + Xapi_host_helpers.remove_pending_guidance ~__context ~self:localhost + ~value:`reboot_host ; + Xapi_host_helpers.remove_pending_guidance ~__context ~self:localhost + ~value:`reboot_host_on_livepatch_failure ; + Xapi_host_helpers.remove_pending_guidance ~__context ~self:localhost + ~value:`reboot_host_on_kernel_livepatch_failure ; + Xapi_host_helpers.remove_pending_guidance ~__context ~self:localhost + ~value:`reboot_host_on_xen_livepatch_failure + ) + (** Update the database to reflect current state. Called for both start of day and after an agent restart. *) let update_env __context sync_keys = @@ -351,4 +366,6 @@ let update_env __context sync_keys = switched_sync Xapi_globs.sync_chipset_info (fun () -> Create_misc.create_chipset_info ~__context info ) ; - switched_sync Xapi_globs.sync_gpus (fun () -> Xapi_pgpu.update_gpus ~__context) + switched_sync Xapi_globs.sync_gpus (fun () -> Xapi_pgpu.update_gpus ~__context) ; + + remove_pending_guidances ~__context diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 9549c0176d8..34bb7de8a34 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -344,6 +344,42 @@ let assert_xen_compatible () = if not compatible then raise Api_errors.(Server_error (xen_incompatible, [])) +let remove_pending_guidance ~__context ~self ~value = + let h = Db.Host.get_name_label ~__context ~self in + if + List.exists + (fun g -> g = value) + (Db.Host.get_pending_guidances ~__context ~self) + then ( + debug "Remove guidance [%s] from host [%s]'s pending_guidances list" + Updateinfo.Guidance.(of_pending_guidance value |> to_string) + h ; + Db.Host.remove_pending_guidances ~__context ~self ~value + ) ; + + if + List.exists + (fun g -> g = value) + (Db.Host.get_pending_guidances_recommended ~__context ~self) + then ( + debug + "Remove guidance [%s] from host [%s]'s pending_guidances_recommended list" + Updateinfo.Guidance.(of_pending_guidance value |> to_string) + h ; + Db.Host.remove_pending_guidances_recommended ~__context ~self ~value + ) ; + + if + List.exists + (fun g -> g = value) + (Db.Host.get_pending_guidances_full ~__context ~self) + then ( + debug "Remove guidance [%s] from host [%s]'s pending_guidances_full list" + Updateinfo.Guidance.(of_pending_guidance value |> to_string) + h ; + Db.Host.remove_pending_guidances_full ~__context ~self ~value + ) + let consider_enabling_host_nolock ~__context = debug "Xapi_host_helpers.consider_enabling_host_nolock called" ; (* If HA is enabled only consider marking the host as enabled if all the storage plugs in successfully. @@ -372,8 +408,6 @@ let consider_enabling_host_nolock ~__context = letting a machine with no fencing touch any VMs. Once the host reboots we can safely clear the flag 'host_disabled_until_reboot' *) let pool = Helpers.get_pool ~__context in - Db.Host.remove_pending_guidances ~__context ~self:localhost - ~value:`restart_toolstack ; let if_no_pending_guidances f = let host_pending_mandatory_guidances = Db.Host.get_pending_guidances ~__context ~self:localhost @@ -395,18 +429,7 @@ let consider_enabling_host_nolock ~__context = f () in if !Xapi_globs.on_system_boot then ( - debug - "Host.enabled: system has just restarted: remove livepatch failure \ - guidances" ; - Db.Host.remove_pending_guidances ~__context ~self:localhost - ~value:`reboot_host ; - Db.Host.remove_pending_guidances ~__context ~self:localhost - ~value:`reboot_host_on_livepatch_failure ; - Db.Host.remove_pending_guidances_recommended ~__context ~self:localhost - ~value:`reboot_host_on_kernel_livepatch_failure ; - Db.Host.remove_pending_guidances_recommended ~__context ~self:localhost - ~value:`reboot_host_on_xen_livepatch_failure ; - + debug "Host.enabled: system has just restarted" ; if_no_pending_guidances (fun () -> debug "Host.enabled: system has just restarted and no pending mandatory \ diff --git a/ocaml/xapi/xapi_host_helpers.mli b/ocaml/xapi/xapi_host_helpers.mli index 0434dabdf7a..519aa34a560 100644 --- a/ocaml/xapi/xapi_host_helpers.mli +++ b/ocaml/xapi/xapi_host_helpers.mli @@ -100,6 +100,20 @@ val assert_xen_compatible : unit -> unit currently installed xenctrl library and the currently running Xen hypervisor.) Raises XEN_INCOMPATIBLE if not, and caches the outcome of the check. *) +val remove_pending_guidance : + __context:Context.t + -> self:API.ref_host + -> value: + [ `reboot_host + | `reboot_host_on_kernel_livepatch_failure + | `reboot_host_on_livepatch_failure + | `reboot_host_on_xen_livepatch_failure + | `restart_device_model + | `restart_toolstack + | `restart_vm ] + -> unit +(** Removes update guidance from a host's all pending guidances lists. *) + module Host_requires_reboot : sig val set : unit -> unit (** [set ()] is used to signal the host needs a reboot. This could be, for From 758f3b18a3d7e1ed30aa4ca61d7dd5a76e3f6bea Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Wed, 20 Dec 2023 16:12:36 +0800 Subject: [PATCH 21/39] CP-45570: Clear VM update guidance When a VM reboots, its qemu-dm- process restarts with its domid changed, but its RestartDeviceModel guidance was not cleared. This issue is resolved in this commit. When a VM starts, or reboots, xapi will be notified by xenopsd event to update its "last_start_time", RestartDeviceModel and RestartVM guidance is cleared there on VM start and VM reboot. When a VM is shutdown, "force_state_reset_keep_current_operations" will always be called to set the VM's state to "`Halted", RestartVM and RestartDeviceModel guidance is cleared there on VM shutdown. When a VM is suspended, "force_state_reset_keep_current_operations" will always to called to set the VM's state to "`Suspended", RestartDeviceModel guidance is cleared there on VM suspend. When a VM is migrated, "pool_migrate_complete" will always be called, RestartDeviceModel guidance is cleared there on VM migration. Below are the tested scenarios: VM running -> (force)halted result: RestartDeviceMode RestartVM cleared if any VM running -> paused result: Nothing VM running -> suspended result: RestartDeviceMode cleared if any VM halted -> running result: RestartDeviceMode RestartVM cleared if any VM paused -> running result: Nothing VM paused -> (force)halted result: RestartDeviceMode RestartVM cleared if any VM paused -> (force)reboot result: RestartDeviceMode RestartVM cleared if any VM suspend -> running result: Nothing VM suspend -> force halted result: RestartDeviceMode RestartVM cleared if any VM running -> (force)reboot result: RestartDeviceMode RestartVM cleared if any VM running -> take snapshot with no memory result: Nothing VM running -> take snapshot with memory result: RestartDeviceMode cleared if any VM running(with RestartDeviceMode and RestartVM guidance) -> take snapshot with no memory -> revert to snapshot with no memory result: both RestartDeviceMode RestartVM cleared VM running(with RestartDeviceMode and RestartVM guidance) -> take snapshot with memory -> add RestartDeviceMode guidance -> revert to snapshot with memory result: RestartDeviceMode cleared, RestartVM remains VM running(with RestartDeviceMode and RestartVM guidance) -> take snapshot with no memory -> clear RestartDeviceMode RestartVM guidance by reboot -> revert to snapshot with no memory result: both RestartDeviceMode and RestartVM cleared VM running(with RestartDeviceMode and RestartVM guidance) -> take snapshot with memory -> clear RestartDeviceMode RestartVM guidance by reboot -> revert to snapshot with memory result: only RestartDeviceMode cleared, RestartVM restored One side effect from this change: In case there is any RestartVM or RestartDeviceModel guidance on a halted VM, then a toolstack restart on pool master will clear those VM guidance from the halted VMs. However it should not be a problem as: 1. xapi will not add VM guidance on halted VMs 2. once a VM turns to halted state, the VM guidance will be cleared by xapi So there should not be any VM guidance on halted VMs. Signed-off-by: Gang Ji --- ocaml/xapi/xapi_vm_lifecycle.ml | 40 +++++++++++++++++++++++++++++++++ ocaml/xapi/xapi_vm_migrate.ml | 3 +++ ocaml/xapi/xapi_xenops.ml | 33 +++++++++++++++++++-------- 3 files changed, 67 insertions(+), 9 deletions(-) diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index 53f6076e89d..d90da39619e 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -816,6 +816,42 @@ let checkpoint_in_progress ~__context ~vm = (List.map snd (Db.VM.get_current_operations ~__context ~self:vm)) |> List.mem `checkpoint +let remove_pending_guidance ~__context ~self ~value = + let v = Db.VM.get_name_label ~__context ~self in + if + List.exists + (fun g -> g = value) + (Db.VM.get_pending_guidances ~__context ~self) + then ( + debug "Remove guidance [%s] from vm [%s]'s pending_guidances list" + Updateinfo.Guidance.(of_pending_guidance value |> to_string) + v ; + Db.VM.remove_pending_guidances ~__context ~self ~value + ) ; + + if + List.exists + (fun g -> g = value) + (Db.VM.get_pending_guidances_recommended ~__context ~self) + then ( + debug + "Remove guidance [%s] from vm [%s]'s pending_guidances_recommended list" + Updateinfo.Guidance.(of_pending_guidance value |> to_string) + v ; + Db.VM.remove_pending_guidances_recommended ~__context ~self ~value + ) ; + + if + List.exists + (fun g -> g = value) + (Db.VM.get_pending_guidances_full ~__context ~self) + then ( + debug "Remove guidance [%s] from vm [%s]'s pending_guidances_full list" + Updateinfo.Guidance.(of_pending_guidance value |> to_string) + v ; + Db.VM.remove_pending_guidances_full ~__context ~self ~value + ) + (** 1. Called on new VMs (clones, imports) and on server start to manually refresh the power state, allowed_operations field etc. Current-operations won't be cleaned @@ -823,7 +859,11 @@ let checkpoint_in_progress ~__context ~vm = let force_state_reset_keep_current_operations ~__context ~self ~value:state = (* First update the power_state. Some operations below indirectly rely on this. *) Db.VM.set_power_state ~__context ~self ~value:state ; + if state = `Suspended then + remove_pending_guidance ~__context ~self ~value:`restart_device_model ; if state = `Halted then ( + remove_pending_guidance ~__context ~self ~value:`restart_device_model ; + remove_pending_guidance ~__context ~self ~value:`restart_vm ; (* mark all devices as disconnected *) List.iter (fun vbd -> diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index d89ca3b6d89..013c0e92544 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -479,6 +479,9 @@ let remove_stale_pcis ~__context ~vm = let pool_migrate_complete ~__context ~vm ~host:_ = let id = Db.VM.get_uuid ~__context ~self:vm in debug "VM.pool_migrate_complete %s" id ; + (* clear RestartDeviceModel guidance on VM migrate *) + Xapi_vm_lifecycle.remove_pending_guidance ~__context ~self:vm + ~value:`restart_device_model ; let dbg = Context.string_of_task __context in let queue_name = Xapi_xenops_queue.queue_of_vm ~__context ~self:vm in if Xapi_xenops.vm_exists_in_xenopsd queue_name dbg id then ( diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index 73cb08de2cb..e52f24865e4 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -1999,6 +1999,9 @@ let update_vm ~__context id = xenapi_of_xenops_power_state (Option.map (fun x -> (snd x).Vm.power_state) info) in + let power_state_before_update = + Db.VM.get_power_state ~__context ~self + in (* We preserve the current_domain_type of suspended VMs like we preserve the currently_attached fields for VBDs/VIFs etc - it's important to know whether suspended VMs are going to resume into PV or PVinPVH for example. @@ -2275,13 +2278,28 @@ let update_vm ~__context id = try Option.iter (fun (_, state) -> - debug "xenopsd event: Updating VM %s last_start_time <- %s" - id - (Date.to_string (Date.of_float state.Vm.last_start_time)) ; let metrics = Db.VM.get_metrics ~__context ~self in let start_time = Date.of_float state.Vm.last_start_time in - Db.VM_metrics.set_start_time ~__context ~self:metrics - ~value:start_time ; + if + start_time + <> Db.VM_metrics.get_start_time ~__context ~self:metrics + then ( + debug + "xenopsd event: Updating VM %s last_start_time <- %s" id + (Date.to_string (Date.of_float state.Vm.last_start_time)) ; + Db.VM_metrics.set_start_time ~__context ~self:metrics + ~value:start_time ; + if + (* VM start and VM reboot *) + power_state = `Running + && power_state_before_update <> `Suspended + then ( + Xapi_vm_lifecycle.remove_pending_guidance ~__context + ~self ~value:`restart_device_model ; + Xapi_vm_lifecycle.remove_pending_guidance ~__context + ~self ~value:`restart_vm + ) + ) ; create_guest_metrics_if_needed () ; let gm = Db.VM.get_guest_metrics ~__context ~self in let update_time = @@ -3484,10 +3502,7 @@ let set_resident_on ~__context ~self = refresh_vm ~__context ~self ; !trigger_xenapi_reregister () ; (* Any future XenAPI updates will trigger events, but we might have missed one so: *) - Xenopsd_metadata.update ~__context ~self ; - Db.VM.remove_pending_guidances ~__context ~self ~value:`restart_device_model ; - Db.VM.remove_recommended_guidances ~__context ~self - ~value:`restart_device_model + Xenopsd_metadata.update ~__context ~self let update_debug_info __context t = let task = Context.get_task_id __context in From 54039f33ab8039bf56a66f0b9edf8aac3cae702a Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 5 Jan 2024 11:02:11 +0800 Subject: [PATCH 22/39] CP-45572,CP-45573: Split 'check_task_status' function out The checking task status logic in CLI server side is used by multiple interfaces. It's better to split it out to resolve the duplications. Signed-off-by: Ming Lu --- ocaml/xapi-cli-server/cli_operations.ml | 118 ++++++++---------------- 1 file changed, 38 insertions(+), 80 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index 6a054697896..f357b6b8820 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -5462,6 +5462,34 @@ let wait_for_task_complete rpc session_id task_id = Thread.delay 1.0 done +let check_task_status ~rpc ~session_id ~task ~fd ~label ~ok = + (* if the client thinks it's ok, check that the server does too *) + match Client.Task.get_status ~rpc ~session_id ~self:task with + | `success when ok -> + marshal fd (Command (Print (Printf.sprintf "%s succeeded" label))) + | `success -> + marshal fd + (Command + (PrintStderr (Printf.sprintf "%s failed, unknown error.\n" label)) + ) ; + raise (ExitWithError 1) + | `failure -> + let result = Client.Task.get_error_info ~rpc ~session_id ~self:task in + if result = [] then + marshal fd + (Command + (PrintStderr (Printf.sprintf "%s failed, unknown error\n" label)) + ) + else + raise (Api_errors.Server_error (List.hd result, List.tl result)) + | `cancelled -> + marshal fd (Command (PrintStderr (Printf.sprintf "%s cancelled\n" label))) ; + raise (ExitWithError 1) + | _ -> + marshal fd (Command (PrintStderr "Internal error\n")) ; + (* should never happen *) + raise (ExitWithError 1) + let download_file rpc session_id task fd filename uri label = marshal fd (Command (HttpGet (filename, uri))) ; let response = ref (Response Wait) in @@ -5469,10 +5497,12 @@ let download_file rpc session_id task fd filename uri label = response := unmarshal fd done ; let ok = - match !response with - | Response OK -> + match (!response, filename <> "") with + | Response OK, true -> true - | Response Failed -> + | Response OK, false -> + false + | Response Failed, _ -> (* Need to check whether the thin cli managed to contact the server or not. If not, we need to mark the task as failed *) if Client.Task.get_progress ~rpc ~session_id ~self:task < 0.0 then @@ -5484,34 +5514,7 @@ let download_file rpc session_id task fd filename uri label = wait_for_task_complete rpc session_id task ; (* Check the server status -- even if the client thinks it's ok, we need to check that the server does too. *) - match Client.Task.get_status ~rpc ~session_id ~self:task with - | `success -> - if ok then ( - if filename <> "" then - marshal fd (Command (Print (Printf.sprintf "%s succeeded" label))) - ) else ( - marshal fd - (Command - (PrintStderr (Printf.sprintf "%s failed, unknown error.\n" label)) - ) ; - raise (ExitWithError 1) - ) - | `failure -> - let result = Client.Task.get_error_info ~rpc ~session_id ~self:task in - if result = [] then - marshal fd - (Command - (PrintStderr (Printf.sprintf "%s failed, unknown error\n" label)) - ) - else - raise (Api_errors.Server_error (List.hd result, List.tl result)) - | `cancelled -> - marshal fd (Command (PrintStderr (Printf.sprintf "%s cancelled\n" label))) ; - raise (ExitWithError 1) - | _ -> - marshal fd (Command (PrintStderr "Internal error\n")) ; - (* should never happen *) - raise (ExitWithError 1) + check_task_status ~rpc ~session_id ~task ~fd ~label ~ok let download_file_with_task fd rpc session_id filename uri query label task_name = @@ -5711,31 +5714,8 @@ let blob_get fd _printer rpc session_id params = false in wait_for_task_complete rpc session_id blobtask ; - (* if the client thinks it's ok, check that the server does too *) - match Client.Task.get_status ~rpc ~session_id ~self:blobtask with - | `success -> - if ok then - marshal fd (Command (Print "Blob get succeeded")) - else ( - marshal fd - (Command (PrintStderr "Blob get failed, unknown error.\n")) ; - raise (ExitWithError 1) - ) - | `failure -> - let result = - Client.Task.get_error_info ~rpc ~session_id ~self:blobtask - in - if result = [] then - marshal fd (Command (PrintStderr "Blob get failed, unknown error\n")) - else - raise (Api_errors.Server_error (List.hd result, List.tl result)) - | `cancelled -> - marshal fd (Command (PrintStderr "Blob get cancelled\n")) ; - raise (ExitWithError 1) - | _ -> - marshal fd (Command (PrintStderr "Internal error\n")) ; - (* should never happen *) - raise (ExitWithError 1) + check_task_status ~rpc ~session_id ~task:blobtask ~fd ~label:"Blob get" + ~ok ) (fun () -> Client.Task.destroy ~rpc ~session_id ~self:blobtask) @@ -5776,30 +5756,8 @@ let blob_put fd _printer rpc session_id params = in wait_for_task_complete rpc session_id blobtask ; (* if the client thinks it's ok, check that the server does too *) - match Client.Task.get_status ~rpc ~session_id ~self:blobtask with - | `success -> - if ok then - marshal fd (Command (Print "Blob put succeeded")) - else ( - marshal fd - (Command (PrintStderr "Blob put failed, unknown error.\n")) ; - raise (ExitWithError 1) - ) - | `failure -> - let result = - Client.Task.get_error_info ~rpc ~session_id ~self:blobtask - in - if result = [] then - marshal fd (Command (PrintStderr "Blob put failed, unknown error\n")) - else - raise (Api_errors.Server_error (List.hd result, List.tl result)) - | `cancelled -> - marshal fd (Command (PrintStderr "Blob put cancelled\n")) ; - raise (ExitWithError 1) - | _ -> - marshal fd (Command (PrintStderr "Internal error\n")) ; - (* should never happen *) - raise (ExitWithError 1) + check_task_status ~rpc ~session_id ~task:blobtask ~fd ~label:"Blob put" + ~ok ) (fun () -> Client.Task.destroy ~rpc ~session_id ~self:blobtask) From a53e54deb083930c2159bd50fe8a5fbd35e4ca55 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 5 Jan 2024 14:58:38 +0800 Subject: [PATCH 23/39] CP-45572,CP-45573: Split 'do_http_get' function out The function will be re-used in next commit. Signed-off-by: Ming Lu --- ocaml/xe-cli/newcli.ml | 112 ++++++++++++++++++++--------------------- 1 file changed, 54 insertions(+), 58 deletions(-) diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index d197b849a94..634ee4d4ebf 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -435,6 +435,38 @@ let assert_filename_permitted ?(permit_cwd = false) permitted_filenames filename | _ -> () +let do_http_get ofd url exit_code f = + try + let rec doit url = + let server, path = parse_url url in + debug "Opening connection to server '%s' path '%s'\n%!" server path ; + with_open_tcp server @@ fun (ic, oc) -> + Printf.fprintf oc "GET %s HTTP/1.0\r\n\r\n" path ; + flush oc ; + (* Get the result header immediately *) + let resultline = input_line ic in + debug "Got %s\n%!" resultline ; + match http_response_code resultline with + | 200 -> + f ic ; marshal ofd (Response OK) + | 302 -> + let headers = read_rest_of_headers ic in + let newloc = List.assoc "location" headers in + (* see above about Unixfd.with_connection *) + close_in_noerr ic ; close_out_noerr oc ; doit newloc + | _ -> + failwith "Unhandled response code" + in + doit url + with + | ClientSideError msg -> + marshal ofd (Response Failed) ; + Printf.fprintf stderr "Operation failed. Error: %s\n" msg ; + exit_code := Some 1 + | e -> + debug "HTTP GET failure: %s\n%!" (Printexc.to_string e) ; + marshal ofd (Response Failed) + let main_loop ifd ofd permitted_filenames = (* Intially exchange version information *) let major', minor' = @@ -709,64 +741,28 @@ let main_loop ifd ofd permitted_filenames = the normal communication channel *) marshal ofd (Response Failed) ) - | Command (HttpGet (filename, url)) -> ( - try - let rec doit url = - let server, path = parse_url url in - debug "Opening connection to server '%s' path '%s'\n%!" server path ; - with_open_tcp server @@ fun (ic, oc) -> - Printf.fprintf oc "GET %s HTTP/1.0\r\n\r\n" path ; - flush oc ; - (* Get the result header immediately *) - let resultline = input_line ic in - debug "Got %s\n%!" resultline ; - match http_response_code resultline with - | 200 -> - let file_ch = - if filename = "" then - Unix.out_channel_of_descr (Unix.dup Unix.stdout) - else ( - assert_filename_permitted ~permit_cwd:true permitted_filenames - filename ; - try - open_out_gen - [Open_wronly; Open_creat; Open_excl] - 0o600 filename - with e -> raise (ClientSideError (Printexc.to_string e)) - ) - in - while input_line ic <> "\r" do - () - done ; - Pervasiveext.finally - (fun () -> - copy_with_heartbeat ic file_ch heartbeat_fun ; - marshal ofd (Response OK) - ) - (fun () -> try close_out file_ch with _ -> ()) - | 302 -> - let headers = read_rest_of_headers ic in - let newloc = List.assoc "location" headers in - (* see above about Unixfd.with_connection *) - close_in_noerr ic ; close_out_noerr oc ; doit newloc - | _ -> - failwith "Unhandled response code" - in - doit url - with - | ClientSideError msg -> - marshal ofd (Response Failed) ; - Printf.fprintf stderr "Operation failed. Error: %s\n" msg ; - exit_code := Some 1 - | e -> ( - match e with - | Filename_not_permitted _ -> - raise e - | _ -> - debug "HttpGet failure: %s\n%!" (Printexc.to_string e) ; - marshal ofd (Response Failed) - ) - ) + | Command (HttpGet (filename, url)) -> + do_http_get ofd url exit_code (fun ic -> + let file_ch = + if filename = "" then + Unix.out_channel_of_descr (Unix.dup Unix.stdout) + else ( + assert_filename_permitted ~permit_cwd:true permitted_filenames + filename ; + try + open_out_gen + [Open_wronly; Open_creat; Open_excl] + 0o600 filename + with e -> raise (ClientSideError (Printexc.to_string e)) + ) + in + while input_line ic <> "\r" do + () + done ; + Pervasiveext.finally + (fun () -> copy_with_heartbeat ic file_ch heartbeat_fun) + (fun () -> try close_out file_ch with _ -> ()) + ) | Command Prompt -> let data = input_line stdin in marshal ofd (Blob (Chunk (Int32.of_int (String.length data)))) ; From a9cc141b2b3dbee760a1ba9083e1240eb5a6e0c1 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Wed, 24 Jan 2024 15:24:47 +0800 Subject: [PATCH 24/39] CP-44324: Block "host.enable" during "host.apply_updates" Signed-off-by: Gang Ji --- ocaml/idl/datamodel_host.ml | 1 + ocaml/idl/schematest.ml | 2 +- ocaml/xapi-cli-server/record_util.ml | 2 ++ ocaml/xapi/message_forwarding.ml | 7 +++++-- ocaml/xapi/xapi_host_helpers.ml | 3 ++- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index 4e1fd8a70ee..18a9ebea9cf 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -1263,6 +1263,7 @@ let operations = ; ("vm_resume", "This host is resuming a VM") ; ("vm_migrate", "This host is the migration target of a VM") ; ("apply_updates", "Indicates this host is being updated") + ; ("enable", "Indicates this host is in the process of enabling") ] ) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index f96237c6f89..da2079468bd 100644 --- a/ocaml/idl/schematest.ml +++ b/ocaml/idl/schematest.ml @@ -2,7 +2,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 = "a2378b3ff9c452cb61f0cab7d9f84a46" +let last_known_schema_hash = "1eeb818fb158749cbbfe5bba58068c05" let current_schema_hash : string = let open Datamodel_types in diff --git a/ocaml/xapi-cli-server/record_util.ml b/ocaml/xapi-cli-server/record_util.ml index e21963c7172..05b18d58ab8 100644 --- a/ocaml/xapi-cli-server/record_util.ml +++ b/ocaml/xapi-cli-server/record_util.ml @@ -197,6 +197,8 @@ let host_operation_to_string = function "VM.migrate" | `apply_updates -> "apply_updates" + | `enable -> + "enable" let update_guidance_to_string = function | `reboot_host -> diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 42f86f94166..717492591b1 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -3269,8 +3269,11 @@ functor let enable ~__context ~host = info "Host.enable: host = '%s'" (host_uuid ~__context host) ; let local_fn = Local.Host.enable ~host in - do_op_on ~local_fn ~__context ~host (fun session_id rpc -> - Client.Host.enable ~rpc ~session_id ~host + Xapi_host_helpers.with_host_operation ~__context ~self:host + ~doc:"Host.enable" ~op:`enable (fun () -> + do_op_on ~local_fn ~__context ~host (fun session_id rpc -> + Client.Host.enable ~rpc ~session_id ~host + ) ) ; Xapi_host_helpers.update_allowed_operations ~__context ~self:host diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 34bb7de8a34..040f5782273 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -37,6 +37,7 @@ let all_operations = ; `vm_migrate ; `power_on ; `apply_updates + ; `enable ] (** Returns a table of operations -> API error options (None if the operation would be ok) *) @@ -86,7 +87,7 @@ let valid_operations ~__context record _ref' = if List.mem `apply_updates current_ops then set_errors Api_errors.other_operation_in_progress ["host"; _ref; host_operation_to_string `apply_updates] - [`reboot; `shutdown] ; + [`reboot; `shutdown; `enable] ; (* Prevent more than one provision happening at a time to prevent extreme dom0 load (in the case of the debian template). Once the template becomes a 'real' template we can relax this. *) From 356de9dc1f144b5a12f0528584a6b020536dc034 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Thu, 25 Jan 2024 13:24:15 +0800 Subject: [PATCH 25/39] CA-388107: Make sure VM is running when starting restart_device_models Now vm.restart_device_models is implemented using a local vm.pool_migrate. For vm.pool_migrate, a destination host is expected, while for vm.restart_device_models, no destination host is needed. With a missing destination host(NULL), when a VM is paused or halted, vm.pool_migrate will raise Api_errors.vm_bad_power_state, while not for a suspended VM. As this is not an issue of vm.pool_migrate, check VM power state before calling vm.pool_migrate in vm.restart_device_models. Signed-off-by: Gang Ji --- ocaml/xapi/xapi_vm.ml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 11c6c94859b..45bb232e693 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1613,6 +1613,19 @@ let set_NVRAM_EFI_variables ~__context ~self ~value = ) let restart_device_models ~__context ~self = + let power_state = Db.VM.get_power_state ~__context ~self in + if power_state <> `Running then + raise + Api_errors.( + Server_error + ( vm_bad_power_state + , [ + Ref.string_of self + ; Record_util.power_state_to_string `Running + ; Record_util.power_state_to_string power_state + ] + ) + ) ; let host = Db.VM.get_resident_on ~__context ~self in (* As it is implemented as a localhost migration, just reuse message * forwarding of "pool_migrate" to handle "allowed operation" and "message From 1bc2f3db7db15ad495b2b8bcd613ad648275a002 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 26 Jan 2024 11:13:11 +0800 Subject: [PATCH 26/39] Update 'last_known_schema_hash' in feature branch This will be updated finally just before merging into master branch. Signed-off-by: Ming Lu --- ocaml/idl/schematest.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 660f39664f5..7f029c22d3d 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 = "2923e663753266bbdcb313ed47bad726" +let last_known_schema_hash = "49c51c0b5e895f42a1c9c19abb038b41" let current_schema_hash : string = let open Datamodel_types in From bb846ee6a86ecd49dbd1c3587fde99e8a4c319c2 Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Mon, 29 Jan 2024 15:55:53 +0800 Subject: [PATCH 27/39] CA-388351: Always apply livepatches even if host will reboot This aligns with the update guidance exposed in /updates endpoint. Signed-off-by: Gang Ji --- ocaml/xapi/repository.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/ocaml/xapi/repository.ml b/ocaml/xapi/repository.ml index 843dfc3a9b1..bd63984c0a1 100644 --- a/ocaml/xapi/repository.ml +++ b/ocaml/xapi/repository.ml @@ -748,14 +748,9 @@ let apply_updates' ~__context ~host ~updates_info ~livepatches ~acc_rpm_updates Helpers.call_api_functions ~__context (fun rpc session_id -> Client.Client.Repository.apply ~rpc ~session_id ~host ) ; - (* Apply livepatches *) + (* Always apply livepatches even if host will reboot *) let applied_livepatches, failed_livepatches = - match List.mem RebootHost mandatory with - | true -> - (* Not apply any livepatches as the host will reboot *) - ([], []) - | false -> - apply_livepatches' ~__context ~host ~livepatches + apply_livepatches' ~__context ~host ~livepatches in (* Update states in cache *) update_cache ~host ~failed_livepatches ; From 8ca4b43a9b6fbadb8f2832e05366de33fc859f6d Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 4 Jan 2024 11:35:09 +0800 Subject: [PATCH 28/39] CP-45573: Add 'xe host-updates-show-available' CLI The available updates are retrieved from XAPI API HTTP GET /updates. Signed-off-by: Ming Lu --- ocaml/xapi-cli-protocol/cli_protocol.ml | 10 +++- ocaml/xapi-cli-server/cli_frontend.ml | 9 +++ ocaml/xapi-cli-server/cli_operations.ml | 73 +++++++++++++++++++++++-- ocaml/xe-cli/newcli.ml | 10 ++++ 4 files changed, 96 insertions(+), 6 deletions(-) diff --git a/ocaml/xapi-cli-protocol/cli_protocol.ml b/ocaml/xapi-cli-protocol/cli_protocol.ml index 6f3be830fa2..38d0f76871c 100644 --- a/ocaml/xapi-cli-protocol/cli_protocol.ml +++ b/ocaml/xapi-cli-protocol/cli_protocol.ml @@ -34,6 +34,7 @@ type command = | Debug of string (* debug message to optionally display *) | Load of string (* filename *) | HttpGet of string * string (* filename * path *) + | PrintHttpGetJson of string (* path *) | HttpPut of string * string (* filename * path *) | HttpConnect of string (* path *) | Prompt (* request the user enter some text *) @@ -66,6 +67,8 @@ let string_of_command = function "Load " ^ x | HttpGet (filename, path) -> "HttpGet " ^ path ^ " -> " ^ filename + | PrintHttpGetJson path -> + "PrintHttpGetJson " ^ path ^ " -> stdout" | HttpPut (filename, path) -> "HttpPut " ^ path ^ " -> " ^ filename | HttpConnect path -> @@ -155,7 +158,7 @@ let unmarshal_list pos f = (*****************************************************************************) (* Marshal/Unmarshal higher-level messages *) -(* Highest command id: 17 *) +(* Highest command id: 18 *) let marshal_command = function | Print x -> @@ -166,6 +169,8 @@ let marshal_command = function marshal_int 1 ^ marshal_string x | HttpGet (a, b) -> marshal_int 12 ^ marshal_string a ^ marshal_string b + | PrintHttpGetJson a -> + marshal_int 18 ^ marshal_string a | HttpPut (a, b) -> marshal_int 13 ^ marshal_string a ^ marshal_string b | HttpConnect a -> @@ -216,6 +221,9 @@ let unmarshal_command pos = | 16 -> let body, pos = unmarshal_string pos in (PrintStderr body, pos) + | 18 -> + let a, pos = unmarshal_string pos in + (PrintHttpGetJson a, pos) | n -> raise (Unknown_tag ("command", n)) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index f8aa043eb5a..09ce4f79dfb 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -1047,6 +1047,15 @@ let rec cmdtable_data : (string * cmd_spec) list = ; flags= [Neverforward] } ) + ; ( "host-updates-show-available" + , { + reqd= [] + ; optn= [] + ; help= "Show available updates for a specified host." + ; implementation= With_fd Cli_operations.host_updates_show_available + ; flags= [Host_selectors] + } + ) ; ( "patch-upload" , { reqd= ["file-name"] diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index f357b6b8820..a90d07a411b 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -5462,11 +5462,14 @@ let wait_for_task_complete rpc session_id task_id = Thread.delay 1.0 done -let check_task_status ~rpc ~session_id ~task ~fd ~label ~ok = +let check_task_status ?(quiet_on_success = false) ~rpc ~session_id ~task ~fd + ~label ~ok () = (* if the client thinks it's ok, check that the server does too *) match Client.Task.get_status ~rpc ~session_id ~self:task with - | `success when ok -> + | `success when ok && not quiet_on_success -> marshal fd (Command (Print (Printf.sprintf "%s succeeded" label))) + | `success when ok && quiet_on_success -> + () | `success -> marshal fd (Command @@ -5514,7 +5517,7 @@ let download_file rpc session_id task fd filename uri label = wait_for_task_complete rpc session_id task ; (* Check the server status -- even if the client thinks it's ok, we need to check that the server does too. *) - check_task_status ~rpc ~session_id ~task ~fd ~label ~ok + check_task_status ~rpc ~session_id ~task ~fd ~label ~ok () let download_file_with_task fd rpc session_id filename uri query label task_name = @@ -5715,7 +5718,7 @@ let blob_get fd _printer rpc session_id params = in wait_for_task_complete rpc session_id blobtask ; check_task_status ~rpc ~session_id ~task:blobtask ~fd ~label:"Blob get" - ~ok + ~ok () ) (fun () -> Client.Task.destroy ~rpc ~session_id ~self:blobtask) @@ -5757,7 +5760,7 @@ let blob_put fd _printer rpc session_id params = wait_for_task_complete rpc session_id blobtask ; (* if the client thinks it's ok, check that the server does too *) check_task_status ~rpc ~session_id ~task:blobtask ~fd ~label:"Blob put" - ~ok + ~ok () ) (fun () -> Client.Task.destroy ~rpc ~session_id ~self:blobtask) @@ -7642,6 +7645,57 @@ let update_resync_host _printer rpc session_id params = let host = Client.Host.get_by_uuid ~rpc ~session_id ~uuid in Client.Pool_update.resync_host ~rpc ~session_id ~host +let get_avail_updates_uri ~session_id ~task ~host = + let query = + [ + ("session_id", [Ref.string_of session_id]) + ; ("task_id", [Ref.string_of task]) + ; ("host_refs", [Ref.string_of host]) + ] + in + Uri.make ~path:Constants.get_updates_uri ~query () |> Uri.to_string + +let command_in_task ~rpc ~session_id ~fd ~host ~label f = + let task = + Client.Task.create ~rpc ~session_id + ~label:(Printf.sprintf "%s for host (ref=%s)" label (Ref.string_of host)) + ~description:"" + in + Client.Task.set_progress ~rpc ~session_id ~self:task ~value:(-1.0) ; + let command = f session_id task host in + finally + (fun () -> + marshal fd (Command command) ; + let response = ref (Response Wait) in + while !response = Response Wait do + response := unmarshal fd + done ; + let ok = + match !response with + | Response OK -> + true + | Response Failed -> + (* Need to check whether the thin cli managed to contact the server + * or not. If not, we need to mark the task as failed. + *) + if Client.Task.get_progress ~rpc ~session_id ~self:task < 0.0 then + Client.Task.set_status ~rpc ~session_id ~self:task ~value:`failure ; + false + | _ -> + false + in + wait_for_task_complete rpc session_id task ; + check_task_status ~rpc ~session_id ~task ~fd ~label ~ok + ~quiet_on_success:true () + ) + (fun () -> Client.Task.destroy ~rpc ~session_id ~self:task) + +let print_avail_updates ~rpc ~session_id ~fd ~host = + command_in_task ~rpc ~session_id ~fd ~host ~label:"Print available updates" + (fun session_id task host -> + PrintHttpGetJson (get_avail_updates_uri ~session_id ~task ~host) + ) + let host_apply_updates _printer rpc session_id params = let hash = List.assoc "hash" params in ignore @@ -7656,6 +7710,15 @@ let host_apply_updates _printer rpc session_id params = params ["hash"] ) +let host_updates_show_available fd _printer rpc session_id params = + do_host_op rpc session_id ~multiple:false + (fun _ host -> + let host = host.getref () in + print_avail_updates ~rpc ~session_id ~fd ~host + ) + params [] + |> ignore + module SDN_controller = struct let introduce printer rpc session_id params = let port = diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 634ee4d4ebf..7dddf2ee359 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -763,6 +763,16 @@ let main_loop ifd ofd permitted_filenames = (fun () -> copy_with_heartbeat ic file_ch heartbeat_fun) (fun () -> try close_out file_ch with _ -> ()) ) + | Command (PrintHttpGetJson url) -> + do_http_get ofd url exit_code (fun ic -> + while input_line ic <> "\r" do + () + done ; + Yojson.Basic.from_channel ic + |> Yojson.Basic.pretty_to_string + |> print_endline ; + flush stdout + ) | Command Prompt -> let data = input_line stdin in marshal ofd (Blob (Chunk (Int32.of_int (String.length data)))) ; From 6668d5f5609eb75a50b7dd4138412e6bf9a732bd Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 23 Jan 2024 15:21:39 +0800 Subject: [PATCH 29/39] CP-45572: Print update guidance in xe host-apply-updates Signed-off-by: Ming Lu --- ocaml/xapi-cli-protocol/cli_protocol.ml | 10 +++++++- ocaml/xapi-cli-server/cli_frontend.ml | 2 +- ocaml/xapi-cli-server/cli_operations.ml | 34 +++++++++++++++++-------- ocaml/xe-cli/newcli.ml | 17 +++++++++++++ 4 files changed, 50 insertions(+), 13 deletions(-) diff --git a/ocaml/xapi-cli-protocol/cli_protocol.ml b/ocaml/xapi-cli-protocol/cli_protocol.ml index 38d0f76871c..261bc11b187 100644 --- a/ocaml/xapi-cli-protocol/cli_protocol.ml +++ b/ocaml/xapi-cli-protocol/cli_protocol.ml @@ -35,6 +35,7 @@ type command = | Load of string (* filename *) | HttpGet of string * string (* filename * path *) | PrintHttpGetJson of string (* path *) + | PrintUpdateGuidance of string (* path *) | HttpPut of string * string (* filename * path *) | HttpConnect of string (* path *) | Prompt (* request the user enter some text *) @@ -69,6 +70,8 @@ let string_of_command = function "HttpGet " ^ path ^ " -> " ^ filename | PrintHttpGetJson path -> "PrintHttpGetJson " ^ path ^ " -> stdout" + | PrintUpdateGuidance path -> + "PrintUpdateGuidance " ^ path ^ " -> stdout" | HttpPut (filename, path) -> "HttpPut " ^ path ^ " -> " ^ filename | HttpConnect path -> @@ -158,7 +161,7 @@ let unmarshal_list pos f = (*****************************************************************************) (* Marshal/Unmarshal higher-level messages *) -(* Highest command id: 18 *) +(* Highest command id: 19 *) let marshal_command = function | Print x -> @@ -171,6 +174,8 @@ let marshal_command = function marshal_int 12 ^ marshal_string a ^ marshal_string b | PrintHttpGetJson a -> marshal_int 18 ^ marshal_string a + | PrintUpdateGuidance a -> + marshal_int 19 ^ marshal_string a | HttpPut (a, b) -> marshal_int 13 ^ marshal_string a ^ marshal_string b | HttpConnect a -> @@ -224,6 +229,9 @@ let unmarshal_command pos = | 18 -> let a, pos = unmarshal_string pos in (PrintHttpGetJson a, pos) + | 19 -> + let a, pos = unmarshal_string pos in + (PrintUpdateGuidance a, pos) | n -> raise (Unknown_tag ("command", n)) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index 09ce4f79dfb..55d884db9d8 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -1032,7 +1032,7 @@ let rec cmdtable_data : (string * cmd_spec) list = reqd= ["hash"] ; optn= [] ; help= "Apply updates from enabled repository on specified host." - ; implementation= No_fd Cli_operations.host_apply_updates + ; implementation= With_fd Cli_operations.host_apply_updates ; flags= [Host_selectors] } ) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index a90d07a411b..b83887bff78 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -7696,19 +7696,31 @@ let print_avail_updates ~rpc ~session_id ~fd ~host = PrintHttpGetJson (get_avail_updates_uri ~session_id ~task ~host) ) -let host_apply_updates _printer rpc session_id params = +let print_update_guidance ~rpc ~session_id ~fd ~host = + command_in_task ~rpc ~session_id ~fd ~host ~label:"Print update guidance" + (fun session_id task host -> + PrintUpdateGuidance (get_avail_updates_uri ~session_id ~task ~host) + ) + +let host_apply_updates fd printer rpc session_id params = let hash = List.assoc "hash" params in - ignore - (do_host_op rpc session_id ~multiple:false - (fun _ host -> - let host = host.getref () in - Client.Host.apply_updates ~rpc ~session_id ~self:host ~hash - |> List.iter (fun l -> - _printer (Cli_printer.PMsg (String.concat "; " l)) - ) - ) - params ["hash"] + do_host_op rpc session_id ~multiple:false + (fun _ host -> + let host = host.getref () in + printer (Cli_printer.PMsg "Guidance of updates:") ; + print_update_guidance ~rpc ~session_id ~fd ~host ; + printer (Cli_printer.PMsg "Applying updates ...") ; + match Client.Host.apply_updates ~rpc ~session_id ~self:host ~hash with + | [] -> + printer (Cli_printer.PMsg "Updated.") + | warnings -> + printer (Cli_printer.PMsg "Updated with warnings:") ; + List.iter + (fun l -> printer (Cli_printer.PMsg (String.concat "; " l))) + warnings ) + params ["hash"] + |> ignore let host_updates_show_available fd _printer rpc session_id params = do_host_op rpc session_id ~multiple:false diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 7dddf2ee359..7c07c199512 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -773,6 +773,23 @@ let main_loop ifd ofd permitted_filenames = |> print_endline ; flush stdout ) + | Command (PrintUpdateGuidance url) -> + do_http_get ofd url exit_code (fun ic -> + while input_line ic <> "\r" do + () + done ; + Yojson.Basic.from_channel ic |> Yojson.Basic.Util.member "hosts" + |> function + | `List [] -> + raise (ClientSideError "No host data returned") + | `List (host :: _) -> + Yojson.Basic.Util.member "guidance" host + |> Yojson.Basic.pretty_to_string + |> print_endline ; + flush stdout + | _ -> + raise (ClientSideError "Unknown data format") + ) | Command Prompt -> let data = input_line stdin in marshal ofd (Blob (Chunk (Int32.of_int (String.length data)))) ; From db91ddf593d7b0b368535874ef45605492d04e8c Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Fri, 5 Jan 2024 16:41:29 +0800 Subject: [PATCH 30/39] Decrease the usage count of List.hd from 317 to 315 Signed-off-by: Ming Lu --- quality-gate.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/quality-gate.sh b/quality-gate.sh index 15133234a82..bf8f561afc0 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=317 + N=315 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" From 533a000b19dfd0e8ad1807ee3e8e0788075ef2b0 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Mon, 29 Jan 2024 14:11:57 +0800 Subject: [PATCH 31/39] CP-45572,CP-45573: Refine to use 'command_in_task' more Signed-off-by: Ming Lu --- ocaml/xapi-cli-server/cli_operations.ml | 137 ++++++++---------------- 1 file changed, 42 insertions(+), 95 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index b83887bff78..ccad3942e37 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -5681,24 +5681,17 @@ let vm_import fd _printer rpc session_id params = in marshal fd (Command (Print (String.concat "," uuids))) -let blob_get fd _printer rpc session_id params = - let blob_uuid = List.assoc "uuid" params in - let blob_ref = Client.Blob.get_by_uuid ~rpc ~session_id ~uuid:blob_uuid in - let filename = List.assoc "filename" params in - let blobtask = +let command_in_task ~rpc ~session_id ~fd ~obj ~label ~quiet_on_success f = + let task = Client.Task.create ~rpc ~session_id - ~label:(Printf.sprintf "Obtaining blob, ref=%s" (Ref.string_of blob_ref)) + ~label:(Printf.sprintf "%s (ref=%s)" label (Ref.string_of obj)) ~description:"" in - Client.Task.set_progress ~rpc ~session_id ~self:blobtask ~value:(-1.0) ; - let bloburi = - Printf.sprintf "%s?session_id=%s&task_id=%s&ref=%s" Constants.blob_uri - (Ref.string_of session_id) (Ref.string_of blobtask) - (Ref.string_of blob_ref) - in + Client.Task.set_progress ~rpc ~session_id ~self:task ~value:(-1.0) ; + let command = f session_id task obj in finally (fun () -> - marshal fd (Command (HttpGet (filename, bloburi))) ; + marshal fd (Command command) ; let response = ref (Response Wait) in while !response = Response Wait do response := unmarshal fd @@ -5708,61 +5701,48 @@ let blob_get fd _printer rpc session_id params = | Response OK -> true | Response Failed -> - if Client.Task.get_progress ~rpc ~session_id ~self:blobtask < 0.0 - then - Client.Task.set_status ~rpc ~session_id ~self:blobtask - ~value:`failure ; + (* Need to check whether the thin cli managed to contact the server + * or not. If not, we need to mark the task as failed. + *) + if Client.Task.get_progress ~rpc ~session_id ~self:task < 0.0 then + Client.Task.set_status ~rpc ~session_id ~self:task ~value:`failure ; false | _ -> false in - wait_for_task_complete rpc session_id blobtask ; - check_task_status ~rpc ~session_id ~task:blobtask ~fd ~label:"Blob get" - ~ok () + wait_for_task_complete rpc session_id task ; + check_task_status ~rpc ~session_id ~task ~fd ~label ~ok ~quiet_on_success + () ) - (fun () -> Client.Task.destroy ~rpc ~session_id ~self:blobtask) + (fun () -> Client.Task.destroy ~rpc ~session_id ~self:task) + +let blob_uri ~session_id ~task ~blob = + let query = + [ + ("session_id", [Ref.string_of session_id]) + ; ("task_id", [Ref.string_of task]) + ; ("ref", [Ref.string_of blob]) + ] + in + Uri.make ~path:Constants.blob_uri ~query () |> Uri.to_string + +let blob_get fd _printer rpc session_id params = + let blob_uuid = List.assoc "uuid" params in + let blob_ref = Client.Blob.get_by_uuid ~rpc ~session_id ~uuid:blob_uuid in + let filename = List.assoc "filename" params in + command_in_task ~rpc ~session_id ~fd ~obj:blob_ref ~label:"GET blob" + ~quiet_on_success:false (fun session_id task blob -> + HttpGet (filename, blob_uri ~session_id ~task ~blob) + ) let blob_put fd _printer rpc session_id params = let blob_uuid = List.assoc "uuid" params in let blob_ref = Client.Blob.get_by_uuid ~rpc ~session_id ~uuid:blob_uuid in let filename = List.assoc "filename" params in - let blobtask = - Client.Task.create ~rpc ~session_id - ~label:(Printf.sprintf "Blob PUT, ref=%s" (Ref.string_of blob_ref)) - ~description:"" - in - Client.Task.set_progress ~rpc ~session_id ~self:blobtask ~value:(-1.0) ; - let bloburi = - Printf.sprintf "%s?session_id=%s&task_id=%s&ref=%s" Constants.blob_uri - (Ref.string_of session_id) (Ref.string_of blobtask) - (Ref.string_of blob_ref) - in - finally - (fun () -> - marshal fd (Command (HttpPut (filename, bloburi))) ; - let response = ref (Response Wait) in - while !response = Response Wait do - response := unmarshal fd - done ; - let ok = - match !response with - | Response OK -> - true - | Response Failed -> - if Client.Task.get_progress ~rpc ~session_id ~self:blobtask < 0.0 - then - Client.Task.set_status ~rpc ~session_id ~self:blobtask - ~value:`failure ; - false - | _ -> - false - in - wait_for_task_complete rpc session_id blobtask ; - (* if the client thinks it's ok, check that the server does too *) - check_task_status ~rpc ~session_id ~task:blobtask ~fd ~label:"Blob put" - ~ok () - ) - (fun () -> Client.Task.destroy ~rpc ~session_id ~self:blobtask) + command_in_task ~rpc ~session_id ~fd ~obj:blob_ref ~label:"PUT blob" + ~quiet_on_success:false (fun session_id task blob -> + HttpPut (filename, blob_uri ~session_id ~task ~blob) + ) let blob_create printer rpc session_id params = let name = List.assoc "name" params in @@ -7655,49 +7635,16 @@ let get_avail_updates_uri ~session_id ~task ~host = in Uri.make ~path:Constants.get_updates_uri ~query () |> Uri.to_string -let command_in_task ~rpc ~session_id ~fd ~host ~label f = - let task = - Client.Task.create ~rpc ~session_id - ~label:(Printf.sprintf "%s for host (ref=%s)" label (Ref.string_of host)) - ~description:"" - in - Client.Task.set_progress ~rpc ~session_id ~self:task ~value:(-1.0) ; - let command = f session_id task host in - finally - (fun () -> - marshal fd (Command command) ; - let response = ref (Response Wait) in - while !response = Response Wait do - response := unmarshal fd - done ; - let ok = - match !response with - | Response OK -> - true - | Response Failed -> - (* Need to check whether the thin cli managed to contact the server - * or not. If not, we need to mark the task as failed. - *) - if Client.Task.get_progress ~rpc ~session_id ~self:task < 0.0 then - Client.Task.set_status ~rpc ~session_id ~self:task ~value:`failure ; - false - | _ -> - false - in - wait_for_task_complete rpc session_id task ; - check_task_status ~rpc ~session_id ~task ~fd ~label ~ok - ~quiet_on_success:true () - ) - (fun () -> Client.Task.destroy ~rpc ~session_id ~self:task) - let print_avail_updates ~rpc ~session_id ~fd ~host = - command_in_task ~rpc ~session_id ~fd ~host ~label:"Print available updates" + command_in_task ~rpc ~session_id ~fd ~obj:host + ~label:"Print available updates for host" ~quiet_on_success:true (fun session_id task host -> PrintHttpGetJson (get_avail_updates_uri ~session_id ~task ~host) ) let print_update_guidance ~rpc ~session_id ~fd ~host = - command_in_task ~rpc ~session_id ~fd ~host ~label:"Print update guidance" + command_in_task ~rpc ~session_id ~fd ~obj:host + ~label:"Print update guidance for host" ~quiet_on_success:true (fun session_id task host -> PrintUpdateGuidance (get_avail_updates_uri ~session_id ~task ~host) ) From 397d47aacb55fc7eac292faac1f785e5e5872fa2 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Tue, 30 Jan 2024 11:09:26 +0800 Subject: [PATCH 32/39] Fixup: Don't change behaviour in download_file when filename is empty Signed-off-by: Ming Lu --- ocaml/xapi-cli-server/cli_operations.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index ccad3942e37..c01d5b2f152 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -5500,12 +5500,10 @@ let download_file rpc session_id task fd filename uri label = response := unmarshal fd done ; let ok = - match (!response, filename <> "") with - | Response OK, true -> + match !response with + | Response OK -> true - | Response OK, false -> - false - | Response Failed, _ -> + | Response Failed -> (* Need to check whether the thin cli managed to contact the server or not. If not, we need to mark the task as failed *) if Client.Task.get_progress ~rpc ~session_id ~self:task < 0.0 then @@ -5517,7 +5515,8 @@ let download_file rpc session_id task fd filename uri label = wait_for_task_complete rpc session_id task ; (* Check the server status -- even if the client thinks it's ok, we need to check that the server does too. *) - check_task_status ~rpc ~session_id ~task ~fd ~label ~ok () + let quiet_on_success = if filename = "" then true else false in + check_task_status ~rpc ~session_id ~task ~fd ~label ~ok ~quiet_on_success () let download_file_with_task fd rpc session_id filename uri query label task_name = From 6942a4bb8963e54cb3d94b13afad8f2928a5f8ac Mon Sep 17 00:00:00 2001 From: Gang Ji Date: Mon, 5 Feb 2024 14:42:40 +0800 Subject: [PATCH 33/39] CP-46946: Bumped API version to 2.21 for update guidance improvement So that the existing XenCenter will refuse to connect to the new XAPI. This aims to force users to use the new XenCenter since the old XenCenter can't work with the new XAPI with update guidance improvement. Signed-off-by: Gang Ji --- ocaml/idl/datamodel_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 6759defde86..00392141d76 100644 --- a/ocaml/idl/datamodel_common.ml +++ b/ocaml/idl/datamodel_common.ml @@ -151,7 +151,7 @@ let tech_preview_releases = * but there are exceptions: please consult the XenCenter maintainers if in doubt. *) let api_version_major = 2L -let api_version_minor = 20L +let api_version_minor = 21L let api_version_string = Printf.sprintf "%Ld.%Ld" api_version_major api_version_minor From c0c3c75828e407a7c09eb6ab8ff459f0e5b9edc8 Mon Sep 17 00:00:00 2001 From: Gang Ji <62988402+gangj@users.noreply.github.com> Date: Tue, 6 Feb 2024 18:10:08 +0800 Subject: [PATCH 34/39] CP-47012: change pending guidance in old xapi to recommended ones in new xapi Add livepatch guidance DB upgrade rule: except reboot_host_on_livepatch_failure, move any guidance in "host.pending_guidances" into "host.pending_guidances_recommended". Signed-off-by: Gang Ji --- ocaml/idl/datamodel_common.ml | 6 +++++- ocaml/xapi/xapi_db_upgrade.ml | 34 ++++++++++++++++++++++++++-------- 2 files changed, 31 insertions(+), 9 deletions(-) diff --git a/ocaml/idl/datamodel_common.ml b/ocaml/idl/datamodel_common.ml index 00392141d76..709cb5eb059 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 = 774 +let schema_minor_vsn = 775 (* Historical schema versions just in case this is useful later *) let rio_schema_major_vsn = 5 @@ -134,6 +134,10 @@ let yangtze_release_schema_major_vsn = 5 let yangtze_release_schema_minor_vsn = 602 +let nile_release_schema_major_vsn = 5 + +let nile_release_schema_minor_vsn = 775 + (* List of tech-preview releases. Fields in these releases are not guaranteed to be retained when * upgrading to a full release. *) let tech_preview_releases = diff --git a/ocaml/xapi/xapi_db_upgrade.ml b/ocaml/xapi/xapi_db_upgrade.ml index cf8bc3f4c3b..05f20f083e7 100644 --- a/ocaml/xapi/xapi_db_upgrade.ml +++ b/ocaml/xapi/xapi_db_upgrade.ml @@ -859,14 +859,25 @@ let empty_pool_uefi_certificates = ) } -let update_livepatch_guidance = +(* 1. Replace reboot_host_on_livepatch_failure in host.pending_guidances \ + * with reboot_host_on_kernel_livepatch_failure and \ + * reboot_host_on_xen_livepatch_failure in \ + * host.pending_guidances_recommended. + * 2. Move the rest guidances in \ + * host.pending_guidances into host.pending_guidances_recommended *) +let upgrade_update_guidance = { description= - "Replace reboot_host_on_livepatch_failure in host.pending_guidances with \ - reboot_host_on_kernel_livepatch_failure and \ - reboot_host_on_xen_livepatch_failure in \ - host.pending_guidances_recommended" - ; version= (fun _ -> true) + "Upgrade pending update gudiances" + (* TODO: update below schema version to which the feature branch got merged with *) + ; version= + (fun x -> + x + < ( Datamodel_common.nile_release_schema_major_vsn + , Datamodel_common.nile_release_schema_minor_vsn + ) + ) + (* the version where update guidance improvement is made *) ; fn= (fun ~__context -> Db.Host.get_all ~__context @@ -881,7 +892,14 @@ let update_livepatch_guidance = ~value:`reboot_host_on_xen_livepatch_failure ; Db.Host.remove_pending_guidances ~__context ~self ~value:`reboot_host_on_livepatch_failure - ) + ) ; + List.iter + (fun g -> + Db.Host.add_pending_guidances_recommended ~__context ~self + ~value:g + ) + (Db.Host.get_pending_guidances ~__context ~self) ; + Db.Host.set_pending_guidances ~__context ~self ~value:[] ) ) } @@ -914,7 +932,7 @@ let rules = ; upgrade_secrets ; remove_legacy_ssl_support ; empty_pool_uefi_certificates - ; update_livepatch_guidance + ; upgrade_update_guidance ] (* Maybe upgrade most recent db *) From 2065fdf6527f89c203ba425cb50f681cbba07231 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Wed, 7 Feb 2024 18:04:22 +0800 Subject: [PATCH 35/39] Update datamodel lifecycle for update guidance feature Signed-off-by: Ming Lu --- ocaml/idl/datamodel_lifecycle.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/ocaml/idl/datamodel_lifecycle.ml b/ocaml/idl/datamodel_lifecycle.ml index 11abd8f9c4b..28ff931ec59 100644 --- a/ocaml/idl/datamodel_lifecycle.ml +++ b/ocaml/idl/datamodel_lifecycle.ml @@ -39,6 +39,12 @@ let prototyped_of_field = function Some "22.26.0" | "VTPM", "persistence_backend" -> Some "22.26.0" + | "host", "last_update_hash" -> + Some "24.10.0" + | "host", "pending_guidances_full" -> + Some "24.10.0" + | "host", "pending_guidances_recommended" -> + Some "24.10.0" | "host", "numa_affinity_policy" -> Some "24.0.0" | "host", "latest_synced_updates_applied" -> @@ -49,6 +55,10 @@ let prototyped_of_field = function Some "22.27.0" | "host", "last_software_update" -> Some "22.20.0" + | "VM", "pending_guidances_full" -> + Some "24.10.0" + | "VM", "pending_guidances_recommended" -> + Some "24.10.0" | "VM", "recommended_guidances" -> Some "23.18.0" | "VM", "actions__after_softreboot" -> @@ -109,6 +119,8 @@ let prototyped_of_message = function Some "22.26.0" | "VTPM", "create" -> Some "22.26.0" + | "host", "emergency_clear_mandatory_guidance" -> + Some "24.10.0" | "host", "apply_recommended_guidances" -> Some "23.18.0" | "host", "set_https_only" -> From fc6fef570eb7dfffdf404d6c00f13d7974a21f9d Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Thu, 8 Feb 2024 10:58:06 +0800 Subject: [PATCH 36/39] Update last_known_schema_hash for feature branch Signed-off-by: Ming Lu --- ocaml/idl/schematest.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 9e716508844..8d0f62949ea 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 = "2de13a69470d10b12910322f8a6bce85" +let last_known_schema_hash = "e4a6f29203bc65b75e969b9d4570933e" let current_schema_hash : string = let open Datamodel_types in From db31d7d983c6b9b07dbc50fb83d840d60c431940 Mon Sep 17 00:00:00 2001 From: Ming Lu Date: Mon, 12 Feb 2024 11:29:25 +0800 Subject: [PATCH 37/39] CA-388699: No async support on VM.restart_device_models The default value of 'flags' is '[`Session; `Async]'. Explicit value '[`Session]' caused no async support on this API method. The fix is to use the default value. Signed-off-by: Ming Lu --- ocaml/idl/datamodel_vm.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index 826d7fb4683..c1a6b9a7d9c 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -1687,8 +1687,9 @@ let set_NVRAM_EFI_variables = ~hide_from_docs:true ~allowed_roles:_R_LOCAL_ROOT_ONLY () let restart_device_models = - call ~flags:[`Session] ~name:"restart_device_models" ~lifecycle:[] + call ~name:"restart_device_models" ~lifecycle:[] ~params:[(Ref _vm, "self", "The VM")] + ~doc:"Restart device models of the VM" ~errs: [ Api_errors.vm_bad_power_state From a0aece99c2af40f47a8a778f2f5a9ebe52b6dffb Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 14 Feb 2024 17:46:11 +0000 Subject: [PATCH 38/39] Add Nile release Signed-off-by: Rob Hoes --- ocaml/idl/datamodel_types.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/ocaml/idl/datamodel_types.ml b/ocaml/idl/datamodel_types.ml index 2feaf559c32..364eafb42db 100644 --- a/ocaml/idl/datamodel_types.ml +++ b/ocaml/idl/datamodel_types.ml @@ -97,6 +97,10 @@ let rel_stockholm = "stockholm" let rel_stockholm_psr = "stockholm_psr" +let rel_nile_preview = "nile-preview" + +let rel_nile = "nile" + type api_release = { code_name: string option ; version_major: int @@ -335,12 +339,19 @@ let release_order_full = ; release_date= Some "November 2020" } ; { - code_name= Some "nile-preview" + code_name= Some rel_nile_preview ; version_major= 2 ; version_minor= 20 ; branding= "XenServer 8 Preview" ; release_date= Some "August 2023" } + ; { + code_name= Some rel_nile + ; version_major= 2 + ; version_minor= 21 + ; branding= "XenServer 8" + ; release_date= None + } ] (* When you add a new release, use the version number of the latest release, "Unreleased" for the branding, and Some "" for the release date, until the actual values are finalised. *) From 2c2d3f63abd34eec8ad9e489d532d49a0cdc5cd9 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 14 Feb 2024 17:41:26 +0000 Subject: [PATCH 39/39] Update schematest Signed-off-by: Rob Hoes --- ocaml/idl/schematest.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/idl/schematest.ml b/ocaml/idl/schematest.ml index 8d0f62949ea..c8e5972c9a6 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 = "e4a6f29203bc65b75e969b9d4570933e" +let last_known_schema_hash = "186131ad48f40dff30246e8e0c0dbf0a" let current_schema_hash : string = let open Datamodel_types in