diff --git a/ocaml/database/db_cache_test.ml b/ocaml/database/db_cache_test.ml index 14222c5b4c7..e5aa40faf2c 100644 --- a/ocaml/database/db_cache_test.ml +++ b/ocaml/database/db_cache_test.ml @@ -26,9 +26,9 @@ let check_many_to_many () = (* make a bar with foos = [] *) (* add 'bar' to foo.bars *) let db = db - |> add_row "bar" "bar:1" (Row.add 0L Db_names.ref (Schema.Value.String "bar:1") (Row.add 0L "foos" (Schema.Value.Set []) Row.empty)) - |> add_row "foo" "foo:1" (Row.add 0L Db_names.ref (Schema.Value.String "foo:1") (Row.add 0L "bars" (Schema.Value.Set []) Row.empty)) - |> set_field "foo" "foo:1" "bars" (add_to_set "bar:1" (Schema.Value.Set [])) + |> add_row "bar" "bar:1" (Row.add 0L Db_names.ref (Schema.Value.String "bar:1") (Row.add 0L "foos" (Schema.Value.Set []) Row.empty)) + |> add_row "foo" "foo:1" (Row.add 0L Db_names.ref (Schema.Value.String "foo:1") (Row.add 0L "bars" (Schema.Value.Set []) Row.empty)) + |> set_field "foo" "foo:1" "bars" (add_to_set "bar:1" (Schema.Value.Set [])) in (* check that 'bar.foos' includes 'foo' *) let bar_1 = Table.find "bar:1" (TableSet.find "bar" (Database.tableset db)) in diff --git a/ocaml/database/db_cache_types.ml b/ocaml/database/db_cache_types.ml index 3f51dfd4071..d433a0c9e33 100644 --- a/ocaml/database/db_cache_types.ml +++ b/ocaml/database/db_cache_types.ml @@ -490,13 +490,13 @@ let remove_row tblname objref db = let g = db.Database.manifest.Manifest.generation_count in db |> Database.update_keymap (fun m -> - match uuid with - | Some u -> KeyMap.remove (Uuid u) m - | None -> m) + match uuid with + | Some u -> KeyMap.remove (Uuid u) m + | None -> m) |> Database.update_keymap (KeyMap.remove (Ref objref)) |> update_many_to_many g tblname objref remove_from_set (* Update foreign (Set(Ref _)) fields *) - (* NB this requires the original row to still exist *) + (* NB this requires the original row to still exist *) |> update_one_to_many g tblname objref remove_from_set |> ( Table.remove g objref diff --git a/ocaml/doc/jsapi.ml b/ocaml/doc/jsapi.ml index 72ceced64d6..9ca0ad7a927 100644 --- a/ocaml/doc/jsapi.ml +++ b/ocaml/doc/jsapi.ml @@ -27,9 +27,9 @@ let templdir = ref "" let parse_args () = Arg.parse [ - "-destdir", Arg.Set_string destdir, "the destination directory for the generated files"; - "-templdir", Arg.Set_string templdir, "the directory with the template (mustache) files"; - ] + "-destdir", Arg.Set_string destdir, "the destination directory for the generated files"; + "-templdir", Arg.Set_string templdir, "the directory with the template (mustache) files"; + ] (fun x-> Printf.printf "Ignoring anonymous argument %s" x) ("Generates documentation for the datamodel classes. See -help.") @@ -95,10 +95,10 @@ let generate_files api_dir = let json_releases = let json_of_rel x = `O [ - "code_name", `String (code_name_of_release x); - "version_major", `Float (float_of_int x.version_major); - "version_minor", `Float (float_of_int x.version_minor); - "branding", `String x.branding; + "code_name", `String (code_name_of_release x); + "version_major", `Float (float_of_int x.version_major); + "version_minor", `Float (float_of_int x.version_minor); + "branding", `String x.branding; ] in `O [ "releases", `A (List.map json_of_rel release_order) ] @@ -108,7 +108,7 @@ let render_template template_file json output_file = let rendered = Mustache.render templ json in let out_chan = open_out output_file in finally (fun () -> output_string out_chan rendered) - (fun () -> close_out out_chan) + (fun () -> close_out out_chan) let _ = diff --git a/ocaml/idl/datamodel.ml b/ocaml/idl/datamodel.ml index ff438df8bef..98f5bbd1d81 100644 --- a/ocaml/idl/datamodel.ml +++ b/ocaml/idl/datamodel.ml @@ -682,18 +682,18 @@ end module Host_metrics = struct -let host_metrics_memory = - let field = field ~ty:Int in - [ - field ~qualifier:DynamicRO "total" "Total host memory (bytes)" ~doc_tags:[Memory]; - field "free" "Free host memory (bytes)" - ~lifecycle: - [ Deprecated, rel_midnight_ride, "Will be disabled in favour of RRD" - ; Removed, rel_tampa, "Disabled in favour of RRD" - ] - ~qualifier:DynamicRO - ~doc_tags:[Memory]; - ] + let host_metrics_memory = + let field = field ~ty:Int in + [ + field ~qualifier:DynamicRO "total" "Total host memory (bytes)" ~doc_tags:[Memory]; + field "free" "Free host memory (bytes)" + ~lifecycle: + [ Deprecated, rel_midnight_ride, "Will be disabled in favour of RRD" + ; Removed, rel_tampa, "Disabled in favour of RRD" + ] + ~qualifier:DynamicRO + ~doc_tags:[Memory]; + ] let t = create_obj ~in_db:true ~in_product_since:rel_rio ~in_oss_since:oss_since_303 ~internal_deprecated_since:None ~persist:PersistEverything ~gen_constructor_destructor:false ~name:_host_metrics ~descr:"The metrics associated with a host" ~gen_events:true @@ -955,16 +955,16 @@ module PIF = struct () let set_disallow_unplug = call - ~name:"set_disallow_unplug" - ~doc:"Set whether unplugging the PIF is allowed" - ~hide_from_docs:false - ~in_oss_since:None - ~in_product_since:rel_orlando - ~params: [ Ref _pif, "self", "Reference to the object" - ; Bool, "value", "New value to set" ] - ~allowed_roles:_R_POOL_OP - ~errs:[Api_errors.clustering_enabled_on_network] - () + ~name:"set_disallow_unplug" + ~doc:"Set whether unplugging the PIF is allowed" + ~hide_from_docs:false + ~in_oss_since:None + ~in_product_since:rel_orlando + ~params: [ Ref _pif, "self", "Reference to the object" + ; Bool, "value", "New value to set" ] + ~allowed_roles:_R_POOL_OP + ~errs:[Api_errors.clustering_enabled_on_network] + () let ip_configuration_mode = Enum ("ip_configuration_mode", [ "None", "Do not acquire an IP address"; @@ -2864,16 +2864,16 @@ module VBD = struct () let set_mode = call - ~name:"set_mode" - ~in_product_since:rel_rio - ~doc:"Sets the mode of the VBD. The power_state of the VM must be halted." - ~params:[ - Ref _vbd, "self", "Reference to the object"; - mode, "value", "New value to set"; - ] - ~in_oss_since:None - ~allowed_roles:_R_VM_ADMIN - () + ~name:"set_mode" + ~in_product_since:rel_rio + ~doc:"Sets the mode of the VBD. The power_state of the VM must be halted." + ~params:[ + Ref _vbd, "self", "Reference to the object"; + mode, "value", "New value to set"; + ] + ~in_oss_since:None + ~allowed_roles:_R_VM_ADMIN + () (** A virtual disk interface *) let t = @@ -3250,7 +3250,7 @@ module VM_metrics = struct ; field ~lifecycle:[Published, rel_jura, ""] ~default_value:(Some (VEnum "unspecified")) ~ty:Datamodel_vm.domain_type ~qualifier:DynamicRO "current_domain_type" "The current domain type of the VM (for running,\ - suspended, or paused VMs). The last-known domain type for halted VMs." + suspended, or paused VMs). The last-known domain type for halted VMs." ] () end diff --git a/ocaml/idl/datamodel_cluster.ml b/ocaml/idl/datamodel_cluster.ml index a86939e9103..8490f1f3173 100644 --- a/ocaml/idl/datamodel_cluster.ml +++ b/ocaml/idl/datamodel_cluster.ml @@ -18,9 +18,9 @@ let cluster_operation = let lifecycle = [Prototyped, rel_kolkata, ""] let timeout_params = [ - {param_type=Float; param_name="token_timeout"; param_doc="Corosync token timeout in seconds"; param_release=kolkata_release; param_default=Some(VFloat Constants.default_token_timeout_s)}; - {param_type=Float; param_name="token_timeout_coefficient"; param_doc="Corosync token timeout coefficient in seconds"; param_release=kolkata_release; param_default=Some(VFloat Constants.default_token_timeout_coefficient_s)}; - ] + {param_type=Float; param_name="token_timeout"; param_doc="Corosync token timeout in seconds"; param_release=kolkata_release; param_default=Some(VFloat Constants.default_token_timeout_s)}; + {param_type=Float; param_name="token_timeout_coefficient"; param_doc="Corosync token timeout coefficient in seconds"; param_release=kolkata_release; param_default=Some(VFloat Constants.default_token_timeout_coefficient_s)}; +] let create = call @@ -28,10 +28,10 @@ let create = call ~doc:"Creates a Cluster object and one Cluster_host object as its first member" ~result:(Ref _cluster, "the new Cluster") ~versioned_params: - ([{param_type=Ref _network; param_name="network"; param_doc="the single network on which corosync carries out its inter-host communications"; param_release=kolkata_release; param_default=None}; - {param_type=String; param_name="cluster_stack"; param_doc="simply the string 'corosync'. No other cluster stacks are currently supported"; param_release=kolkata_release; param_default=None}; - {param_type=Bool; param_name="pool_auto_join"; param_doc="true if xapi is automatically joining new pool members to the cluster"; param_release=kolkata_release; param_default=None}; - ] @timeout_params) + ([{param_type=Ref _network; param_name="network"; param_doc="the single network on which corosync carries out its inter-host communications"; param_release=kolkata_release; param_default=None}; + {param_type=String; param_name="cluster_stack"; param_doc="simply the string 'corosync'. No other cluster stacks are currently supported"; param_release=kolkata_release; param_default=None}; + {param_type=Bool; param_name="pool_auto_join"; param_doc="true if xapi is automatically joining new pool members to the cluster"; param_release=kolkata_release; param_default=None}; + ] @timeout_params) ~lifecycle ~allowed_roles:_R_POOL_ADMIN () @@ -51,9 +51,9 @@ let pool_create = call ~doc:"Attempt to create a Cluster from the entire pool" ~result:(Ref _cluster, "the new Cluster") ~versioned_params: - ([{param_type=Ref _network; param_name="network"; param_doc="the single network on which corosync carries out its inter-host communications"; param_release=kolkata_release; param_default=None}; - {param_type=String; param_name="cluster_stack"; param_doc="simply the string 'corosync'. No other cluster stacks are currently supported"; param_release=kolkata_release; param_default=None}; - ] @ timeout_params) + ([{param_type=Ref _network; param_name="network"; param_doc="the single network on which corosync carries out its inter-host communications"; param_release=kolkata_release; param_default=None}; + {param_type=String; param_name="cluster_stack"; param_doc="simply the string 'corosync'. No other cluster stacks are currently supported"; param_release=kolkata_release; param_default=None}; + ] @ timeout_params) ~lifecycle ~allowed_roles:_R_POOL_ADMIN () @@ -79,12 +79,12 @@ let pool_destroy = call () let pool_resync = call - ~name:"pool_resync" - ~doc:"Resynchronise the cluster_host objects across the pool. Creates them where they need creating and then plugs them" - ~params:[ Ref _cluster, "self", "The cluster to resync"] - ~lifecycle - ~allowed_roles:_R_POOL_ADMIN - () + ~name:"pool_resync" + ~doc:"Resynchronise the cluster_host objects across the pool. Creates them where they need creating and then plugs them" + ~params:[ Ref _cluster, "self", "The cluster to resync"] + ~lifecycle + ~allowed_roles:_R_POOL_ADMIN + () let t = create_obj @@ -119,15 +119,15 @@ let t = ] @ (allowed_and_current_operations cluster_operation) @ [ - field ~qualifier:StaticRO ~lifecycle + field ~qualifier:StaticRO ~lifecycle ~ty:Bool "pool_auto_join" ~default_value:(Some (VBool true)) "True if xapi is automatically joining new pool members to the cluster. This will be `true` in the first release" - ; field ~qualifier:StaticRO ~lifecycle + ; field ~qualifier:StaticRO ~lifecycle ~ty:Int "token_timeout" ~default_value:(Some (VInt 20000L)) "The corosync token timeout in ms" - ; field ~qualifier:StaticRO ~lifecycle + ; field ~qualifier:StaticRO ~lifecycle ~ty:Int "token_timeout_coefficient" ~default_value:(Some (VInt 1000L)) "The corosync token timeout coefficient in ms" diff --git a/ocaml/idl/datamodel_cluster_host.ml b/ocaml/idl/datamodel_cluster_host.ml index 16589fbded4..ca9312b69d6 100644 --- a/ocaml/idl/datamodel_cluster_host.ml +++ b/ocaml/idl/datamodel_cluster_host.ml @@ -94,10 +94,10 @@ let t = (* TODO: add `live` member to represent whether corosync believes that this cluster host actually is enabled *) - + ] @ (allowed_and_current_operations cluster_host_operation) @ [ - field ~qualifier:StaticRO ~lifecycle + field ~qualifier:StaticRO ~lifecycle ~ty:(Map(String, String)) "other_config" ~default_value:(Some (VMap [])) "Additional configuration" ]) diff --git a/ocaml/idl/datamodel_host.ml b/ocaml/idl/datamodel_host.ml index ef129ef2351..2e1c67be502 100644 --- a/ocaml/idl/datamodel_host.ml +++ b/ocaml/idl/datamodel_host.ml @@ -20,110 +20,110 @@ let api_version = field' ~ty:(Map(String,String)) "vendor_implementation" "details of vendor implementation"; ] - let migrate_receive = call - ~in_oss_since:None - ~in_product_since:rel_tampa - ~name:"migrate_receive" - ~doc:"Prepare to receive a VM, returning a token which can be passed to VM.migrate." - ~params:[Ref _host, "host", "The target host"; - Ref _network, "network", "The network through which migration traffic should be received."; - Map(String, String), "options", "Extra configuration operations" ] - ~result:(Map(String,String), "A value which should be passed to VM.migrate") - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let ha_disable_failover_decisions = call - ~in_product_since:rel_orlando - ~name:"ha_disable_failover_decisions" - ~doc:"Prevents future failover decisions happening on this node. This function should only be used as part of a controlled shutdown of the HA system." - ~params:[Ref _host, "host", "The Host to disable failover decisions for"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let ha_disarm_fencing = call - ~in_product_since:rel_orlando - ~name:"ha_disarm_fencing" - ~doc:"Disarms the fencing function of the HA subsystem. This function is extremely dangerous and should only be used as part of a controlled shutdown of the HA system." - ~params:[Ref _host, "host", "The Host to disarm"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let ha_stop_daemon = call - ~in_product_since:rel_orlando - ~name:"ha_stop_daemon" - ~doc:"Stops the HA daemon. This function is extremely dangerous and should only be used as part of a controlled shutdown of the HA system." - ~params:[Ref _host, "host", "The Host whose daemon should be stopped"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let ha_release_resources = call - ~in_product_since:rel_orlando - ~name:"ha_release_resources" - ~doc:"Cleans up any resources on the host associated with this HA instance." - ~params:[Ref _host, "host", "The Host whose resources should be cleaned up"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let local_assert_healthy = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"local_assert_healthy" - ~doc:"Returns nothing if this host is healthy, otherwise it throws an error explaining why the host is unhealthy" - ~params:[] - ~pool_internal:true - ~hide_from_docs:true - ~errs:[ Api_errors.host_still_booting; - Api_errors.host_has_no_management_ip; - Api_errors.host_master_cannot_talk_back; - Api_errors.host_unknown_to_master; - Api_errors.host_broken; - Api_errors.license_restriction; - Api_errors.license_does_not_support_pooling; - Api_errors.ha_should_be_fenced; +let migrate_receive = call + ~in_oss_since:None + ~in_product_since:rel_tampa + ~name:"migrate_receive" + ~doc:"Prepare to receive a VM, returning a token which can be passed to VM.migrate." + ~params:[Ref _host, "host", "The target host"; + Ref _network, "network", "The network through which migration traffic should be received."; + Map(String, String), "options", "Extra configuration operations" ] + ~result:(Map(String,String), "A value which should be passed to VM.migrate") + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let ha_disable_failover_decisions = call + ~in_product_since:rel_orlando + ~name:"ha_disable_failover_decisions" + ~doc:"Prevents future failover decisions happening on this node. This function should only be used as part of a controlled shutdown of the HA system." + ~params:[Ref _host, "host", "The Host to disable failover decisions for"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let ha_disarm_fencing = call + ~in_product_since:rel_orlando + ~name:"ha_disarm_fencing" + ~doc:"Disarms the fencing function of the HA subsystem. This function is extremely dangerous and should only be used as part of a controlled shutdown of the HA system." + ~params:[Ref _host, "host", "The Host to disarm"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let ha_stop_daemon = call + ~in_product_since:rel_orlando + ~name:"ha_stop_daemon" + ~doc:"Stops the HA daemon. This function is extremely dangerous and should only be used as part of a controlled shutdown of the HA system." + ~params:[Ref _host, "host", "The Host whose daemon should be stopped"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let ha_release_resources = call + ~in_product_since:rel_orlando + ~name:"ha_release_resources" + ~doc:"Cleans up any resources on the host associated with this HA instance." + ~params:[Ref _host, "host", "The Host whose resources should be cleaned up"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let local_assert_healthy = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"local_assert_healthy" + ~doc:"Returns nothing if this host is healthy, otherwise it throws an error explaining why the host is unhealthy" + ~params:[] + ~pool_internal:true + ~hide_from_docs:true + ~errs:[ Api_errors.host_still_booting; + Api_errors.host_has_no_management_ip; + Api_errors.host_master_cannot_talk_back; + Api_errors.host_unknown_to_master; + Api_errors.host_broken; + Api_errors.license_restriction; + Api_errors.license_does_not_support_pooling; + Api_errors.ha_should_be_fenced; + ] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let preconfigure_ha = call + ~in_product_since:rel_miami + ~name:"preconfigure_ha" + ~doc:"Attach statefiles, generate config files but do not start the xHA daemon." + ~params:[Ref _host, "host", "The Host to modify"; + Set(Ref _vdi), "statefiles", "Set of statefile VDIs to use"; + Ref _vdi, "metadata_vdi", "VDI to use for Pool metadata"; + String, "generation", "UUID identifying this HA instance"; ] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let preconfigure_ha = call - ~in_product_since:rel_miami - ~name:"preconfigure_ha" - ~doc:"Attach statefiles, generate config files but do not start the xHA daemon." - ~params:[Ref _host, "host", "The Host to modify"; - Set(Ref _vdi), "statefiles", "Set of statefile VDIs to use"; - Ref _vdi, "metadata_vdi", "VDI to use for Pool metadata"; - String, "generation", "UUID identifying this HA instance"; - ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let ha_join_liveset = call - ~in_product_since:rel_orlando - ~name:"ha_join_liveset" - ~doc:"Block until this host joins the liveset." - ~params:[Ref _host, "host", "The Host whose HA daemon to start"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let ha_wait_for_shutdown_via_statefile = call - ~in_product_since:rel_orlando - ~name:"ha_wait_for_shutdown_via_statefile" - ~doc:"Block until this host xHA daemon exits after having seen the invalid statefile. If the host loses statefile access then throw an exception" - ~params:[Ref _host, "host", "The Host whose HA subsystem to query"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let ha_join_liveset = call + ~in_product_since:rel_orlando + ~name:"ha_join_liveset" + ~doc:"Block until this host joins the liveset." + ~params:[Ref _host, "host", "The Host whose HA daemon to start"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let ha_wait_for_shutdown_via_statefile = call + ~in_product_since:rel_orlando + ~name:"ha_wait_for_shutdown_via_statefile" + ~doc:"Block until this host xHA daemon exits after having seen the invalid statefile. If the host loses statefile access then throw an exception" + ~params:[Ref _host, "host", "The Host whose HA subsystem to query"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () (* let host_query_ha = call ~flags:[`Session] ~in_product_since:rel_miami @@ -135,285 +135,285 @@ let host_query_ha = call ~flags:[`Session] ~hide_from_docs:true () *) - let request_backup = call ~flags:[`Session] - ~name:"request_backup" - ~in_product_since:rel_rio - ~doc:"Request this host performs a database backup" - ~params:[Ref _host, "host", "The Host to send the request to"; - Int, "generation", "The generation count of the master's database"; - Bool, "force", "If this is true then the client _has_ to take a backup, otherwise it's just an 'offer'" - ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let request_config_file_sync = call ~flags:[`Session] - ~name:"request_config_file_sync" - ~in_product_since:rel_rio - ~doc:"Request this host syncs dom0 config files" - ~params:[Ref _host, "host", "The Host to send the request to"; - String, "hash", "The hash of the master's dom0 config files package" - ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - - (* Since there are no async versions, no tasks are generated (!) this is important - otherwise the call would block doing a Db.Task.create *) - let propose_new_master = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"propose_new_master" - ~doc:"First phase of a two-phase commit protocol to set the new master. If the host has already committed to another configuration or if the proposed new master is not in this node's membership set then the call will return an exception." - ~params:[String, "address", "The address of the Host which is proposed as the new master"; - Bool, "manual", "True if this call is being invoked by the user manually, false if automatic"; - ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let abort_new_master = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"abort_new_master" - ~doc:"Causes the new master transaction to abort" - ~params:[String, "address", "The address of the Host which is proposed as the new master"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let commit_new_master = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"commit_new_master" - ~doc:"Second phase of a two-phase commit protocol to set the new master." - ~params:[String, "address", "The address of the Host which should be committed as the new master"] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let compute_free_memory = call - ~in_product_since:rel_orlando - ~name:"compute_free_memory" - ~doc:"Computes the amount of free memory on the host." - ~params:[Ref _host, "host", "The host to send the request to"] - ~pool_internal:false - ~hide_from_docs:false - ~result:(Int, "the amount of free memory on the host.") - ~allowed_roles:_R_READ_ONLY - ~doc_tags:[Memory] - () - - let compute_memory_overhead = call - ~in_product_since:rel_midnight_ride - ~name:"compute_memory_overhead" - ~doc:"Computes the virtualization memory overhead of a host." - ~params:[Ref _host, "host", "The host for which to compute the memory overhead"] - ~pool_internal:false - ~hide_from_docs:false - ~result:(Int, "the virtualization memory overhead of the host.") - ~allowed_roles:_R_READ_ONLY - ~doc_tags:[Memory] - () - - (* Diagnostics see if host is in emergency mode *) - let is_in_emergency_mode = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"is_in_emergency_mode" - ~doc:"Diagnostics call to discover if host is in emergency mode" - ~params:[] - ~pool_internal:false - ~hide_from_docs:true - ~result:(Bool, "true if host is in emergency mode") - ~allowed_roles:_R_READ_ONLY - () - - (* Signal that the management IP address or hostname has been changed beneath us. *) - let signal_networking_change = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"signal_networking_change" - ~doc:"Signals that the management IP address or hostname has been changed beneath us." - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - ~doc_tags:[Networking] - () - - let notify = call - ~in_product_since:rel_miami - ~name:"notify" - ~doc:"Notify an event" - ~params:[String, "ty", "type of the notification"; - String, "params", "arguments of the notification (can be empty)"; ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let syslog_reconfigure = call - ~in_product_since:rel_miami - ~name:"syslog_reconfigure" - ~doc:"Re-configure syslog logging" - ~params:[Ref _host, "host", "Tell the host to reread its Host.logging parameters and reconfigure itself accordingly"] - ~allowed_roles:_R_POOL_OP - () - - let management_reconfigure = call - ~in_product_since:rel_miami - ~name:"management_reconfigure" - ~doc:"Reconfigure the management network interface" - ~params:[ - Ref _pif, "pif", "reference to a PIF object corresponding to the management interface"; - ] - ~allowed_roles:_R_POOL_OP - ~doc_tags:[Networking] - () - - let local_management_reconfigure = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"local_management_reconfigure" - ~doc:"Reconfigure the management network interface. Should only be used if Host.management_reconfigure is impossible because the network configuration is broken." - ~params:[ - String, "interface", "name of the interface to use as a management interface"; - ] - ~allowed_roles:_R_POOL_OP - () - - let ha_xapi_healthcheck = call ~flags:[`Session] - ~in_product_since:rel_orlando - ~name:"ha_xapi_healthcheck" - ~doc:"Returns true if xapi appears to be functioning normally." - ~result:(Bool, "true if xapi is functioning normally.") - ~hide_from_docs:true - ~allowed_roles:_R_POOL_ADMIN - () - - let management_disable = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"management_disable" - ~doc:"Disable the management network interface" - ~params:[] - ~allowed_roles:_R_POOL_OP - ~doc_tags:[Networking] - () - - let get_management_interface = call - ~lifecycle:[Prototyped, rel_tampa, ""] - ~name:"get_management_interface" - ~doc:"Returns the management interface for the specified host" - ~params:[Ref _host, "host", "Which host's management interface is required"] - ~result:(Ref _pif, "The management interface for the host") - ~allowed_roles:_R_POOL_OP - ~doc_tags:[Networking] - () - - (* Simple host evacuate message for Miami. - Not intended for HA *) - - let assert_can_evacuate = call - ~in_product_since:rel_miami - ~name:"assert_can_evacuate" - ~doc:"Check this host can be evacuated." - ~params:[Ref _host, "host", "The host to evacuate"] - ~allowed_roles:_R_POOL_OP - () - - (* New Orlando message which aims to make the GUI less brittle (unexpected errors will trigger a VM suspend) - and sensitive to HA planning constraints *) - let get_vms_which_prevent_evacuation = call - ~in_product_since:rel_orlando - ~name:"get_vms_which_prevent_evacuation" - ~doc:"Return a set of VMs which prevent the host being evacuated, with per-VM error codes" - ~params:[Ref _host, "self", "The host to query"] - ~result:(Map(Ref _vm, Set(String)), "VMs which block evacuation together with reasons") - ~allowed_roles:_R_READ_ONLY - () - - let evacuate = call - ~in_product_since:rel_miami - ~name:"evacuate" - ~doc:"Migrate all VMs off of this host, where possible." - ~params:[Ref _host, "host", "The host to evacuate"] - ~allowed_roles:_R_POOL_OP - () - - let get_uncooperative_resident_VMs = call - ~in_product_since:rel_midnight_ride - ~internal_deprecated_since:rel_tampa - ~name:"get_uncooperative_resident_VMs" - ~doc:"Return a set of VMs which are not co-operating with the host's memory control system" - ~params:[Ref _host, "self", "The host to query"] - ~result:((Set(Ref _vm)), "VMs which are not co-operating") - ~allowed_roles:_R_READ_ONLY - () - - let get_uncooperative_domains = call - ~in_product_since:rel_midnight_ride - ~internal_deprecated_since:rel_tampa - ~name:"get_uncooperative_domains" - ~doc:"Return the set of domain uuids which are not co-operating with the host's memory control system" - ~params:[Ref _host, "self", "The host to query"] - ~result:((Set(String)), "UUIDs of domains which are not co-operating") - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let retrieve_wlb_evacuate_recommendations = call - ~name:"retrieve_wlb_evacuate_recommendations" - ~in_product_since:rel_george - ~doc:"Retrieves recommended host migrations to perform when evacuating the host from the wlb server. If a VM cannot be migrated from the host the reason is listed instead of a recommendation." - ~params:[Ref _host, "self", "The host to query"] - ~result:(Map(Ref _vm, Set(String)), "VMs and the reasons why they would block evacuation, or their target host recommended by the wlb server") - ~allowed_roles:_R_READ_ONLY - () - - (* Host.Disable *) - - let disable = call - ~in_product_since:rel_rio - ~name:"disable" - ~doc:"Puts the host into a state in which no new VMs can be started. Currently active VMs on the host continue to execute." - ~params:[Ref _host, "host", "The Host to disable"] - ~allowed_roles:_R_POOL_OP - () - - (* Host.Enable *) - - let enable = call - ~name:"enable" - ~in_product_since:rel_rio - ~doc:"Puts the host into a state in which new VMs can be started." - ~params:[Ref _host, "host", "The Host to enable"] - ~allowed_roles:_R_POOL_OP - () - - (* Host.Shutdown *) - - let shutdown = call - ~name:"shutdown" - ~in_product_since:rel_rio - ~doc:"Shutdown the host. (This function can only be called if there are no currently running VMs on the host and it is disabled.)" - ~params:[Ref _host, "host", "The Host to shutdown"] - ~allowed_roles:_R_POOL_OP - () - - (* Host.reboot *) - - let reboot = call - ~name:"reboot" - ~in_product_since:rel_rio - ~doc:"Reboot the host. (This function can only be called if there are no currently running VMs on the host and it is disabled.)" - ~params:[Ref _host, "host", "The Host to reboot"] - ~allowed_roles:_R_POOL_OP - () - - (* Host.prepare_for_poweroff *) - - let prepare_for_poweroff = call +let request_backup = call ~flags:[`Session] + ~name:"request_backup" + ~in_product_since:rel_rio + ~doc:"Request this host performs a database backup" + ~params:[Ref _host, "host", "The Host to send the request to"; + Int, "generation", "The generation count of the master's database"; + Bool, "force", "If this is true then the client _has_ to take a backup, otherwise it's just an 'offer'" + ] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let request_config_file_sync = call ~flags:[`Session] + ~name:"request_config_file_sync" + ~in_product_since:rel_rio + ~doc:"Request this host syncs dom0 config files" + ~params:[Ref _host, "host", "The Host to send the request to"; + String, "hash", "The hash of the master's dom0 config files package" + ] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + + +(* Since there are no async versions, no tasks are generated (!) this is important + otherwise the call would block doing a Db.Task.create *) +let propose_new_master = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"propose_new_master" + ~doc:"First phase of a two-phase commit protocol to set the new master. If the host has already committed to another configuration or if the proposed new master is not in this node's membership set then the call will return an exception." + ~params:[String, "address", "The address of the Host which is proposed as the new master"; + Bool, "manual", "True if this call is being invoked by the user manually, false if automatic"; + ] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let abort_new_master = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"abort_new_master" + ~doc:"Causes the new master transaction to abort" + ~params:[String, "address", "The address of the Host which is proposed as the new master"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let commit_new_master = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"commit_new_master" + ~doc:"Second phase of a two-phase commit protocol to set the new master." + ~params:[String, "address", "The address of the Host which should be committed as the new master"] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let compute_free_memory = call + ~in_product_since:rel_orlando + ~name:"compute_free_memory" + ~doc:"Computes the amount of free memory on the host." + ~params:[Ref _host, "host", "The host to send the request to"] + ~pool_internal:false + ~hide_from_docs:false + ~result:(Int, "the amount of free memory on the host.") + ~allowed_roles:_R_READ_ONLY + ~doc_tags:[Memory] + () + +let compute_memory_overhead = call + ~in_product_since:rel_midnight_ride + ~name:"compute_memory_overhead" + ~doc:"Computes the virtualization memory overhead of a host." + ~params:[Ref _host, "host", "The host for which to compute the memory overhead"] + ~pool_internal:false + ~hide_from_docs:false + ~result:(Int, "the virtualization memory overhead of the host.") + ~allowed_roles:_R_READ_ONLY + ~doc_tags:[Memory] + () + +(* Diagnostics see if host is in emergency mode *) +let is_in_emergency_mode = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"is_in_emergency_mode" + ~doc:"Diagnostics call to discover if host is in emergency mode" + ~params:[] + ~pool_internal:false + ~hide_from_docs:true + ~result:(Bool, "true if host is in emergency mode") + ~allowed_roles:_R_READ_ONLY + () + +(* Signal that the management IP address or hostname has been changed beneath us. *) +let signal_networking_change = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"signal_networking_change" + ~doc:"Signals that the management IP address or hostname has been changed beneath us." + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + ~doc_tags:[Networking] + () + +let notify = call + ~in_product_since:rel_miami + ~name:"notify" + ~doc:"Notify an event" + ~params:[String, "ty", "type of the notification"; + String, "params", "arguments of the notification (can be empty)"; ] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let syslog_reconfigure = call + ~in_product_since:rel_miami + ~name:"syslog_reconfigure" + ~doc:"Re-configure syslog logging" + ~params:[Ref _host, "host", "Tell the host to reread its Host.logging parameters and reconfigure itself accordingly"] + ~allowed_roles:_R_POOL_OP + () + +let management_reconfigure = call + ~in_product_since:rel_miami + ~name:"management_reconfigure" + ~doc:"Reconfigure the management network interface" + ~params:[ + Ref _pif, "pif", "reference to a PIF object corresponding to the management interface"; + ] + ~allowed_roles:_R_POOL_OP + ~doc_tags:[Networking] + () + +let local_management_reconfigure = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"local_management_reconfigure" + ~doc:"Reconfigure the management network interface. Should only be used if Host.management_reconfigure is impossible because the network configuration is broken." + ~params:[ + String, "interface", "name of the interface to use as a management interface"; + ] + ~allowed_roles:_R_POOL_OP + () + +let ha_xapi_healthcheck = call ~flags:[`Session] + ~in_product_since:rel_orlando + ~name:"ha_xapi_healthcheck" + ~doc:"Returns true if xapi appears to be functioning normally." + ~result:(Bool, "true if xapi is functioning normally.") + ~hide_from_docs:true + ~allowed_roles:_R_POOL_ADMIN + () + +let management_disable = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"management_disable" + ~doc:"Disable the management network interface" + ~params:[] + ~allowed_roles:_R_POOL_OP + ~doc_tags:[Networking] + () + +let get_management_interface = call + ~lifecycle:[Prototyped, rel_tampa, ""] + ~name:"get_management_interface" + ~doc:"Returns the management interface for the specified host" + ~params:[Ref _host, "host", "Which host's management interface is required"] + ~result:(Ref _pif, "The management interface for the host") + ~allowed_roles:_R_POOL_OP + ~doc_tags:[Networking] + () + +(* Simple host evacuate message for Miami. + Not intended for HA *) + +let assert_can_evacuate = call + ~in_product_since:rel_miami + ~name:"assert_can_evacuate" + ~doc:"Check this host can be evacuated." + ~params:[Ref _host, "host", "The host to evacuate"] + ~allowed_roles:_R_POOL_OP + () + +(* New Orlando message which aims to make the GUI less brittle (unexpected errors will trigger a VM suspend) + and sensitive to HA planning constraints *) +let get_vms_which_prevent_evacuation = call + ~in_product_since:rel_orlando + ~name:"get_vms_which_prevent_evacuation" + ~doc:"Return a set of VMs which prevent the host being evacuated, with per-VM error codes" + ~params:[Ref _host, "self", "The host to query"] + ~result:(Map(Ref _vm, Set(String)), "VMs which block evacuation together with reasons") + ~allowed_roles:_R_READ_ONLY + () + +let evacuate = call + ~in_product_since:rel_miami + ~name:"evacuate" + ~doc:"Migrate all VMs off of this host, where possible." + ~params:[Ref _host, "host", "The host to evacuate"] + ~allowed_roles:_R_POOL_OP + () + +let get_uncooperative_resident_VMs = call + ~in_product_since:rel_midnight_ride + ~internal_deprecated_since:rel_tampa + ~name:"get_uncooperative_resident_VMs" + ~doc:"Return a set of VMs which are not co-operating with the host's memory control system" + ~params:[Ref _host, "self", "The host to query"] + ~result:((Set(Ref _vm)), "VMs which are not co-operating") + ~allowed_roles:_R_READ_ONLY + () + +let get_uncooperative_domains = call + ~in_product_since:rel_midnight_ride + ~internal_deprecated_since:rel_tampa + ~name:"get_uncooperative_domains" + ~doc:"Return the set of domain uuids which are not co-operating with the host's memory control system" + ~params:[Ref _host, "self", "The host to query"] + ~result:((Set(String)), "UUIDs of domains which are not co-operating") + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let retrieve_wlb_evacuate_recommendations = call + ~name:"retrieve_wlb_evacuate_recommendations" + ~in_product_since:rel_george + ~doc:"Retrieves recommended host migrations to perform when evacuating the host from the wlb server. If a VM cannot be migrated from the host the reason is listed instead of a recommendation." + ~params:[Ref _host, "self", "The host to query"] + ~result:(Map(Ref _vm, Set(String)), "VMs and the reasons why they would block evacuation, or their target host recommended by the wlb server") + ~allowed_roles:_R_READ_ONLY + () + +(* Host.Disable *) + +let disable = call + ~in_product_since:rel_rio + ~name:"disable" + ~doc:"Puts the host into a state in which no new VMs can be started. Currently active VMs on the host continue to execute." + ~params:[Ref _host, "host", "The Host to disable"] + ~allowed_roles:_R_POOL_OP + () + +(* Host.Enable *) + +let enable = call + ~name:"enable" + ~in_product_since:rel_rio + ~doc:"Puts the host into a state in which new VMs can be started." + ~params:[Ref _host, "host", "The Host to enable"] + ~allowed_roles:_R_POOL_OP + () + +(* Host.Shutdown *) + +let shutdown = call + ~name:"shutdown" + ~in_product_since:rel_rio + ~doc:"Shutdown the host. (This function can only be called if there are no currently running VMs on the host and it is disabled.)" + ~params:[Ref _host, "host", "The Host to shutdown"] + ~allowed_roles:_R_POOL_OP + () + +(* Host.reboot *) + +let reboot = call + ~name:"reboot" + ~in_product_since:rel_rio + ~doc:"Reboot the host. (This function can only be called if there are no currently running VMs on the host and it is disabled.)" + ~params:[Ref _host, "host", "The Host to reboot"] + ~allowed_roles:_R_POOL_OP + () + +(* Host.prepare_for_poweroff *) + +let prepare_for_poweroff = call ~name:"prepare_for_poweroff" ~in_product_since:rel_kolkata ~doc:"Performs the necessary actions before host shutdown or reboot." @@ -422,831 +422,831 @@ let host_query_ha = call ~flags:[`Session] ~hide_from_docs:true () - (* Host.power_on *) - - let power_on = call - ~name:"power_on" - ~in_product_since:rel_orlando - ~doc:"Attempt to power-on the host (if the capability exists)." - ~params:[Ref _host, "host", "The Host to power on"] - ~allowed_roles:_R_POOL_OP - () - - let restart_agent = call - ~name:"restart_agent" - ~in_product_since:rel_rio - ~doc:"Restarts the agent after a 10 second pause. WARNING: this is a dangerous operation. Any operations in progress will be aborted, and unrecoverable data loss may occur. The caller is responsible for ensuring that there are no operations in progress when this method is called." - ~params:[Ref _host, "host", "The Host on which you want to restart the agent"] - ~allowed_roles:_R_POOL_OP - () - - let shutdown_agent = call - ~name:"shutdown_agent" - ~in_product_since:rel_orlando - ~doc:"Shuts the agent down after a 10 second pause. WARNING: this is a dangerous operation. Any operations in progress will be aborted, and unrecoverable data loss may occur. The caller is responsible for ensuring that there are no operations in progress when this method is called." - ~params:[] - ~flags:[`Session] (* no async *) - ~allowed_roles:_R_POOL_OP - () - - let dmesg = call - ~name:"dmesg" - ~in_product_since:rel_rio - ~doc:"Get the host xen dmesg." - ~params:[Ref _host, "host", "The Host to query"] - ~result:(String, "dmesg string") - ~allowed_roles:_R_POOL_OP - () - - let dmesg_clear = call - ~name:"dmesg_clear" - ~in_product_since:rel_rio - ~doc:"Get the host xen dmesg, and clear the buffer." - ~params:[Ref _host, "host", "The Host to query"] - ~result:(String, "dmesg string") - ~allowed_roles:_R_POOL_OP - () - - let get_log = call - ~name:"get_log" - ~in_product_since:rel_rio - ~doc:"Get the host's log file" - ~params:[Ref _host, "host", "The Host to query"] - ~result:(String, "The contents of the host's primary log file") - ~allowed_roles:_R_READ_ONLY - () - - let send_debug_keys = call - ~name:"send_debug_keys" - ~in_product_since:rel_rio - ~doc:"Inject the given string as debugging keys into Xen" - ~params:[Ref _host, "host", "The host"; - String, "keys", "The keys to send"] - ~allowed_roles:_R_POOL_ADMIN - () - - let get_data_sources = call - ~name:"get_data_sources" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"" - ~result:(Set (Record _data_source), "A set of data sources") - ~params:[Ref _host, "host", "The host to interrogate"] - ~errs:[] - ~flags:[`Session] - ~allowed_roles:_R_READ_ONLY - () - - let record_data_source = call - ~name:"record_data_source" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Start recording the specified data source" - ~params:[Ref _host, "host", "The host"; - String, "data_source", "The data source to record"] - ~errs:[] - ~flags:[`Session] - ~allowed_roles:_R_POOL_OP - () - - let query_data_source = call - ~name:"query_data_source" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Query the latest value of the specified data source" - ~params:[Ref _host, "host", "The host"; - String, "data_source", "The data source to query"] - ~result:(Float,"The latest value, averaged over the last 5 seconds") - ~errs:[] - ~flags:[`Session] - ~allowed_roles:_R_READ_ONLY - () - - let attach_static_vdis = call - ~name:"attach_static_vdis" - ~in_product_since:rel_midnight_ride - ~doc:"Statically attach VDIs on a host." - ~params:[Ref _host, "host", "The Host to modify"; - Map(Ref _vdi, String), "vdi_reason_map", "List of VDI+reason pairs to attach" - ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let detach_static_vdis = call - ~name:"detach_static_vdis" - ~in_product_since:rel_midnight_ride - ~doc:"Detach static VDIs from a host." - ~params:[Ref _host, "host", "The Host to modify"; - Set(Ref _vdi), "vdis", "Set of VDIs to detach"; - ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let declare_dead = call - ~name:"declare_dead" - ~in_product_since:rel_clearwater - ~doc:"Declare that a host is dead. This is a dangerous operation, and should only be called if the administrator is absolutely sure the host is definitely dead" - ~params:[Ref _host, "host", "The Host to declare is dead"] - ~allowed_roles:_R_POOL_OP - () - - let forget_data_source_archives = call - ~name:"forget_data_source_archives" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Forget the recorded statistics related to the specified data source" - ~params:[Ref _host, "host", "The host"; - String, "data_source", "The data source whose archives are to be forgotten"] - ~flags:[`Session] - ~allowed_roles:_R_POOL_OP - () - - let get_diagnostic_timing_stats = call ~flags:[`Session] - ~in_product_since:rel_miami - ~name:"get_diagnostic_timing_stats" - ~doc:"Return timing statistics for diagnostic purposes" - ~params:[Ref _host, "host", "The host to interrogate"] - ~result:(Map(String, String), "population name to summary map") - ~hide_from_docs:true - ~allowed_roles:_R_READ_ONLY - () - - let create_new_blob = call - ~name: "create_new_blob" - ~in_product_since:rel_orlando - ~doc:"Create a placeholder for a named binary blob of data that is associated with this host" - ~versioned_params: - [{param_type=Ref _host; param_name="host"; param_doc="The host"; param_release=orlando_release; param_default=None}; - {param_type=String; param_name="name"; param_doc="The name associated with the blob"; param_release=orlando_release; param_default=None}; - {param_type=String; param_name="mime_type"; param_doc="The mime type for the data. Empty string translates to application/octet-stream"; param_release=orlando_release; param_default=None}; - {param_type=Bool; param_name="public"; param_doc="True if the blob should be publicly available"; param_release=tampa_release; param_default=Some (VBool false)}] - ~result:(Ref _blob, "The reference of the blob, needed for populating its data") - ~allowed_roles:_R_POOL_OP - () - - let call_plugin = call - ~name:"call_plugin" - ~in_product_since:rel_orlando - ~doc:"Call a XenAPI plugin on this host" - ~params:[Ref _host, "host", "The host"; - String, "plugin", "The name of the plugin"; - String, "fn", "The name of the function within the plugin"; - Map(String, String), "args", "Arguments for the function";] - ~result:(String, "Result from the plugin") - ~allowed_roles:_R_POOL_ADMIN - () - - let has_extension = call - ~name:"has_extension" - ~in_product_since:rel_ely - ~doc:"Return true if the extension is available on the host" - ~params:[Ref _host, "host", "The host"; - String, "name", "The name of the API call";] - ~result:(Bool, "True if the extension exists, false otherwise") - ~allowed_roles:_R_POOL_ADMIN - () - - let call_extension = call - ~name:"call_extension" - ~in_product_since:rel_ely - ~custom_marshaller:true - ~doc:"Call a XenAPI extension on this host" - ~params:[Ref _host, "host", "The host"; - String, "call", "Rpc call for the extension";] - ~result:(String, "Result from the extension") - ~allowed_roles:_R_POOL_ADMIN - ~flags:[`Session] (* no async *) - () - - let enable_binary_storage = call - ~name:"enable_binary_storage" - ~in_product_since:rel_orlando - ~hide_from_docs:true - ~pool_internal:true - ~doc:"Enable binary storage on a particular host, for storing RRDs, messages and blobs" - ~params:[Ref _host, "host", "The host"] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let disable_binary_storage = call - ~name:"disable_binary_storage" - ~in_product_since:rel_orlando - ~hide_from_docs:true - ~pool_internal:true - ~doc:"Disable binary storage on a particular host, deleting stored RRDs, messages and blobs" - ~params:[Ref _host, "host", "The host"] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let update_pool_secret = call - ~name:"update_pool_secret" - ~in_product_since:rel_midnight_ride - ~hide_from_docs:true - ~pool_internal:true - ~doc:"" - ~params:[ - Ref _host, "host", "The host"; - String, "pool_secret", "The new pool secret" ] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let update_master = call - ~name:"update_master" - ~in_product_since:rel_midnight_ride - ~hide_from_docs:true - ~pool_internal:true - ~doc:"" - ~params:[ - Ref _host, "host", "The host"; - String, "master_address", "The new master address" ] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let set_localdb_key = call - ~name:"set_localdb_key" - ~in_product_since:rel_midnight_ride - ~doc:"Set a key in the local DB of the host." - ~params:[Ref _host, "host", "The Host to modify"; - String, "key", "Key to change"; - String, "value", "Value to set" - ] - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let refresh_pack_info = call - ~name:"refresh_pack_info" - ~doc:"Refresh the list of installed Supplemental Packs." - ~params:[Ref _host, "host", "The Host to modify"] - ~allowed_roles:_R_POOL_OP - ~lifecycle:[Published, rel_midnight_ride, ""; - Deprecated, rel_ely, "Use Pool_update.resync_host instead"] - () - - let bugreport_upload = call - ~name:"bugreport_upload" - ~doc:"Run xen-bugtool --yestoall and upload the output to support" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[ Ref _host, "host", "The host on which to run xen-bugtool"; - String, "url", "The URL to upload to"; - Map(String, String), "options", "Extra configuration operations" ] - ~allowed_roles:_R_POOL_OP - () - - let list_methods = call - ~name:"list_methods" - ~in_product_since:rel_rio - ~flags: [`Session] - ~doc:"List all supported methods" - ~params:[] - ~result:(Set(String), "The name of every supported method.") - ~allowed_roles:_R_READ_ONLY - () - - let license_apply = call - ~name:"license_apply" - ~in_oss_since:None - ~lifecycle:[ - Published, rel_rio, "Apply a new license to a host"; - Removed, rel_clearwater, "Free licenses no longer handled by xapi"; - ] - ~params:[Ref _host, "host", "The host to upload the license to"; - String, "contents", "The contents of the license file, base64 encoded"] - ~doc:"Apply a new license to a host" - ~errs: [Api_errors.license_processing_error] - ~allowed_roles:_R_POOL_OP - () - - let license_add = call - ~name:"license_add" - ~in_oss_since:None - ~lifecycle:[ - Published, rel_indigo, "Functionality for parsing license files re-added"; - ] - ~params:[Ref _host, "host", "The host to upload the license to"; - String, "contents", "The contents of the license file, base64 encoded"] - ~doc:"Apply a new license to a host" - ~errs: [Api_errors.license_processing_error] - ~allowed_roles:_R_POOL_OP - () - - let license_remove = call - ~name:"license_remove" - ~in_oss_since:None - ~lifecycle:[ - Published, rel_indigo, ""; - ] - ~params:[ - Ref _host, "host", "The host from which any license will be removed" - ] - ~doc:"Remove any license file from the specified host, and switch that host to the unlicensed edition" - ~allowed_roles:_R_POOL_OP - () - - let create_params = - [ - {param_type=String; param_name="uuid"; param_doc="unique identifier/object reference"; param_release=rio_release; param_default=None}; - {param_type=String; param_name="name_label"; param_doc="The name of the new storage repository"; param_release=rio_release; param_default=None}; - {param_type=String; param_name="name_description"; param_doc="The description of the new storage repository"; param_release=rio_release; param_default=None}; - {param_type=String; param_name="hostname"; param_doc="Hostname"; param_release=rio_release; param_default=None}; - {param_type=String; param_name="address"; param_doc="An address by which this host can be contacted by other members in its pool"; param_release=rio_release; param_default=None}; - {param_type=String; param_name="external_auth_type"; param_doc="type of external authentication service configured; empty if none configured"; param_release=george_release; param_default=Some(VString "")}; - {param_type=String; param_name="external_auth_service_name"; param_doc="name of external authentication service configured; empty if none configured"; param_release=george_release; param_default=Some(VString "")}; - {param_type=Map(String,String); param_name="external_auth_configuration"; param_doc="configuration specific to external authentication service"; param_release=george_release; param_default=Some(VMap [])}; - {param_type=Map(String,String); param_name="license_params"; param_doc="State of the current license"; param_release=midnight_ride_release; param_default=Some(VMap [])}; - {param_type=String; param_name="edition"; param_doc="Product edition"; param_release=midnight_ride_release; param_default=Some(VString "")}; - {param_type=Map(String,String); param_name="license_server"; param_doc="Contact information of the license server"; param_release=midnight_ride_release; param_default=Some(VMap [VString "address", VString "localhost"; VString "port", VString "27000"])}; - {param_type=Ref _sr; param_name="local_cache_sr"; param_doc="The SR that is used as a local cache"; param_release=cowley_release; param_default=(Some (VRef null_ref))}; - {param_type=Map(String,String); param_name="chipset_info"; param_doc="Information about chipset features"; param_release=boston_release; param_default=Some(VMap [])}; - {param_type=Bool; param_name="ssl_legacy"; param_doc="Allow SSLv3 protocol and ciphersuites as used by older XenServers. This controls both incoming and outgoing connections."; param_release=dundee_release; param_default=Some (VBool true)}; +(* Host.power_on *) + +let power_on = call + ~name:"power_on" + ~in_product_since:rel_orlando + ~doc:"Attempt to power-on the host (if the capability exists)." + ~params:[Ref _host, "host", "The Host to power on"] + ~allowed_roles:_R_POOL_OP + () + +let restart_agent = call + ~name:"restart_agent" + ~in_product_since:rel_rio + ~doc:"Restarts the agent after a 10 second pause. WARNING: this is a dangerous operation. Any operations in progress will be aborted, and unrecoverable data loss may occur. The caller is responsible for ensuring that there are no operations in progress when this method is called." + ~params:[Ref _host, "host", "The Host on which you want to restart the agent"] + ~allowed_roles:_R_POOL_OP + () + +let shutdown_agent = call + ~name:"shutdown_agent" + ~in_product_since:rel_orlando + ~doc:"Shuts the agent down after a 10 second pause. WARNING: this is a dangerous operation. Any operations in progress will be aborted, and unrecoverable data loss may occur. The caller is responsible for ensuring that there are no operations in progress when this method is called." + ~params:[] + ~flags:[`Session] (* no async *) + ~allowed_roles:_R_POOL_OP + () + +let dmesg = call + ~name:"dmesg" + ~in_product_since:rel_rio + ~doc:"Get the host xen dmesg." + ~params:[Ref _host, "host", "The Host to query"] + ~result:(String, "dmesg string") + ~allowed_roles:_R_POOL_OP + () + +let dmesg_clear = call + ~name:"dmesg_clear" + ~in_product_since:rel_rio + ~doc:"Get the host xen dmesg, and clear the buffer." + ~params:[Ref _host, "host", "The Host to query"] + ~result:(String, "dmesg string") + ~allowed_roles:_R_POOL_OP + () + +let get_log = call + ~name:"get_log" + ~in_product_since:rel_rio + ~doc:"Get the host's log file" + ~params:[Ref _host, "host", "The Host to query"] + ~result:(String, "The contents of the host's primary log file") + ~allowed_roles:_R_READ_ONLY + () + +let send_debug_keys = call + ~name:"send_debug_keys" + ~in_product_since:rel_rio + ~doc:"Inject the given string as debugging keys into Xen" + ~params:[Ref _host, "host", "The host"; + String, "keys", "The keys to send"] + ~allowed_roles:_R_POOL_ADMIN + () + +let get_data_sources = call + ~name:"get_data_sources" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"" + ~result:(Set (Record _data_source), "A set of data sources") + ~params:[Ref _host, "host", "The host to interrogate"] + ~errs:[] + ~flags:[`Session] + ~allowed_roles:_R_READ_ONLY + () + +let record_data_source = call + ~name:"record_data_source" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Start recording the specified data source" + ~params:[Ref _host, "host", "The host"; + String, "data_source", "The data source to record"] + ~errs:[] + ~flags:[`Session] + ~allowed_roles:_R_POOL_OP + () + +let query_data_source = call + ~name:"query_data_source" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Query the latest value of the specified data source" + ~params:[Ref _host, "host", "The host"; + String, "data_source", "The data source to query"] + ~result:(Float,"The latest value, averaged over the last 5 seconds") + ~errs:[] + ~flags:[`Session] + ~allowed_roles:_R_READ_ONLY + () + +let attach_static_vdis = call + ~name:"attach_static_vdis" + ~in_product_since:rel_midnight_ride + ~doc:"Statically attach VDIs on a host." + ~params:[Ref _host, "host", "The Host to modify"; + Map(Ref _vdi, String), "vdi_reason_map", "List of VDI+reason pairs to attach" + ] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let detach_static_vdis = call + ~name:"detach_static_vdis" + ~in_product_since:rel_midnight_ride + ~doc:"Detach static VDIs from a host." + ~params:[Ref _host, "host", "The Host to modify"; + Set(Ref _vdi), "vdis", "Set of VDIs to detach"; + ] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let declare_dead = call + ~name:"declare_dead" + ~in_product_since:rel_clearwater + ~doc:"Declare that a host is dead. This is a dangerous operation, and should only be called if the administrator is absolutely sure the host is definitely dead" + ~params:[Ref _host, "host", "The Host to declare is dead"] + ~allowed_roles:_R_POOL_OP + () + +let forget_data_source_archives = call + ~name:"forget_data_source_archives" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Forget the recorded statistics related to the specified data source" + ~params:[Ref _host, "host", "The host"; + String, "data_source", "The data source whose archives are to be forgotten"] + ~flags:[`Session] + ~allowed_roles:_R_POOL_OP + () + +let get_diagnostic_timing_stats = call ~flags:[`Session] + ~in_product_since:rel_miami + ~name:"get_diagnostic_timing_stats" + ~doc:"Return timing statistics for diagnostic purposes" + ~params:[Ref _host, "host", "The host to interrogate"] + ~result:(Map(String, String), "population name to summary map") + ~hide_from_docs:true + ~allowed_roles:_R_READ_ONLY + () + +let create_new_blob = call + ~name: "create_new_blob" + ~in_product_since:rel_orlando + ~doc:"Create a placeholder for a named binary blob of data that is associated with this host" + ~versioned_params: + [{param_type=Ref _host; param_name="host"; param_doc="The host"; param_release=orlando_release; param_default=None}; + {param_type=String; param_name="name"; param_doc="The name associated with the blob"; param_release=orlando_release; param_default=None}; + {param_type=String; param_name="mime_type"; param_doc="The mime type for the data. Empty string translates to application/octet-stream"; param_release=orlando_release; param_default=None}; + {param_type=Bool; param_name="public"; param_doc="True if the blob should be publicly available"; param_release=tampa_release; param_default=Some (VBool false)}] + ~result:(Ref _blob, "The reference of the blob, needed for populating its data") + ~allowed_roles:_R_POOL_OP + () + +let call_plugin = call + ~name:"call_plugin" + ~in_product_since:rel_orlando + ~doc:"Call a XenAPI plugin on this host" + ~params:[Ref _host, "host", "The host"; + String, "plugin", "The name of the plugin"; + String, "fn", "The name of the function within the plugin"; + Map(String, String), "args", "Arguments for the function";] + ~result:(String, "Result from the plugin") + ~allowed_roles:_R_POOL_ADMIN + () + +let has_extension = call + ~name:"has_extension" + ~in_product_since:rel_ely + ~doc:"Return true if the extension is available on the host" + ~params:[Ref _host, "host", "The host"; + String, "name", "The name of the API call";] + ~result:(Bool, "True if the extension exists, false otherwise") + ~allowed_roles:_R_POOL_ADMIN + () + +let call_extension = call + ~name:"call_extension" + ~in_product_since:rel_ely + ~custom_marshaller:true + ~doc:"Call a XenAPI extension on this host" + ~params:[Ref _host, "host", "The host"; + String, "call", "Rpc call for the extension";] + ~result:(String, "Result from the extension") + ~allowed_roles:_R_POOL_ADMIN + ~flags:[`Session] (* no async *) + () + +let enable_binary_storage = call + ~name:"enable_binary_storage" + ~in_product_since:rel_orlando + ~hide_from_docs:true + ~pool_internal:true + ~doc:"Enable binary storage on a particular host, for storing RRDs, messages and blobs" + ~params:[Ref _host, "host", "The host"] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let disable_binary_storage = call + ~name:"disable_binary_storage" + ~in_product_since:rel_orlando + ~hide_from_docs:true + ~pool_internal:true + ~doc:"Disable binary storage on a particular host, deleting stored RRDs, messages and blobs" + ~params:[Ref _host, "host", "The host"] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let update_pool_secret = call + ~name:"update_pool_secret" + ~in_product_since:rel_midnight_ride + ~hide_from_docs:true + ~pool_internal:true + ~doc:"" + ~params:[ + Ref _host, "host", "The host"; + String, "pool_secret", "The new pool secret" ] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let update_master = call + ~name:"update_master" + ~in_product_since:rel_midnight_ride + ~hide_from_docs:true + ~pool_internal:true + ~doc:"" + ~params:[ + Ref _host, "host", "The host"; + String, "master_address", "The new master address" ] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let set_localdb_key = call + ~name:"set_localdb_key" + ~in_product_since:rel_midnight_ride + ~doc:"Set a key in the local DB of the host." + ~params:[Ref _host, "host", "The Host to modify"; + String, "key", "Key to change"; + String, "value", "Value to set" + ] + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let refresh_pack_info = call + ~name:"refresh_pack_info" + ~doc:"Refresh the list of installed Supplemental Packs." + ~params:[Ref _host, "host", "The Host to modify"] + ~allowed_roles:_R_POOL_OP + ~lifecycle:[Published, rel_midnight_ride, ""; + Deprecated, rel_ely, "Use Pool_update.resync_host instead"] + () + +let bugreport_upload = call + ~name:"bugreport_upload" + ~doc:"Run xen-bugtool --yestoall and upload the output to support" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[ Ref _host, "host", "The host on which to run xen-bugtool"; + String, "url", "The URL to upload to"; + Map(String, String), "options", "Extra configuration operations" ] + ~allowed_roles:_R_POOL_OP + () + +let list_methods = call + ~name:"list_methods" + ~in_product_since:rel_rio + ~flags: [`Session] + ~doc:"List all supported methods" + ~params:[] + ~result:(Set(String), "The name of every supported method.") + ~allowed_roles:_R_READ_ONLY + () + +let license_apply = call + ~name:"license_apply" + ~in_oss_since:None + ~lifecycle:[ + Published, rel_rio, "Apply a new license to a host"; + Removed, rel_clearwater, "Free licenses no longer handled by xapi"; ] + ~params:[Ref _host, "host", "The host to upload the license to"; + String, "contents", "The contents of the license file, base64 encoded"] + ~doc:"Apply a new license to a host" + ~errs: [Api_errors.license_processing_error] + ~allowed_roles:_R_POOL_OP + () - let create = call - ~name:"create" - ~in_oss_since:None - ~in_product_since:rel_rio - ~versioned_params:create_params - ~doc:"Create a new host record" - ~result:(Ref _host, "Reference to the newly created host object.") - ~hide_from_docs:true - ~allowed_roles:_R_POOL_OP - () - - let destroy = call - ~name:"destroy" - ~in_oss_since:None - ~in_product_since:rel_rio - ~doc:"Destroy specified host record in database" - ~params:[(Ref _host, "self", "The host record to remove")] - ~allowed_roles:_R_POOL_OP - () - - let get_system_status_capabilities = call ~flags:[`Session] - ~name:"get_system_status_capabilities" - ~in_oss_since:None - ~in_product_since:rel_miami - ~params:[Ref _host, "host", "The host to interrogate"] - ~doc:"" - ~result:(String, "An XML fragment containing the system status capabilities.") - ~allowed_roles:_R_READ_ONLY - () - - let set_hostname_live = call ~flags:[`Session] - ~name:"set_hostname_live" - ~in_oss_since:None - ~in_product_since:rel_miami - ~params:[Ref _host, "host", "The host whose host name to set"; - String, "hostname", "The new host name"] - ~errs:[Api_errors.host_name_invalid] - ~doc:"Sets the host name to the specified string. Both the API and lower-level system hostname are changed immediately." - ~allowed_roles:_R_POOL_OP - () - - let tickle_heartbeat = call ~flags:[`Session] - ~name:"tickle_heartbeat" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~params:[Ref _host, "host", "The host calling the function, and whose heartbeat to tickle"; - Map(String, String), "stuff", "Anything else we want to let the master know"; - ] - ~result:(Map(String, String), "Anything the master wants to tell the slave") - ~doc:"Needs to be called every 30 seconds for the master to believe the host is alive" - ~pool_internal:true - ~hide_from_docs:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let sync_data = call ~flags:[`Session] - ~name:"sync_data" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~params:[Ref _host, "host", "The host to whom the data should be sent"] - ~doc:"This causes the synchronisation of the non-database data (messages, RRDs and so on) stored on the master to be synchronised with the host" - ~allowed_roles:_R_POOL_ADMIN - () - - let backup_rrds = call ~flags:[`Session] - ~name:"backup_rrds" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~params:[Ref _host, "host", "Schedule a backup of the RRDs of this host"; - Float, "delay", "Delay in seconds from when the call is received to perform the backup"] - ~doc:"This causes the RRDs to be backed up to the master" - ~allowed_roles:_R_POOL_ADMIN - () - - let get_servertime = call ~flags:[`Session] - ~name:"get_servertime" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~params:[Ref _host, "host", "The host whose clock should be queried"] - ~doc:"This call queries the host's clock for the current time" - ~result:(DateTime, "The current time") - ~allowed_roles:_R_READ_ONLY - () - - let get_server_localtime = call ~flags:[`Session] - ~name:"get_server_localtime" - ~in_oss_since:None - ~in_product_since:rel_cowley - ~params:[Ref _host, "host", "The host whose clock should be queried"] - ~doc:"This call queries the host's clock for the current time in the host's local timezone" - ~result:(DateTime, "The current local time") - ~allowed_roles:_R_READ_ONLY - () - - let emergency_ha_disable = call ~flags:[`Session] - ~name:"emergency_ha_disable" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~versioned_params: - [{param_type=Bool; param_name="soft"; param_doc="Disable HA temporarily, revert upon host reboot or further changes, idempotent"; param_release=ely_release; param_default=Some(VBool false)}; - ] - ~doc:"This call disables HA on the local host. This should only be used with extreme care." - ~allowed_roles:_R_POOL_OP - () - - let certificate_install = call - ~in_oss_since:None - ~in_product_since:rel_george - ~pool_internal:true - ~hide_from_docs:true - ~name:"certificate_install" - ~doc:"Install an SSL certificate to this host." - ~params:[Ref _host, "host", "The host"; - String, "name", "A name to give the certificate"; - String, "cert", "The certificate"] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let certificate_uninstall = call - ~in_oss_since:None - ~in_product_since:rel_george - ~pool_internal:true - ~hide_from_docs:true - ~name:"certificate_uninstall" - ~doc:"Remove an SSL certificate from this host." - ~params:[Ref _host, "host", "The host"; - String, "name", "The certificate name"] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let certificate_list = call - ~in_oss_since:None - ~in_product_since:rel_george - ~pool_internal:true - ~hide_from_docs:true - ~name:"certificate_list" - ~doc:"List all installed SSL certificates." - ~params:[Ref _host, "host", "The host"] - ~result:(Set(String),"All installed certificates") - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let crl_install = call - ~in_oss_since:None - ~in_product_since:rel_george - ~pool_internal:true - ~hide_from_docs:true - ~name:"crl_install" - ~doc:"Install an SSL certificate revocation list to this host." - ~params:[Ref _host, "host", "The host"; - String, "name", "A name to give the CRL"; - String, "crl", "The CRL"] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let crl_uninstall = call - ~in_oss_since:None - ~in_product_since:rel_george - ~pool_internal:true - ~hide_from_docs:true - ~name:"crl_uninstall" - ~doc:"Remove an SSL certificate revocation list from this host." - ~params:[Ref _host, "host", "The host"; - String, "name", "The CRL name"] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let crl_list = call - ~in_oss_since:None - ~in_product_since:rel_george - ~pool_internal:true - ~hide_from_docs:true - ~name:"crl_list" - ~doc:"List all installed SSL certificate revocation lists." - ~params:[Ref _host, "host", "The host"] - ~result:(Set(String),"All installed CRLs") - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let certificate_sync = call - ~in_oss_since:None - ~in_product_since:rel_george - ~pool_internal:true - ~hide_from_docs:true - ~name:"certificate_sync" - ~doc:"Resync installed SSL certificates and CRLs." - ~params:[Ref _host, "host", "The host"] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let get_server_certificate = call - ~in_oss_since:None - ~lifecycle:[Published, rel_george, ""; Changed, rel_inverness, "Now available to all RBAC roles."] - ~name:"get_server_certificate" - ~doc:"Get the installed server public TLS certificate." - ~params:[Ref _host, "host", "The host"] - ~result:(String,"The installed server public TLS certificate, in PEM form.") - ~allowed_roles:_R_READ_ONLY - () - - let display = - Enum ("host_display", [ - "enabled", "This host is outputting its console to a physical display device"; - "disable_on_reboot", "The host will stop outputting its console to a physical display device on next boot"; - "disabled", "This host is not outputting its console to a physical display device"; - "enable_on_reboot", "The host will start outputting its console to a physical display device on next boot"; - ]) - - let operations = - Enum ("host_allowed_operations", - [ "provision", "Indicates this host is able to provision another VM"; - "evacuate", "Indicates this host is evacuating"; - "shutdown", "Indicates this host is in the process of shutting itself down"; - "reboot", "Indicates this host is in the process of rebooting"; - "power_on", "Indicates this host is in the process of being powered on"; - "vm_start", "This host is starting a VM"; - "vm_resume", "This host is resuming a VM"; - "vm_migrate", "This host is the migration target of a VM"; - ]) - - let enable_external_auth = call ~flags:[`Session] - ~name:"enable_external_auth" - ~in_oss_since:None - ~in_product_since:rel_george - ~params:[ - Ref _host, "host", "The host whose external authentication should be enabled"; - Map (String,String), "config", "A list of key-values containing the configuration data" ; - String, "service_name", "The name of the service" ; - String, "auth_type", "The type of authentication (e.g. AD for Active Directory)" - ] - ~doc:"This call enables external authentication on a host" - ~allowed_roles:_R_POOL_ADMIN - () - - let disable_external_auth = call ~flags:[`Session] - ~name:"disable_external_auth" - ~in_oss_since:None - ~in_product_since:rel_george - ~versioned_params:[ - {param_type=Ref _host; param_name="host"; param_doc="The host whose external authentication should be disabled"; param_release=george_release; param_default=None}; - {param_type=Map (String, String); param_name="config"; param_doc="Optional parameters as a list of key-values containing the configuration data"; param_release=george_release; param_default=Some (VMap [])} - ] - ~doc:"This call disables external authentication on the local host" - ~allowed_roles:_R_POOL_ADMIN - () - - let set_license_params = call - ~name:"set_license_params" - ~in_product_since:rel_orlando (* actually update 3 aka floodgate *) - ~doc:"Set the new license details in the database, trigger a recomputation of the pool SKU" - ~params:[ - Ref _host, "self", "The host"; - Map(String, String), "value", "The license_params" - ] - ~hide_from_docs:true - ~pool_internal:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let apply_edition = call ~flags:[`Session] - ~name:"apply_edition" - ~in_product_since:rel_midnight_ride - ~doc:"Change to another edition, or reactivate the current edition after a license has expired. This may be subject to the successful checkout of an appropriate license." - ~versioned_params:[ - {param_type=Ref _host; param_name="host"; param_doc="The host"; param_release=midnight_ride_release; param_default=None}; - {param_type=String; param_name="edition"; param_doc="The requested edition"; param_release=midnight_ride_release; param_default=None}; - {param_type=Bool; param_name="force"; param_doc="Update the license params even if the apply call fails"; param_release=clearwater_release; param_default=Some (VBool false)}; - ] - ~allowed_roles:_R_POOL_OP - () - - let set_power_on_mode = call - ~name:"set_power_on_mode" - ~in_product_since:rel_midnight_ride - ~doc:"Set the power-on-mode, host, user and password " - ~params:[ - Ref _host, "self", "The host"; - String, "power_on_mode", "power-on-mode can be empty,iLO,wake-on-lan, DRAC or other"; - Map(String, String), "power_on_config", "Power on config"; - ] - ~allowed_roles:_R_POOL_OP - () - - let set_ssl_legacy = call - ~name:"set_ssl_legacy" - ~lifecycle:[Published, rel_dundee, ""] - ~doc:"Enable/disable SSLv3 for interoperability with older versions of XenServer. When this is set to a different value, the host immediately restarts its SSL/TLS listening service; typically this takes less than a second but existing connections to it will be broken. XenAPI login sessions will remain valid." - ~params:[ - Ref _host, "self", "The host"; - Bool, "value", "True to allow SSLv3 and ciphersuites as used in old XenServer versions"; - ] - ~allowed_roles:_R_POOL_OP - () - - let set_cpu_features = call ~flags:[`Session] - ~name:"set_cpu_features" - ~in_product_since:rel_midnight_ride - ~doc:"Set the CPU features to be used after a reboot, if the given features string is valid." - ~params:[ - Ref _host, "host", "The host"; - String, "features", "The features string (32 hexadecimal digits)" - ] - ~allowed_roles:_R_POOL_OP - ~lifecycle:[Published, rel_midnight_ride, ""; Removed, rel_dundee, "Manual CPU feature setting was removed"] - () - - let reset_cpu_features = call ~flags:[`Session] - ~name:"reset_cpu_features" - ~in_product_since:rel_midnight_ride - ~doc:"Remove the feature mask, such that after a reboot all features of the CPU are enabled." - ~params:[ - Ref _host, "host", "The host" - ] - ~allowed_roles:_R_POOL_OP - ~lifecycle:[Published, rel_midnight_ride, ""; Removed, rel_dundee, "Manual CPU feature setting was removed"] - () - - let reset_networking = call - ~name:"reset_networking" - ~lifecycle:[] - ~doc:"Purge all network-related metadata associated with the given host." - ~params:[Ref _host, "host", "The Host to modify"] - ~allowed_roles:_R_POOL_OP - ~hide_from_docs:true - () - - let enable_local_storage_caching = call ~flags:[`Session] - ~name:"enable_local_storage_caching" - ~in_product_since:rel_cowley - ~doc:"Enable the use of a local SR for caching purposes" - ~params:[ - Ref _host, "host", "The host"; - Ref _sr, "sr", "The SR to use as a local cache" - ] - ~allowed_roles:_R_POOL_OP - () - - let disable_local_storage_caching = call ~flags:[`Session] - ~name:"disable_local_storage_caching" - ~in_product_since:rel_cowley - ~doc:"Disable the use of a local SR for caching purposes" - ~params:[ - Ref _host, "host", "The host" - ] - ~allowed_roles:_R_POOL_OP - () - - let get_sm_diagnostics = call ~flags:[`Session] - ~name:"get_sm_diagnostics" - ~in_product_since:rel_boston - ~doc:"Return live SM diagnostics" - ~params:[ - Ref _host, "host", "The host" - ] - ~result:(String, "Printable diagnostic data") - ~allowed_roles:_R_POOL_OP - ~hide_from_docs:true - () - - let get_thread_diagnostics = call ~flags:[`Session] - ~name:"get_thread_diagnostics" - ~in_product_since:rel_boston - ~doc:"Return live thread diagnostics" - ~params:[ - Ref _host, "host", "The host" - ] - ~result:(String, "Printable diagnostic data") - ~allowed_roles:_R_POOL_OP - ~hide_from_docs:true - () - - let sm_dp_destroy = call ~flags:[`Session] - ~name:"sm_dp_destroy" - ~in_product_since:rel_boston - ~doc:"Attempt to cleanup and destroy a named SM datapath" - ~params:[ - Ref _host, "host", "The host"; - String, "dp", "The datapath"; - Bool, "allow_leak", "If true, all records of the datapath will be removed even if the datapath could not be destroyed cleanly."; - ] - ~allowed_roles:_R_POOL_OP - ~hide_from_docs:true - () - - let sync_vlans = call ~flags:[`Session] - ~name:"sync_vlans" - ~lifecycle:[] - ~doc:"Synchronise VLANs on given host with the master's VLANs" - ~params:[ - Ref _host, "host", "The host"; - ] - ~hide_from_docs:true - ~pool_internal:true - ~allowed_roles:_R_POOL_OP - () - - let sync_tunnels = call ~flags:[`Session] - ~name:"sync_tunnels" - ~lifecycle:[] - ~doc:"Synchronise tunnels on given host with the master's tunnels" - ~params:[ - Ref _host, "host", "The host"; - ] - ~hide_from_docs:true - ~pool_internal:true - ~allowed_roles:_R_POOL_OP - () - - let sync_pif_currently_attached = call ~flags:[`Session] - ~name:"sync_pif_currently_attached" - ~lifecycle:[] - ~doc:"Synchronise tunnels on given host with the master's tunnels" - ~params:[ - Ref _host, "host", "The host"; - Set String, "bridges", "A list of bridges that are currently up"; - ] - ~hide_from_docs:true - ~pool_internal:true - ~allowed_roles:_R_POOL_OP - () - - let enable_display = call - ~name:"enable_display" - ~lifecycle:[Published, rel_cream, ""] - ~doc:"Enable console output to the physical display device next time this host boots" - ~params:[ - Ref _host, "host", "The host"; - ] - ~result:(display, "This host's physical display usage") - ~allowed_roles:_R_POOL_OP - () - - let disable_display = call - ~name:"disable_display" - ~lifecycle:[Published, rel_cream, ""] - ~doc:"Disable console output to the physical display device next time this host boots" - ~params:[ - Ref _host, "host", "The host"; - ] - ~result:(display, "This host's physical display usage") - ~allowed_roles:_R_POOL_OP - () - - let apply_guest_agent_config = call - ~name:"apply_guest_agent_config" - ~lifecycle:[Published, rel_dundee, ""] - ~doc:"Signal to the host that the pool-wide guest agent config has changed" - ~params:[ - Ref _host, "host", "The host"; - ] - ~hide_from_docs:true - ~allowed_roles:_R_POOL_ADMIN - () - - let mxgpu_vf_setup = call - ~name:"mxgpu_vf_setup" - ~lifecycle:[Published, rel_falcon, ""] - ~doc:"Ensure the driver (kernel module) for MxGPU is loaded on the host, and create PCI objects for any new PCI devices (virtual functions) that the module makes visible." - ~params:[ - Ref _host, "host", "The host"; - ] - ~hide_from_docs:true - ~pool_internal:true - ~allowed_roles:_R_VM_OP - () - - let allocate_resources_for_vm = call - ~name:"allocate_resources_for_vm" - ~lifecycle:[Published, rel_inverness, ""] - ~doc:"Reserves the resources for a VM by setting the 'scheduled_to_be_resident_on' fields" - ~params:[ - Ref _host, "self", "The host"; - Ref _vm, "vm", "The VM"; - Bool, "live", "Is this part of a live migration?" +let license_add = call + ~name:"license_add" + ~in_oss_since:None + ~lifecycle:[ + Published, rel_indigo, "Functionality for parsing license files re-added"; + ] + ~params:[Ref _host, "host", "The host to upload the license to"; + String, "contents", "The contents of the license file, base64 encoded"] + ~doc:"Apply a new license to a host" + ~errs: [Api_errors.license_processing_error] + ~allowed_roles:_R_POOL_OP + () + +let license_remove = call + ~name:"license_remove" + ~in_oss_since:None + ~lifecycle:[ + Published, rel_indigo, ""; + ] + ~params:[ + Ref _host, "host", "The host from which any license will be removed" + ] + ~doc:"Remove any license file from the specified host, and switch that host to the unlicensed edition" + ~allowed_roles:_R_POOL_OP + () + +let create_params = + [ + {param_type=String; param_name="uuid"; param_doc="unique identifier/object reference"; param_release=rio_release; param_default=None}; + {param_type=String; param_name="name_label"; param_doc="The name of the new storage repository"; param_release=rio_release; param_default=None}; + {param_type=String; param_name="name_description"; param_doc="The description of the new storage repository"; param_release=rio_release; param_default=None}; + {param_type=String; param_name="hostname"; param_doc="Hostname"; param_release=rio_release; param_default=None}; + {param_type=String; param_name="address"; param_doc="An address by which this host can be contacted by other members in its pool"; param_release=rio_release; param_default=None}; + {param_type=String; param_name="external_auth_type"; param_doc="type of external authentication service configured; empty if none configured"; param_release=george_release; param_default=Some(VString "")}; + {param_type=String; param_name="external_auth_service_name"; param_doc="name of external authentication service configured; empty if none configured"; param_release=george_release; param_default=Some(VString "")}; + {param_type=Map(String,String); param_name="external_auth_configuration"; param_doc="configuration specific to external authentication service"; param_release=george_release; param_default=Some(VMap [])}; + {param_type=Map(String,String); param_name="license_params"; param_doc="State of the current license"; param_release=midnight_ride_release; param_default=Some(VMap [])}; + {param_type=String; param_name="edition"; param_doc="Product edition"; param_release=midnight_ride_release; param_default=Some(VString "")}; + {param_type=Map(String,String); param_name="license_server"; param_doc="Contact information of the license server"; param_release=midnight_ride_release; param_default=Some(VMap [VString "address", VString "localhost"; VString "port", VString "27000"])}; + {param_type=Ref _sr; param_name="local_cache_sr"; param_doc="The SR that is used as a local cache"; param_release=cowley_release; param_default=(Some (VRef null_ref))}; + {param_type=Map(String,String); param_name="chipset_info"; param_doc="Information about chipset features"; param_release=boston_release; param_default=Some(VMap [])}; + {param_type=Bool; param_name="ssl_legacy"; param_doc="Allow SSLv3 protocol and ciphersuites as used by older XenServers. This controls both incoming and outgoing connections."; param_release=dundee_release; param_default=Some (VBool true)}; + ] + +let create = call + ~name:"create" + ~in_oss_since:None + ~in_product_since:rel_rio + ~versioned_params:create_params + ~doc:"Create a new host record" + ~result:(Ref _host, "Reference to the newly created host object.") + ~hide_from_docs:true + ~allowed_roles:_R_POOL_OP + () + +let destroy = call + ~name:"destroy" + ~in_oss_since:None + ~in_product_since:rel_rio + ~doc:"Destroy specified host record in database" + ~params:[(Ref _host, "self", "The host record to remove")] + ~allowed_roles:_R_POOL_OP + () + +let get_system_status_capabilities = call ~flags:[`Session] + ~name:"get_system_status_capabilities" + ~in_oss_since:None + ~in_product_since:rel_miami + ~params:[Ref _host, "host", "The host to interrogate"] + ~doc:"" + ~result:(String, "An XML fragment containing the system status capabilities.") + ~allowed_roles:_R_READ_ONLY + () + +let set_hostname_live = call ~flags:[`Session] + ~name:"set_hostname_live" + ~in_oss_since:None + ~in_product_since:rel_miami + ~params:[Ref _host, "host", "The host whose host name to set"; + String, "hostname", "The new host name"] + ~errs:[Api_errors.host_name_invalid] + ~doc:"Sets the host name to the specified string. Both the API and lower-level system hostname are changed immediately." + ~allowed_roles:_R_POOL_OP + () + +let tickle_heartbeat = call ~flags:[`Session] + ~name:"tickle_heartbeat" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~params:[Ref _host, "host", "The host calling the function, and whose heartbeat to tickle"; + Map(String, String), "stuff", "Anything else we want to let the master know"; + ] + ~result:(Map(String, String), "Anything the master wants to tell the slave") + ~doc:"Needs to be called every 30 seconds for the master to believe the host is alive" + ~pool_internal:true + ~hide_from_docs:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let sync_data = call ~flags:[`Session] + ~name:"sync_data" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~params:[Ref _host, "host", "The host to whom the data should be sent"] + ~doc:"This causes the synchronisation of the non-database data (messages, RRDs and so on) stored on the master to be synchronised with the host" + ~allowed_roles:_R_POOL_ADMIN + () + +let backup_rrds = call ~flags:[`Session] + ~name:"backup_rrds" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~params:[Ref _host, "host", "Schedule a backup of the RRDs of this host"; + Float, "delay", "Delay in seconds from when the call is received to perform the backup"] + ~doc:"This causes the RRDs to be backed up to the master" + ~allowed_roles:_R_POOL_ADMIN + () + +let get_servertime = call ~flags:[`Session] + ~name:"get_servertime" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~params:[Ref _host, "host", "The host whose clock should be queried"] + ~doc:"This call queries the host's clock for the current time" + ~result:(DateTime, "The current time") + ~allowed_roles:_R_READ_ONLY + () + +let get_server_localtime = call ~flags:[`Session] + ~name:"get_server_localtime" + ~in_oss_since:None + ~in_product_since:rel_cowley + ~params:[Ref _host, "host", "The host whose clock should be queried"] + ~doc:"This call queries the host's clock for the current time in the host's local timezone" + ~result:(DateTime, "The current local time") + ~allowed_roles:_R_READ_ONLY + () + +let emergency_ha_disable = call ~flags:[`Session] + ~name:"emergency_ha_disable" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~versioned_params: + [{param_type=Bool; param_name="soft"; param_doc="Disable HA temporarily, revert upon host reboot or further changes, idempotent"; param_release=ely_release; param_default=Some(VBool false)}; ] - ~hide_from_docs:true - ~allowed_roles:_R_VM_OP - () + ~doc:"This call disables HA on the local host. This should only be used with extreme care." + ~allowed_roles:_R_POOL_OP + () + +let certificate_install = call + ~in_oss_since:None + ~in_product_since:rel_george + ~pool_internal:true + ~hide_from_docs:true + ~name:"certificate_install" + ~doc:"Install an SSL certificate to this host." + ~params:[Ref _host, "host", "The host"; + String, "name", "A name to give the certificate"; + String, "cert", "The certificate"] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let certificate_uninstall = call + ~in_oss_since:None + ~in_product_since:rel_george + ~pool_internal:true + ~hide_from_docs:true + ~name:"certificate_uninstall" + ~doc:"Remove an SSL certificate from this host." + ~params:[Ref _host, "host", "The host"; + String, "name", "The certificate name"] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let certificate_list = call + ~in_oss_since:None + ~in_product_since:rel_george + ~pool_internal:true + ~hide_from_docs:true + ~name:"certificate_list" + ~doc:"List all installed SSL certificates." + ~params:[Ref _host, "host", "The host"] + ~result:(Set(String),"All installed certificates") + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () - let set_iscsi_iqn = call +let crl_install = call + ~in_oss_since:None + ~in_product_since:rel_george + ~pool_internal:true + ~hide_from_docs:true + ~name:"crl_install" + ~doc:"Install an SSL certificate revocation list to this host." + ~params:[Ref _host, "host", "The host"; + String, "name", "A name to give the CRL"; + String, "crl", "The CRL"] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let crl_uninstall = call + ~in_oss_since:None + ~in_product_since:rel_george + ~pool_internal:true + ~hide_from_docs:true + ~name:"crl_uninstall" + ~doc:"Remove an SSL certificate revocation list from this host." + ~params:[Ref _host, "host", "The host"; + String, "name", "The CRL name"] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let crl_list = call + ~in_oss_since:None + ~in_product_since:rel_george + ~pool_internal:true + ~hide_from_docs:true + ~name:"crl_list" + ~doc:"List all installed SSL certificate revocation lists." + ~params:[Ref _host, "host", "The host"] + ~result:(Set(String),"All installed CRLs") + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let certificate_sync = call + ~in_oss_since:None + ~in_product_since:rel_george + ~pool_internal:true + ~hide_from_docs:true + ~name:"certificate_sync" + ~doc:"Resync installed SSL certificates and CRLs." + ~params:[Ref _host, "host", "The host"] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let get_server_certificate = call + ~in_oss_since:None + ~lifecycle:[Published, rel_george, ""; Changed, rel_inverness, "Now available to all RBAC roles."] + ~name:"get_server_certificate" + ~doc:"Get the installed server public TLS certificate." + ~params:[Ref _host, "host", "The host"] + ~result:(String,"The installed server public TLS certificate, in PEM form.") + ~allowed_roles:_R_READ_ONLY + () + +let display = + Enum ("host_display", [ + "enabled", "This host is outputting its console to a physical display device"; + "disable_on_reboot", "The host will stop outputting its console to a physical display device on next boot"; + "disabled", "This host is not outputting its console to a physical display device"; + "enable_on_reboot", "The host will start outputting its console to a physical display device on next boot"; + ]) + +let operations = + Enum ("host_allowed_operations", + [ "provision", "Indicates this host is able to provision another VM"; + "evacuate", "Indicates this host is evacuating"; + "shutdown", "Indicates this host is in the process of shutting itself down"; + "reboot", "Indicates this host is in the process of rebooting"; + "power_on", "Indicates this host is in the process of being powered on"; + "vm_start", "This host is starting a VM"; + "vm_resume", "This host is resuming a VM"; + "vm_migrate", "This host is the migration target of a VM"; + ]) + +let enable_external_auth = call ~flags:[`Session] + ~name:"enable_external_auth" + ~in_oss_since:None + ~in_product_since:rel_george + ~params:[ + Ref _host, "host", "The host whose external authentication should be enabled"; + Map (String,String), "config", "A list of key-values containing the configuration data" ; + String, "service_name", "The name of the service" ; + String, "auth_type", "The type of authentication (e.g. AD for Active Directory)" + ] + ~doc:"This call enables external authentication on a host" + ~allowed_roles:_R_POOL_ADMIN + () + +let disable_external_auth = call ~flags:[`Session] + ~name:"disable_external_auth" + ~in_oss_since:None + ~in_product_since:rel_george + ~versioned_params:[ + {param_type=Ref _host; param_name="host"; param_doc="The host whose external authentication should be disabled"; param_release=george_release; param_default=None}; + {param_type=Map (String, String); param_name="config"; param_doc="Optional parameters as a list of key-values containing the configuration data"; param_release=george_release; param_default=Some (VMap [])} + ] + ~doc:"This call disables external authentication on the local host" + ~allowed_roles:_R_POOL_ADMIN + () + +let set_license_params = call + ~name:"set_license_params" + ~in_product_since:rel_orlando (* actually update 3 aka floodgate *) + ~doc:"Set the new license details in the database, trigger a recomputation of the pool SKU" + ~params:[ + Ref _host, "self", "The host"; + Map(String, String), "value", "The license_params" + ] + ~hide_from_docs:true + ~pool_internal:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let apply_edition = call ~flags:[`Session] + ~name:"apply_edition" + ~in_product_since:rel_midnight_ride + ~doc:"Change to another edition, or reactivate the current edition after a license has expired. This may be subject to the successful checkout of an appropriate license." + ~versioned_params:[ + {param_type=Ref _host; param_name="host"; param_doc="The host"; param_release=midnight_ride_release; param_default=None}; + {param_type=String; param_name="edition"; param_doc="The requested edition"; param_release=midnight_ride_release; param_default=None}; + {param_type=Bool; param_name="force"; param_doc="Update the license params even if the apply call fails"; param_release=clearwater_release; param_default=Some (VBool false)}; + ] + ~allowed_roles:_R_POOL_OP + () + +let set_power_on_mode = call + ~name:"set_power_on_mode" + ~in_product_since:rel_midnight_ride + ~doc:"Set the power-on-mode, host, user and password " + ~params:[ + Ref _host, "self", "The host"; + String, "power_on_mode", "power-on-mode can be empty,iLO,wake-on-lan, DRAC or other"; + Map(String, String), "power_on_config", "Power on config"; + ] + ~allowed_roles:_R_POOL_OP + () + +let set_ssl_legacy = call + ~name:"set_ssl_legacy" + ~lifecycle:[Published, rel_dundee, ""] + ~doc:"Enable/disable SSLv3 for interoperability with older versions of XenServer. When this is set to a different value, the host immediately restarts its SSL/TLS listening service; typically this takes less than a second but existing connections to it will be broken. XenAPI login sessions will remain valid." + ~params:[ + Ref _host, "self", "The host"; + Bool, "value", "True to allow SSLv3 and ciphersuites as used in old XenServer versions"; + ] + ~allowed_roles:_R_POOL_OP + () + +let set_cpu_features = call ~flags:[`Session] + ~name:"set_cpu_features" + ~in_product_since:rel_midnight_ride + ~doc:"Set the CPU features to be used after a reboot, if the given features string is valid." + ~params:[ + Ref _host, "host", "The host"; + String, "features", "The features string (32 hexadecimal digits)" + ] + ~allowed_roles:_R_POOL_OP + ~lifecycle:[Published, rel_midnight_ride, ""; Removed, rel_dundee, "Manual CPU feature setting was removed"] + () + +let reset_cpu_features = call ~flags:[`Session] + ~name:"reset_cpu_features" + ~in_product_since:rel_midnight_ride + ~doc:"Remove the feature mask, such that after a reboot all features of the CPU are enabled." + ~params:[ + Ref _host, "host", "The host" + ] + ~allowed_roles:_R_POOL_OP + ~lifecycle:[Published, rel_midnight_ride, ""; Removed, rel_dundee, "Manual CPU feature setting was removed"] + () + +let reset_networking = call + ~name:"reset_networking" + ~lifecycle:[] + ~doc:"Purge all network-related metadata associated with the given host." + ~params:[Ref _host, "host", "The Host to modify"] + ~allowed_roles:_R_POOL_OP + ~hide_from_docs:true + () + +let enable_local_storage_caching = call ~flags:[`Session] + ~name:"enable_local_storage_caching" + ~in_product_since:rel_cowley + ~doc:"Enable the use of a local SR for caching purposes" + ~params:[ + Ref _host, "host", "The host"; + Ref _sr, "sr", "The SR to use as a local cache" + ] + ~allowed_roles:_R_POOL_OP + () + +let disable_local_storage_caching = call ~flags:[`Session] + ~name:"disable_local_storage_caching" + ~in_product_since:rel_cowley + ~doc:"Disable the use of a local SR for caching purposes" + ~params:[ + Ref _host, "host", "The host" + ] + ~allowed_roles:_R_POOL_OP + () + +let get_sm_diagnostics = call ~flags:[`Session] + ~name:"get_sm_diagnostics" + ~in_product_since:rel_boston + ~doc:"Return live SM diagnostics" + ~params:[ + Ref _host, "host", "The host" + ] + ~result:(String, "Printable diagnostic data") + ~allowed_roles:_R_POOL_OP + ~hide_from_docs:true + () + +let get_thread_diagnostics = call ~flags:[`Session] + ~name:"get_thread_diagnostics" + ~in_product_since:rel_boston + ~doc:"Return live thread diagnostics" + ~params:[ + Ref _host, "host", "The host" + ] + ~result:(String, "Printable diagnostic data") + ~allowed_roles:_R_POOL_OP + ~hide_from_docs:true + () + +let sm_dp_destroy = call ~flags:[`Session] + ~name:"sm_dp_destroy" + ~in_product_since:rel_boston + ~doc:"Attempt to cleanup and destroy a named SM datapath" + ~params:[ + Ref _host, "host", "The host"; + String, "dp", "The datapath"; + Bool, "allow_leak", "If true, all records of the datapath will be removed even if the datapath could not be destroyed cleanly."; + ] + ~allowed_roles:_R_POOL_OP + ~hide_from_docs:true + () + +let sync_vlans = call ~flags:[`Session] + ~name:"sync_vlans" + ~lifecycle:[] + ~doc:"Synchronise VLANs on given host with the master's VLANs" + ~params:[ + Ref _host, "host", "The host"; + ] + ~hide_from_docs:true + ~pool_internal:true + ~allowed_roles:_R_POOL_OP + () + +let sync_tunnels = call ~flags:[`Session] + ~name:"sync_tunnels" + ~lifecycle:[] + ~doc:"Synchronise tunnels on given host with the master's tunnels" + ~params:[ + Ref _host, "host", "The host"; + ] + ~hide_from_docs:true + ~pool_internal:true + ~allowed_roles:_R_POOL_OP + () + +let sync_pif_currently_attached = call ~flags:[`Session] + ~name:"sync_pif_currently_attached" + ~lifecycle:[] + ~doc:"Synchronise tunnels on given host with the master's tunnels" + ~params:[ + Ref _host, "host", "The host"; + Set String, "bridges", "A list of bridges that are currently up"; + ] + ~hide_from_docs:true + ~pool_internal:true + ~allowed_roles:_R_POOL_OP + () + +let enable_display = call + ~name:"enable_display" + ~lifecycle:[Published, rel_cream, ""] + ~doc:"Enable console output to the physical display device next time this host boots" + ~params:[ + Ref _host, "host", "The host"; + ] + ~result:(display, "This host's physical display usage") + ~allowed_roles:_R_POOL_OP + () + +let disable_display = call + ~name:"disable_display" + ~lifecycle:[Published, rel_cream, ""] + ~doc:"Disable console output to the physical display device next time this host boots" + ~params:[ + Ref _host, "host", "The host"; + ] + ~result:(display, "This host's physical display usage") + ~allowed_roles:_R_POOL_OP + () + +let apply_guest_agent_config = call + ~name:"apply_guest_agent_config" + ~lifecycle:[Published, rel_dundee, ""] + ~doc:"Signal to the host that the pool-wide guest agent config has changed" + ~params:[ + Ref _host, "host", "The host"; + ] + ~hide_from_docs:true + ~allowed_roles:_R_POOL_ADMIN + () + +let mxgpu_vf_setup = call + ~name:"mxgpu_vf_setup" + ~lifecycle:[Published, rel_falcon, ""] + ~doc:"Ensure the driver (kernel module) for MxGPU is loaded on the host, and create PCI objects for any new PCI devices (virtual functions) that the module makes visible." + ~params:[ + Ref _host, "host", "The host"; + ] + ~hide_from_docs:true + ~pool_internal:true + ~allowed_roles:_R_VM_OP + () + +let allocate_resources_for_vm = call + ~name:"allocate_resources_for_vm" + ~lifecycle:[Published, rel_inverness, ""] + ~doc:"Reserves the resources for a VM by setting the 'scheduled_to_be_resident_on' fields" + ~params:[ + Ref _host, "self", "The host"; + Ref _vm, "vm", "The VM"; + Bool, "live", "Is this part of a live migration?" + ] + ~hide_from_docs:true + ~allowed_roles:_R_VM_OP + () + +let set_iscsi_iqn = call ~name:"set_iscsi_iqn" ~lifecycle:[Published, rel_kolkata, ""] ~doc:"Sets the initiator IQN for the host" @@ -1257,7 +1257,7 @@ let host_query_ha = call ~flags:[`Session] ~allowed_roles:_R_POOL_OP () - let set_multipathing = call +let set_multipathing = call ~name:"set_multipathing" ~lifecycle:[Published, rel_kolkata, ""] ~doc:"Specifies whether multipathing is enabled" @@ -1268,176 +1268,176 @@ let host_query_ha = call ~flags:[`Session] ~allowed_roles:_R_POOL_OP () - (** Hosts *) - let t = - create_obj ~in_db:true ~in_product_since:rel_rio ~in_oss_since:oss_since_303 ~internal_deprecated_since:None ~persist:PersistEverything ~gen_constructor_destructor:false ~name:_host ~descr:"A physical host" ~gen_events:true - ~doccomments:[] - ~messages_default_allowed_roles:_R_POOL_OP - ~messages: [ - disable; - enable; - shutdown; - reboot; - prepare_for_poweroff; - dmesg; - dmesg_clear; - get_log; - send_debug_keys; - bugreport_upload; - list_methods; - license_apply; - license_add; - license_remove; - create; - destroy; - power_on; - set_license_params; - emergency_ha_disable; - ha_disarm_fencing; - preconfigure_ha; - ha_join_liveset; - ha_disable_failover_decisions; - ha_wait_for_shutdown_via_statefile; - ha_stop_daemon; - ha_release_resources; - ha_xapi_healthcheck; - local_assert_healthy; - request_backup; - request_config_file_sync; - propose_new_master; - commit_new_master; - abort_new_master; - get_data_sources; - record_data_source; - query_data_source; - forget_data_source_archives; - assert_can_evacuate; - get_vms_which_prevent_evacuation; - get_uncooperative_resident_VMs; - get_uncooperative_domains; - evacuate; - signal_networking_change; - notify; - syslog_reconfigure; - management_reconfigure; - local_management_reconfigure; - management_disable; - get_management_interface; - get_system_status_capabilities; - get_diagnostic_timing_stats; - restart_agent; - shutdown_agent; - set_hostname_live; - is_in_emergency_mode; - compute_free_memory; - compute_memory_overhead; - tickle_heartbeat; - sync_data; - backup_rrds; - create_new_blob; - call_plugin; - has_extension; - call_extension; - get_servertime; - get_server_localtime; - enable_binary_storage; - disable_binary_storage; - enable_external_auth; - disable_external_auth; - retrieve_wlb_evacuate_recommendations; - certificate_install; - certificate_uninstall; - certificate_list; - crl_install; - crl_uninstall; - crl_list; - certificate_sync; - get_server_certificate; - update_pool_secret; - update_master; - attach_static_vdis; - detach_static_vdis; - set_localdb_key; - apply_edition; - refresh_pack_info; - set_power_on_mode; - set_cpu_features; - reset_cpu_features; - reset_networking; - enable_local_storage_caching; - disable_local_storage_caching; - get_sm_diagnostics; - get_thread_diagnostics; - sm_dp_destroy; - sync_vlans; - sync_tunnels; - sync_pif_currently_attached; - migrate_receive; - declare_dead; - enable_display; - disable_display; - set_ssl_legacy; - apply_guest_agent_config; - mxgpu_vf_setup; - allocate_resources_for_vm; - set_iscsi_iqn; - set_multipathing; - ] - ~contents: - ([ uid _host; - namespace ~name:"name" ~contents:(names None RW) (); - namespace ~name:"memory" ~contents:host_memory (); - ] @ (allowed_and_current_operations operations) @ [ - namespace ~name:"API_version" ~contents:api_version (); - field ~qualifier:DynamicRO ~ty:Bool "enabled" "True if the host is currently enabled"; - field ~qualifier:StaticRO ~ty:(Map(String, String)) "software_version" "version strings"; - field ~ty:(Map(String, String)) "other_config" "additional configuration" ~map_keys_roles:[("folder",(_R_VM_OP));("XenCenter.CustomFields.*",(_R_VM_OP))]; - field ~qualifier:StaticRO ~ty:(Set(String)) "capabilities" "Xen capabilities"; - field ~qualifier:DynamicRO ~ty:(Map(String, String)) "cpu_configuration" "The CPU configuration on this host. May contain keys such as \"nr_nodes\", \"sockets_per_node\", \"cores_per_socket\", or \"threads_per_core\""; - field ~qualifier:DynamicRO ~ty:String "sched_policy" "Scheduler policy currently in force on this host"; - field ~qualifier:DynamicRO ~ty:(Set String) "supported_bootloaders" "a list of the bootloaders installed on the machine"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _vm)) "resident_VMs" "list of VMs currently resident on host"; - field ~qualifier:RW ~ty:(Map(String, String)) "logging" "logging configuration"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _pif)) ~doc_tags:[Networking] "PIFs" "physical network interfaces"; - field ~qualifier:RW ~ty:(Ref _sr) "suspend_image_sr" "The SR in which VDIs for suspend images are created"; - field ~qualifier:RW ~ty:(Ref _sr) "crash_dump_sr" "The SR in which VDIs for crash dumps are created"; - field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Set (Ref _host_crashdump)) "crashdumps" "Set of host crash dumps"; - field ~in_oss_since:None ~internal_deprecated_since:rel_ely ~qualifier:DynamicRO ~ty:(Set (Ref _host_patch)) "patches" "Set of host patches"; - field ~in_oss_since:None ~in_product_since:rel_ely ~qualifier:DynamicRO ~ty:(Set (Ref _pool_update)) "updates" "Set of updates"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _pbd)) "PBDs" "physical blockdevices"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _hostcpu)) "host_CPUs" "The physical CPUs on this host"; - field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "cpu_info" "Details about the physical CPUs on this host"; - field ~in_oss_since:None ~qualifier:RW ~ty:String ~doc_tags:[Networking] "hostname" "The hostname of this host"; - field ~in_oss_since:None ~qualifier:RW ~ty:String ~doc_tags:[Networking] "address" "The address by which this host can be contacted from any other host in the pool"; - field ~qualifier:DynamicRO ~ty:(Ref _host_metrics) "metrics" "metrics associated with this host"; - field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Map (String,String)) "license_params" "State of the current license"; - field ~in_oss_since:None ~internal_only:true ~qualifier:DynamicRO ~ty:Int "boot_free_mem" "Free memory on host at boot time"; - field ~in_oss_since:None ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Set String) ~default_value:(Some (VSet [])) "ha_statefiles" "The set of statefiles accessible from this host"; - field ~in_oss_since:None ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Set String) ~default_value:(Some (VSet [])) "ha_network_peers" "The set of hosts visible via the network from this host"; - field ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Map(String,Ref _blob)) ~default_value:(Some (VMap [])) "blobs" "Binary blobs associated with this host"; - field ~writer_roles:_R_VM_OP ~qualifier:RW ~in_product_since:rel_orlando ~default_value:(Some (VSet [])) ~ty:(Set String) "tags" "user-specified tags for categorization purposes"; - field ~qualifier:DynamicRO ~in_product_since:rel_george ~default_value:(Some (VString "")) ~ty:String "external_auth_type" "type of external authentication service configured; empty if none configured."; - field ~qualifier:DynamicRO ~in_product_since:rel_george ~default_value:(Some (VString "")) ~ty:String "external_auth_service_name" "name of external authentication service configured; empty if none configured."; - field ~qualifier:DynamicRO ~in_product_since:rel_george ~default_value:(Some (VMap [])) ~ty:(Map (String,String)) "external_auth_configuration" "configuration specific to external authentication service"; - field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VString "")) ~ty:String "edition" "Product edition"; - field ~qualifier:RW ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [VString "address", VString "localhost"; VString "port", VString "27000"])) ~ty:(Map (String, String)) "license_server" "Contact information of the license server"; - field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map (String,String)) "bios_strings" "BIOS strings"; - field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VString "")) ~ty:String "power_on_mode" "The power on mode"; - field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "power_on_config" "The power on config"; - field ~qualifier:StaticRO ~in_product_since:rel_cowley ~default_value:(Some (VRef null_ref)) ~ty:(Ref _sr) "local_cache_sr" "The SR that is used as a local cache"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Map (String, String)) ~default_value:(Some (VMap [])) - "chipset_info" "Information about chipset features"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _pci)) "PCIs" "List of PCI devices in the host"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _pgpu)) "PGPUs" "List of physical GPUs in the host"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_inverness, ""] ~ty:(Set (Ref _pusb)) "PUSBs" "List of physical USBs in the host"; - field ~qualifier:StaticRO ~lifecycle:[Published, rel_dundee, ""] ~ty:Bool ~default_value:(Some (VBool true)) "ssl_legacy" "Allow SSLv3 protocol and ciphersuites as used by older XenServers. This controls both incoming and outgoing connections. When this is set to a different value, the host immediately restarts its SSL/TLS listening service; typically this takes less than a second but existing connections to it will be broken. XenAPI login sessions will remain valid."; - field ~qualifier:RW ~in_product_since:rel_tampa ~default_value:(Some (VMap [])) ~ty:(Map (String, String)) "guest_VCPUs_params" "VCPUs params to apply to all resident guests"; - field ~qualifier:RW ~in_product_since:rel_cream ~default_value:(Some (VEnum "enabled")) ~ty:display "display" "indicates whether the host is configured to output its console to a physical display device"; - field ~qualifier:DynamicRO ~in_product_since:rel_cream ~default_value:(Some (VSet [VInt 0L])) ~ty:(Set (Int)) "virtual_hardware_platform_versions" "The set of versions of the virtual hardware platform that the host can offer to its guests"; - field ~qualifier:DynamicRO ~default_value:(Some (VRef null_ref)) ~in_product_since:rel_ely ~ty:(Ref _vm) "control_domain" "The control domain (domain 0)"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_ely, ""] ~ty:(Set (Ref _pool_update)) ~ignore_foreign_key:true "updates_requiring_reboot" "List of updates which require reboot"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_falcon, ""] ~ty:(Set (Ref _feature)) "features" "List of features available on this host"; - field ~qualifier:StaticRO ~lifecycle:[Published, rel_kolkata, ""] ~default_value:(Some (VString "")) ~ty:String "iscsi_iqn" "The initiator IQN for the host"; - field ~qualifier:StaticRO ~lifecycle:[Published, rel_kolkata, ""] ~default_value:(Some (VBool false)) ~ty:Bool "multipathing" "Specifies whether multipathing is enabled"; - ]) - () +(** Hosts *) +let t = + create_obj ~in_db:true ~in_product_since:rel_rio ~in_oss_since:oss_since_303 ~internal_deprecated_since:None ~persist:PersistEverything ~gen_constructor_destructor:false ~name:_host ~descr:"A physical host" ~gen_events:true + ~doccomments:[] + ~messages_default_allowed_roles:_R_POOL_OP + ~messages: [ + disable; + enable; + shutdown; + reboot; + prepare_for_poweroff; + dmesg; + dmesg_clear; + get_log; + send_debug_keys; + bugreport_upload; + list_methods; + license_apply; + license_add; + license_remove; + create; + destroy; + power_on; + set_license_params; + emergency_ha_disable; + ha_disarm_fencing; + preconfigure_ha; + ha_join_liveset; + ha_disable_failover_decisions; + ha_wait_for_shutdown_via_statefile; + ha_stop_daemon; + ha_release_resources; + ha_xapi_healthcheck; + local_assert_healthy; + request_backup; + request_config_file_sync; + propose_new_master; + commit_new_master; + abort_new_master; + get_data_sources; + record_data_source; + query_data_source; + forget_data_source_archives; + assert_can_evacuate; + get_vms_which_prevent_evacuation; + get_uncooperative_resident_VMs; + get_uncooperative_domains; + evacuate; + signal_networking_change; + notify; + syslog_reconfigure; + management_reconfigure; + local_management_reconfigure; + management_disable; + get_management_interface; + get_system_status_capabilities; + get_diagnostic_timing_stats; + restart_agent; + shutdown_agent; + set_hostname_live; + is_in_emergency_mode; + compute_free_memory; + compute_memory_overhead; + tickle_heartbeat; + sync_data; + backup_rrds; + create_new_blob; + call_plugin; + has_extension; + call_extension; + get_servertime; + get_server_localtime; + enable_binary_storage; + disable_binary_storage; + enable_external_auth; + disable_external_auth; + retrieve_wlb_evacuate_recommendations; + certificate_install; + certificate_uninstall; + certificate_list; + crl_install; + crl_uninstall; + crl_list; + certificate_sync; + get_server_certificate; + update_pool_secret; + update_master; + attach_static_vdis; + detach_static_vdis; + set_localdb_key; + apply_edition; + refresh_pack_info; + set_power_on_mode; + set_cpu_features; + reset_cpu_features; + reset_networking; + enable_local_storage_caching; + disable_local_storage_caching; + get_sm_diagnostics; + get_thread_diagnostics; + sm_dp_destroy; + sync_vlans; + sync_tunnels; + sync_pif_currently_attached; + migrate_receive; + declare_dead; + enable_display; + disable_display; + set_ssl_legacy; + apply_guest_agent_config; + mxgpu_vf_setup; + allocate_resources_for_vm; + set_iscsi_iqn; + set_multipathing; + ] + ~contents: + ([ uid _host; + namespace ~name:"name" ~contents:(names None RW) (); + namespace ~name:"memory" ~contents:host_memory (); + ] @ (allowed_and_current_operations operations) @ [ + namespace ~name:"API_version" ~contents:api_version (); + field ~qualifier:DynamicRO ~ty:Bool "enabled" "True if the host is currently enabled"; + field ~qualifier:StaticRO ~ty:(Map(String, String)) "software_version" "version strings"; + field ~ty:(Map(String, String)) "other_config" "additional configuration" ~map_keys_roles:[("folder",(_R_VM_OP));("XenCenter.CustomFields.*",(_R_VM_OP))]; + field ~qualifier:StaticRO ~ty:(Set(String)) "capabilities" "Xen capabilities"; + field ~qualifier:DynamicRO ~ty:(Map(String, String)) "cpu_configuration" "The CPU configuration on this host. May contain keys such as \"nr_nodes\", \"sockets_per_node\", \"cores_per_socket\", or \"threads_per_core\""; + field ~qualifier:DynamicRO ~ty:String "sched_policy" "Scheduler policy currently in force on this host"; + field ~qualifier:DynamicRO ~ty:(Set String) "supported_bootloaders" "a list of the bootloaders installed on the machine"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _vm)) "resident_VMs" "list of VMs currently resident on host"; + field ~qualifier:RW ~ty:(Map(String, String)) "logging" "logging configuration"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _pif)) ~doc_tags:[Networking] "PIFs" "physical network interfaces"; + field ~qualifier:RW ~ty:(Ref _sr) "suspend_image_sr" "The SR in which VDIs for suspend images are created"; + field ~qualifier:RW ~ty:(Ref _sr) "crash_dump_sr" "The SR in which VDIs for crash dumps are created"; + field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Set (Ref _host_crashdump)) "crashdumps" "Set of host crash dumps"; + field ~in_oss_since:None ~internal_deprecated_since:rel_ely ~qualifier:DynamicRO ~ty:(Set (Ref _host_patch)) "patches" "Set of host patches"; + field ~in_oss_since:None ~in_product_since:rel_ely ~qualifier:DynamicRO ~ty:(Set (Ref _pool_update)) "updates" "Set of updates"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _pbd)) "PBDs" "physical blockdevices"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _hostcpu)) "host_CPUs" "The physical CPUs on this host"; + field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "cpu_info" "Details about the physical CPUs on this host"; + field ~in_oss_since:None ~qualifier:RW ~ty:String ~doc_tags:[Networking] "hostname" "The hostname of this host"; + field ~in_oss_since:None ~qualifier:RW ~ty:String ~doc_tags:[Networking] "address" "The address by which this host can be contacted from any other host in the pool"; + field ~qualifier:DynamicRO ~ty:(Ref _host_metrics) "metrics" "metrics associated with this host"; + field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Map (String,String)) "license_params" "State of the current license"; + field ~in_oss_since:None ~internal_only:true ~qualifier:DynamicRO ~ty:Int "boot_free_mem" "Free memory on host at boot time"; + field ~in_oss_since:None ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Set String) ~default_value:(Some (VSet [])) "ha_statefiles" "The set of statefiles accessible from this host"; + field ~in_oss_since:None ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Set String) ~default_value:(Some (VSet [])) "ha_network_peers" "The set of hosts visible via the network from this host"; + field ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Map(String,Ref _blob)) ~default_value:(Some (VMap [])) "blobs" "Binary blobs associated with this host"; + field ~writer_roles:_R_VM_OP ~qualifier:RW ~in_product_since:rel_orlando ~default_value:(Some (VSet [])) ~ty:(Set String) "tags" "user-specified tags for categorization purposes"; + field ~qualifier:DynamicRO ~in_product_since:rel_george ~default_value:(Some (VString "")) ~ty:String "external_auth_type" "type of external authentication service configured; empty if none configured."; + field ~qualifier:DynamicRO ~in_product_since:rel_george ~default_value:(Some (VString "")) ~ty:String "external_auth_service_name" "name of external authentication service configured; empty if none configured."; + field ~qualifier:DynamicRO ~in_product_since:rel_george ~default_value:(Some (VMap [])) ~ty:(Map (String,String)) "external_auth_configuration" "configuration specific to external authentication service"; + field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VString "")) ~ty:String "edition" "Product edition"; + field ~qualifier:RW ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [VString "address", VString "localhost"; VString "port", VString "27000"])) ~ty:(Map (String, String)) "license_server" "Contact information of the license server"; + field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map (String,String)) "bios_strings" "BIOS strings"; + field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VString "")) ~ty:String "power_on_mode" "The power on mode"; + field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "power_on_config" "The power on config"; + field ~qualifier:StaticRO ~in_product_since:rel_cowley ~default_value:(Some (VRef null_ref)) ~ty:(Ref _sr) "local_cache_sr" "The SR that is used as a local cache"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Map (String, String)) ~default_value:(Some (VMap [])) + "chipset_info" "Information about chipset features"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _pci)) "PCIs" "List of PCI devices in the host"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _pgpu)) "PGPUs" "List of physical GPUs in the host"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_inverness, ""] ~ty:(Set (Ref _pusb)) "PUSBs" "List of physical USBs in the host"; + field ~qualifier:StaticRO ~lifecycle:[Published, rel_dundee, ""] ~ty:Bool ~default_value:(Some (VBool true)) "ssl_legacy" "Allow SSLv3 protocol and ciphersuites as used by older XenServers. This controls both incoming and outgoing connections. When this is set to a different value, the host immediately restarts its SSL/TLS listening service; typically this takes less than a second but existing connections to it will be broken. XenAPI login sessions will remain valid."; + field ~qualifier:RW ~in_product_since:rel_tampa ~default_value:(Some (VMap [])) ~ty:(Map (String, String)) "guest_VCPUs_params" "VCPUs params to apply to all resident guests"; + field ~qualifier:RW ~in_product_since:rel_cream ~default_value:(Some (VEnum "enabled")) ~ty:display "display" "indicates whether the host is configured to output its console to a physical display device"; + field ~qualifier:DynamicRO ~in_product_since:rel_cream ~default_value:(Some (VSet [VInt 0L])) ~ty:(Set (Int)) "virtual_hardware_platform_versions" "The set of versions of the virtual hardware platform that the host can offer to its guests"; + field ~qualifier:DynamicRO ~default_value:(Some (VRef null_ref)) ~in_product_since:rel_ely ~ty:(Ref _vm) "control_domain" "The control domain (domain 0)"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_ely, ""] ~ty:(Set (Ref _pool_update)) ~ignore_foreign_key:true "updates_requiring_reboot" "List of updates which require reboot"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_falcon, ""] ~ty:(Set (Ref _feature)) "features" "List of features available on this host"; + field ~qualifier:StaticRO ~lifecycle:[Published, rel_kolkata, ""] ~default_value:(Some (VString "")) ~ty:String "iscsi_iqn" "The initiator IQN for the host"; + field ~qualifier:StaticRO ~lifecycle:[Published, rel_kolkata, ""] ~default_value:(Some (VBool false)) ~ty:Bool "multipathing" "Specifies whether multipathing is enabled"; + ]) + () diff --git a/ocaml/idl/datamodel_pool.ml b/ocaml/idl/datamodel_pool.ml index f2200ba3a05..af2f7ebee1b 100644 --- a/ocaml/idl/datamodel_pool.ml +++ b/ocaml/idl/datamodel_pool.ml @@ -2,748 +2,748 @@ open Datamodel_common open Datamodel_roles open Datamodel_types - let operations = - Enum ("pool_allowed_operations", (* FIXME: This should really be called `pool_operations`, to avoid confusion with the Pool.allowed_operations field *) - [ "ha_enable", "Indicates this pool is in the process of enabling HA"; - "ha_disable", "Indicates this pool is in the process of disabling HA"; - "cluster_create", "Indicates this pool is in the process of creating a cluster"; - ]) - - let enable_ha = call - ~in_product_since:rel_miami - ~name:"enable_ha" - ~in_oss_since:None - ~versioned_params: - [{param_type=Set(Ref _sr); param_name="heartbeat_srs"; param_doc="Set of SRs to use for storage heartbeating"; param_release=miami_release; param_default=None }; - {param_type=Map(String, String); param_name="configuration"; param_doc="Detailed HA configuration to apply"; param_release=miami_release; param_default=None }; - ] - ~doc:"Turn on High Availability mode" - ~allowed_roles:_R_POOL_OP - () - - let disable_ha = call - ~in_product_since:rel_miami - ~name:"disable_ha" - ~in_oss_since:None - ~params:[] - ~doc:"Turn off High Availability mode" - ~allowed_roles:_R_POOL_OP - () - - let sync_database = call - ~name:"sync_database" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[] - ~doc:"Forcibly synchronise the database now" - ~allowed_roles:_R_POOL_OP - () - - let designate_new_master = call - ~in_product_since:rel_miami - ~name:"designate_new_master" - ~in_oss_since:None - ~params:[Ref _host, "host", "The host who should become the new master"] - ~doc:"Perform an orderly handover of the role of master to the referenced host." - ~allowed_roles:_R_POOL_OP - () - - let join = call - ~name:"join" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[String, "master_address", "The hostname of the master of the pool to join"; - String, "master_username", "The username of the master (for initial authentication)"; - String, "master_password", "The password for the master (for initial authentication)"; - ] - ~errs:[Api_errors.pool_joining_host_cannot_contain_shared_SRs] - ~doc:"Instruct host to join a new pool" - ~allowed_roles:_R_POOL_OP - () - - let join_force = call - ~name:"join_force" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[String, "master_address", "The hostname of the master of the pool to join"; - String, "master_username", "The username of the master (for initial authentication)"; - String, "master_password", "The password for the master (for initial authentication)"; - ] - ~doc:"Instruct host to join a new pool" - ~allowed_roles:_R_POOL_OP - () - - - let slave_reset_master = call ~flags:[`Session] - ~name:"emergency_reset_master" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[ - String, "master_address", "The hostname of the master"; +let operations = + Enum ("pool_allowed_operations", (* FIXME: This should really be called `pool_operations`, to avoid confusion with the Pool.allowed_operations field *) + [ "ha_enable", "Indicates this pool is in the process of enabling HA"; + "ha_disable", "Indicates this pool is in the process of disabling HA"; + "cluster_create", "Indicates this pool is in the process of creating a cluster"; + ]) + +let enable_ha = call + ~in_product_since:rel_miami + ~name:"enable_ha" + ~in_oss_since:None + ~versioned_params: + [{param_type=Set(Ref _sr); param_name="heartbeat_srs"; param_doc="Set of SRs to use for storage heartbeating"; param_release=miami_release; param_default=None }; + {param_type=Map(String, String); param_name="configuration"; param_doc="Detailed HA configuration to apply"; param_release=miami_release; param_default=None }; ] - ~doc:"Instruct a slave already in a pool that the master has changed" - ~allowed_roles:_R_POOL_OP - () - - let transition_to_master = call ~flags:[`Session] - ~name:"emergency_transition_to_master" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[] - ~doc:"Instruct host that's currently a slave to transition to being master" - ~allowed_roles:_R_POOL_OP - () - - let recover_slaves = call - ~name:"recover_slaves" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[] - ~result:(Set (Ref _host), "list of hosts whose master address were successfully reset") - ~doc:"Instruct a pool master, M, to try and contact its slaves and, if slaves are in emergency mode, reset their master address to M." - ~allowed_roles:_R_POOL_OP - () - - let eject = call - ~name:"eject" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[Ref _host, "host", "The host to eject"] - ~doc:"Instruct a pool master to eject a host from the pool" - ~allowed_roles:_R_POOL_OP - () - - let initial_auth = call - ~name:"initial_auth" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[] - ~result:(String, "") - ~doc:"Internal use only" - ~hide_from_docs:true - ~allowed_roles:_R_POOL_OP - () - - let create_VLAN_from_PIF = call - ~in_oss_since:None - ~in_product_since:rel_rio - ~name:"create_VLAN_from_PIF" - ~doc:"Create a pool-wide VLAN by taking the PIF." - ~params:[Ref _pif, "pif", "physical interface on any particular host, that identifies the PIF on which to create the (pool-wide) VLAN interface"; - Ref _network, "network", "network to which this interface should be connected"; - Int, "VLAN", "VLAN tag for the new interface"] - ~result:(Set (Ref _pif), "The references of the created PIF objects") - ~errs:[Api_errors.vlan_tag_invalid] - ~allowed_roles:_R_POOL_OP - () - - (* !! THIS IS BROKEN; it takes a device name which in the case of a bond is not homogeneous across all pool hosts. - See CA-22613. !! *) - let create_VLAN = call - ~in_oss_since:None - ~in_product_since:rel_rio - ~name:"create_VLAN" - ~doc:"Create PIFs, mapping a network to the same physical interface/VLAN on each host. This call is deprecated: use Pool.create_VLAN_from_PIF instead." - ~params:[String, "device", "physical interface on which to create the VLAN interface"; - Ref _network, "network", "network to which this interface should be connected"; - Int, "VLAN", "VLAN tag for the new interface"] - ~result:(Set (Ref _pif), "The references of the created PIF objects") - ~errs:[Api_errors.vlan_tag_invalid] - ~allowed_roles:_R_POOL_OP - () - - let management_reconfigure = call - ~name:"management_reconfigure" - ~in_oss_since:None - ~in_product_since:rel_inverness - ~params:[ - Ref _network, "network", "The network"; - ] - ~doc:"Reconfigure the management network interface for all Hosts in the Pool" - ~errs:[ Api_errors.ha_is_enabled; - Api_errors.pif_not_present; - Api_errors.cannot_plug_bond_slave; - Api_errors.pif_incompatible_primary_address_type; - Api_errors.pif_has_no_network_configuration; - Api_errors.pif_has_no_v6_network_configuration + ~doc:"Turn on High Availability mode" + ~allowed_roles:_R_POOL_OP + () + +let disable_ha = call + ~in_product_since:rel_miami + ~name:"disable_ha" + ~in_oss_since:None + ~params:[] + ~doc:"Turn off High Availability mode" + ~allowed_roles:_R_POOL_OP + () + +let sync_database = call + ~name:"sync_database" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[] + ~doc:"Forcibly synchronise the database now" + ~allowed_roles:_R_POOL_OP + () + +let designate_new_master = call + ~in_product_since:rel_miami + ~name:"designate_new_master" + ~in_oss_since:None + ~params:[Ref _host, "host", "The host who should become the new master"] + ~doc:"Perform an orderly handover of the role of master to the referenced host." + ~allowed_roles:_R_POOL_OP + () + +let join = call + ~name:"join" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[String, "master_address", "The hostname of the master of the pool to join"; + String, "master_username", "The username of the master (for initial authentication)"; + String, "master_password", "The password for the master (for initial authentication)"; ] - ~allowed_roles:_R_POOL_OP - () - - let hello_return = Enum("hello_return", [ - "ok", ""; - "unknown_host", ""; - "cannot_talk_back", "" - ]) - - let hello = call - ~name:"hello" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[String, "host_uuid", ""; - String, "host_address", "" - ] - ~result:(hello_return, "") - ~doc:"Internal use only" - ~hide_from_docs:true - ~allowed_roles:_R_POOL_OP - () - - let slave_network_report = call - ~name:"slave_network_report" - ~in_oss_since:None - ~in_product_since:rel_rio - ~doc:"Internal use only" - ~params:[Map (String, String), "phydevs", "(device,bridge) pairs of physical NICs on slave"; - Map (String, String), "dev_to_mac", "(device,mac) pairs of physical NICs on slave"; - Map (String, Int), "dev_to_mtu", "(device,mtu) pairs of physical NICs on slave"; - Ref _host, "slave_host", "the host that the PIFs will be attached to when created" - ] - ~result:(Set(Ref _pif), "refs for pifs corresponding to device list") - ~hide_from_docs:true - ~allowed_roles:_R_POOL_ADMIN - () - - let ping_slave = call ~flags:[`Session] - ~name:"is_slave" - ~in_oss_since:None - ~in_product_since:rel_rio - ~params:[Ref _host, "host", ""] - ~doc:"Internal use only" - ~result:(Bool, "returns false if pinged host is master [indicating critical error condition]; true if pinged host is slave") - ~hide_from_docs:true - ~allowed_roles:_R_POOL_ADMIN - () - - let ha_prevent_restarts_for = call ~flags:[`Session] - ~name:"ha_prevent_restarts_for" - ~in_product_since:rel_orlando_update_1 - ~doc:"When this call returns the VM restart logic will not run for the requested number of seconds. If the argument is zero then the restart thread is immediately unblocked" - ~params:[Int, "seconds", "The number of seconds to block the restart thread for"] - ~allowed_roles:_R_POOL_OP - () - - let ha_failover_plan_exists = call ~flags:[`Session] - ~name:"ha_failover_plan_exists" - ~in_product_since:rel_orlando - ~doc:"Returns true if a VM failover plan exists for up to 'n' host failures" - ~params:[Int, "n", "The number of host failures to plan for" ] - ~result:(Bool, "true if a failover plan exists for the supplied number of host failures") - ~allowed_roles:_R_POOL_OP - () - - let ha_compute_max_host_failures_to_tolerate = call ~flags:[`Session] - ~name:"ha_compute_max_host_failures_to_tolerate" - ~in_product_since:rel_orlando - ~doc:"Returns the maximum number of host failures we could tolerate before we would be unable to restart configured VMs" - ~params:[] - ~result:(Int, "maximum value for ha_host_failures_to_tolerate given current configuration") - ~allowed_roles:_R_POOL_OP - () - - let ha_compute_hypothetical_max_host_failures_to_tolerate = call ~flags:[`Session] - ~name:"ha_compute_hypothetical_max_host_failures_to_tolerate" - ~in_product_since:rel_orlando - ~doc:"Returns the maximum number of host failures we could tolerate before we would be unable to restart the provided VMs" - ~params:[ Map(Ref _vm, String), "configuration", "Map of protected VM reference to restart priority" ] - ~result:(Int, "maximum value for ha_host_failures_to_tolerate given provided configuration") - ~allowed_roles:_R_READ_ONLY - () - - let ha_compute_vm_failover_plan = call ~flags:[`Session] - ~name:"ha_compute_vm_failover_plan" - ~in_product_since:rel_orlando - ~doc:"Return a VM failover plan assuming a given subset of hosts fail" - ~params:[Set(Ref _host), "failed_hosts", "The set of hosts to assume have failed"; - Set(Ref _vm), "failed_vms", "The set of VMs to restart" ] - ~result:(Map(Ref _vm, Map(String, String)), "VM failover plan: a map of VM to host to restart the host on") - ~allowed_roles:_R_POOL_OP - () - - let create_new_blob = call - ~name: "create_new_blob" - ~in_product_since:rel_orlando - ~doc:"Create a placeholder for a named binary blob of data that is associated with this pool" - ~versioned_params: - [{param_type=Ref _pool; param_name="pool"; param_doc="The pool"; param_release=orlando_release; param_default=None}; - {param_type=String; param_name="name"; param_doc="The name associated with the blob"; param_release=orlando_release; param_default=None}; - {param_type=String; param_name="mime_type"; param_doc="The mime type for the data. Empty string translates to application/octet-stream"; param_release=orlando_release; param_default=None}; - {param_type=Bool; param_name="public"; param_doc="True if the blob should be publicly available"; param_release=tampa_release; param_default=Some (VBool false)} - ] - ~result:(Ref _blob, "The reference of the blob, needed for populating its data") - ~allowed_roles:_R_POOL_OP - () - - let set_ha_host_failures_to_tolerate = call - ~name:"set_ha_host_failures_to_tolerate" - ~in_product_since:rel_orlando - ~doc:"Set the maximum number of host failures to consider in the HA VM restart planner" - ~params:[Ref _pool, "self", "The pool"; - Int, "value", "New number of host failures to consider"] - ~allowed_roles:_R_POOL_OP - () - - let ha_schedule_plan_recomputation = call - ~name:"ha_schedule_plan_recomputation" - ~in_product_since:rel_orlando - ~doc:"Signal that the plan should be recomputed (eg a host has come online)" - ~params:[] - ~hide_from_docs:true - ~pool_internal:true - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let enable_binary_storage = call - ~name:"enable_binary_storage" - ~in_product_since:rel_orlando - ~hide_from_docs:true - ~doc:"Enable the storage of larger objects, such as RRDs, messages and binary blobs across all hosts in the pool" - ~params:[] - ~allowed_roles:_R_POOL_OP - () - - let disable_binary_storage = call - ~name:"disable_binary_storage" - ~in_product_since:rel_orlando - ~hide_from_docs:true - ~doc:"Disable the storage of larger objects, such as RRDs, messages and binary blobs across all hosts in the pool. This will destroy all of these objects where they exist." - ~params:[] - ~allowed_roles:_R_POOL_OP - () - - let enable_external_auth = call ~flags:[`Session] - ~name:"enable_external_auth" - ~in_oss_since:None - ~in_product_since:rel_george - ~params:[ - Ref _pool, "pool", "The pool whose external authentication should be enabled"; - Map (String,String), "config", "A list of key-values containing the configuration data" ; - String, "service_name", "The name of the service" ; - String, "auth_type", "The type of authentication (e.g. AD for Active Directory)" - ] - ~doc:"This call enables external authentication on all the hosts of the pool" - ~allowed_roles:_R_POOL_ADMIN - () - - let disable_external_auth = call ~flags:[`Session] - ~name:"disable_external_auth" - ~in_oss_since:None - ~in_product_since:rel_george - ~versioned_params:[ - {param_type=Ref _pool; param_name="pool"; param_doc="The pool whose external authentication should be disabled"; param_release=george_release; param_default=None}; - {param_type=Map (String, String); param_name="config"; param_doc="Optional parameters as a list of key-values containing the configuration data"; param_release=george_release; param_default=Some (VMap [])} - ] - ~doc:"This call disables external authentication on all the hosts of the pool" - ~allowed_roles:_R_POOL_ADMIN - () - - let detect_nonhomogeneous_external_auth = call ~flags:[`Session] - ~name:"detect_nonhomogeneous_external_auth" - ~in_oss_since:None - ~in_product_since:rel_george - ~params:[ - Ref _pool, "pool", "The pool where to detect non-homogeneous external authentication configuration"; - ] - ~doc:"This call asynchronously detects if the external authentication configuration in any slave is different from that in the master and raises appropriate alerts" - ~allowed_roles:_R_POOL_OP - () - - let initialize_wlb = call - ~name:"initialize_wlb" - ~in_product_since:rel_george - ~doc:"Initializes workload balancing monitoring on this pool with the specified wlb server" - ~params:[String, "wlb_url", "The ip address and port to use when accessing the wlb server"; - String, "wlb_username", "The username used to authenticate with the wlb server"; - String, "wlb_password", "The password used to authenticate with the wlb server"; - String, "xenserver_username", "The username used by the wlb server to authenticate with the xenserver"; - String, "xenserver_password", "The password used by the wlb server to authenticate with the xenserver"] - ~allowed_roles:_R_POOL_OP - () - - let deconfigure_wlb = call - ~name:"deconfigure_wlb" - ~in_product_since:rel_george - ~doc:"Permanently deconfigures workload balancing monitoring on this pool" - ~params:[] - ~allowed_roles:_R_POOL_OP - () - - let send_wlb_configuration = call - ~name:"send_wlb_configuration" - ~in_product_since:rel_george - ~doc:"Sets the pool optimization criteria for the workload balancing server" - ~params:[Map(String, String), "config", "The configuration to use in optimizing this pool"] - ~allowed_roles:_R_POOL_OP - () - - let retrieve_wlb_configuration = call - ~name:"retrieve_wlb_configuration" - ~in_product_since:rel_george - ~doc:"Retrieves the pool optimization criteria from the workload balancing server" - ~params:[] - ~result:(Map(String,String), "The configuration used in optimizing this pool") - ~allowed_roles:_R_READ_ONLY - () - - let retrieve_wlb_recommendations = call - ~name:"retrieve_wlb_recommendations" - ~in_product_since:rel_george - ~doc:"Retrieves vm migrate recommendations for the pool from the workload balancing server" - ~params:[] - ~result:(Map(Ref _vm,Set(String)), "The list of vm migration recommendations") - ~allowed_roles:_R_READ_ONLY - () - - let send_test_post = call - ~name:"send_test_post" - ~in_product_since:rel_george - ~doc:"Send the given body to the given host and port, using HTTPS, and print the response. This is used for debugging the SSL layer." - ~params:[(String, "host", ""); (Int, "port", ""); (String, "body", "")] - ~result:(String, "The response") - ~allowed_roles:_R_POOL_ADMIN - () - - let certificate_install = call - ~in_oss_since:None - ~in_product_since:rel_george - ~name:"certificate_install" - ~doc:"Install an SSL certificate pool-wide." - ~params:[String, "name", "A name to give the certificate"; - String, "cert", "The certificate"] - ~allowed_roles:_R_POOL_OP - () - - let certificate_uninstall = call - ~in_oss_since:None - ~in_product_since:rel_george - ~name:"certificate_uninstall" - ~doc:"Remove an SSL certificate." - ~params:[String, "name", "The certificate name"] - ~allowed_roles:_R_POOL_OP - () - - let certificate_list = call - ~in_oss_since:None - ~in_product_since:rel_george - ~name:"certificate_list" - ~doc:"List all installed SSL certificates." - ~result:(Set(String),"All installed certificates") - ~allowed_roles:_R_POOL_OP - () - - let crl_install = call - ~in_oss_since:None - ~in_product_since:rel_george - ~name:"crl_install" - ~doc:"Install an SSL certificate revocation list, pool-wide." - ~params:[String, "name", "A name to give the CRL"; - String, "cert", "The CRL"] - ~allowed_roles:_R_POOL_OP - () - - let crl_uninstall = call - ~in_oss_since:None - ~in_product_since:rel_george - ~name:"crl_uninstall" - ~doc:"Remove an SSL certificate revocation list." - ~params:[String, "name", "The CRL name"] - ~allowed_roles:_R_POOL_OP - () - - let crl_list = call - ~in_oss_since:None - ~in_product_since:rel_george - ~name:"crl_list" - ~doc:"List all installed SSL certificate revocation lists." - ~result:(Set(String), "All installed CRLs") - ~allowed_roles:_R_POOL_OP - () - - let certificate_sync = call - ~in_oss_since:None - ~in_product_since:rel_george - ~name:"certificate_sync" - ~doc:"Sync SSL certificates from master to slaves." - ~allowed_roles:_R_POOL_OP - () - - let enable_redo_log = call - ~in_oss_since:None - ~in_product_since:rel_midnight_ride - ~name:"enable_redo_log" - ~params:[Ref _sr, "sr", "SR to hold the redo log."] - ~doc:"Enable the redo log on the given SR and start using it, unless HA is enabled." - ~allowed_roles:_R_POOL_OP - () - - let disable_redo_log = call - ~in_oss_since:None - ~in_product_since:rel_midnight_ride - ~name:"disable_redo_log" - ~doc:"Disable the redo log if in use, unless HA is enabled." - ~allowed_roles:_R_POOL_OP - () - - let audit_log_append = call - ~in_oss_since:None - ~pool_internal:true - ~hide_from_docs:true - ~in_product_since:rel_midnight_ride - ~name:"audit_log_append" - ~params:[String, "line", "line to be appended to the audit log"] - ~doc:"Append a line to the audit log on the master." - ~allowed_roles:_R_POOL_ADMIN - () - - let set_vswitch_controller = call - ~in_oss_since:None - ~in_product_since:rel_midnight_ride - ~lifecycle:[ - Published, rel_midnight_ride, "Set the IP address of the vswitch controller."; - Extended, rel_cowley, "Allow to be set to the empty string (no controller is used)."; - Deprecated, rel_falcon, "Deprecated: use 'SDN_controller.introduce' and 'SDN_controller.forget' instead."] - ~name:"set_vswitch_controller" - ~params:[String, "address", "IP address of the vswitch controller."] - ~doc:"Set the IP address of the vswitch controller." - ~allowed_roles:_R_POOL_OP - () - - let test_archive_target = call ~flags:[`Session] - ~name:"test_archive_target" - ~in_oss_since:None - ~in_product_since:rel_cowley - ~params:[Ref _pool, "self", "Reference to the pool"; - Map(String,String), "config", "Location config settings to test"; - ] - ~doc:"This call tests if a location is valid" - ~allowed_roles:_R_POOL_OP - ~result:(String, "An XMLRPC result") - () - - let enable_local_storage_caching = call - ~name:"enable_local_storage_caching" - ~in_oss_since:None - ~in_product_since:rel_cowley - ~params:[Ref _pool, "self", "Reference to the pool"] - ~doc:"This call attempts to enable pool-wide local storage caching" - ~allowed_roles:_R_POOL_OP - () - - let disable_local_storage_caching = call - ~name:"disable_local_storage_caching" - ~in_oss_since:None - ~in_product_since:rel_cowley - ~params:[Ref _pool, "self", "Reference to the pool"] - ~doc:"This call disables pool-wide local storage caching" - ~allowed_roles:_R_POOL_OP - () - - let get_license_state = call - ~name:"get_license_state" - ~in_oss_since:None - ~in_product_since:rel_clearwater - ~params:[Ref _pool, "self", "Reference to the pool"] - ~doc:"This call returns the license state for the pool" - ~allowed_roles:_R_READ_ONLY - ~result:(Map(String,String), "The pool's license state") - () - - let apply_edition = call - ~name:"apply_edition" - ~in_oss_since:None - ~in_product_since:rel_clearwater - ~params:[ - Ref _pool, "self", "Reference to the pool"; - String, "edition", "The requested edition"; - ] - ~doc:"Apply an edition to all hosts in the pool" - ~allowed_roles:_R_POOL_OP - () - - let enable_ssl_legacy = call - ~name:"enable_ssl_legacy" - ~in_oss_since:None - ~lifecycle:[ - Published, rel_dundee, ""; - ] - ~params:[Ref _pool, "self", "(ignored)";] - ~doc:"Sets ssl_legacy true on each host, pool-master last. See Host.ssl_legacy and Host.set_ssl_legacy." - ~allowed_roles:_R_POOL_OP - () - - let disable_ssl_legacy = call - ~name:"disable_ssl_legacy" - ~in_oss_since:None - ~lifecycle:[ - Published, rel_dundee, ""; - ] - ~params:[Ref _pool, "self", "(ignored)";] - ~doc:"Sets ssl_legacy true on each host, pool-master last. See Host.ssl_legacy and Host.set_ssl_legacy." - ~allowed_roles:_R_POOL_OP - () - - let set_igmp_snooping_enabled = call - ~in_oss_since:None - ~lifecycle:[ - Published, rel_inverness, "Enable or disable IGMP Snooping on the pool."; - ] - ~name:"set_igmp_snooping_enabled" - ~params:[ - Ref _pool, "self", "The pool"; - Bool, "value", "Enable or disable IGMP Snooping on the pool" - ] - ~doc:"Enable or disable IGMP Snooping on the pool." - ~allowed_roles:_R_POOL_OP - () - - let has_extension = call - ~name:"has_extension" - ~in_product_since:rel_dundee - ~doc:"Return true if the extension is available on the pool" - ~params:[ - Ref _pool, "self", "The pool"; - String, "name", "The name of the API call" - ] - ~result:(Bool, "True if the extension exists, false otherwise") - ~allowed_roles:_R_POOL_ADMIN - () - - let add_to_guest_agent_config = call - ~name:"add_to_guest_agent_config" - ~in_product_since:rel_dundee - ~doc:"Add a key-value pair to the pool-wide guest agent configuration" - ~params:[ - Ref _pool, "self", "The pool"; - String, "key", "The key to add"; - String, "value", "The value to add"; + ~errs:[Api_errors.pool_joining_host_cannot_contain_shared_SRs] + ~doc:"Instruct host to join a new pool" + ~allowed_roles:_R_POOL_OP + () + +let join_force = call + ~name:"join_force" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[String, "master_address", "The hostname of the master of the pool to join"; + String, "master_username", "The username of the master (for initial authentication)"; + String, "master_password", "The password for the master (for initial authentication)"; + ] + ~doc:"Instruct host to join a new pool" + ~allowed_roles:_R_POOL_OP + () + + +let slave_reset_master = call ~flags:[`Session] + ~name:"emergency_reset_master" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[ + String, "master_address", "The hostname of the master"; + ] + ~doc:"Instruct a slave already in a pool that the master has changed" + ~allowed_roles:_R_POOL_OP + () + +let transition_to_master = call ~flags:[`Session] + ~name:"emergency_transition_to_master" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[] + ~doc:"Instruct host that's currently a slave to transition to being master" + ~allowed_roles:_R_POOL_OP + () + +let recover_slaves = call + ~name:"recover_slaves" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[] + ~result:(Set (Ref _host), "list of hosts whose master address were successfully reset") + ~doc:"Instruct a pool master, M, to try and contact its slaves and, if slaves are in emergency mode, reset their master address to M." + ~allowed_roles:_R_POOL_OP + () + +let eject = call + ~name:"eject" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[Ref _host, "host", "The host to eject"] + ~doc:"Instruct a pool master to eject a host from the pool" + ~allowed_roles:_R_POOL_OP + () + +let initial_auth = call + ~name:"initial_auth" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[] + ~result:(String, "") + ~doc:"Internal use only" + ~hide_from_docs:true + ~allowed_roles:_R_POOL_OP + () + +let create_VLAN_from_PIF = call + ~in_oss_since:None + ~in_product_since:rel_rio + ~name:"create_VLAN_from_PIF" + ~doc:"Create a pool-wide VLAN by taking the PIF." + ~params:[Ref _pif, "pif", "physical interface on any particular host, that identifies the PIF on which to create the (pool-wide) VLAN interface"; + Ref _network, "network", "network to which this interface should be connected"; + Int, "VLAN", "VLAN tag for the new interface"] + ~result:(Set (Ref _pif), "The references of the created PIF objects") + ~errs:[Api_errors.vlan_tag_invalid] + ~allowed_roles:_R_POOL_OP + () + +(* !! THIS IS BROKEN; it takes a device name which in the case of a bond is not homogeneous across all pool hosts. + See CA-22613. !! *) +let create_VLAN = call + ~in_oss_since:None + ~in_product_since:rel_rio + ~name:"create_VLAN" + ~doc:"Create PIFs, mapping a network to the same physical interface/VLAN on each host. This call is deprecated: use Pool.create_VLAN_from_PIF instead." + ~params:[String, "device", "physical interface on which to create the VLAN interface"; + Ref _network, "network", "network to which this interface should be connected"; + Int, "VLAN", "VLAN tag for the new interface"] + ~result:(Set (Ref _pif), "The references of the created PIF objects") + ~errs:[Api_errors.vlan_tag_invalid] + ~allowed_roles:_R_POOL_OP + () + +let management_reconfigure = call + ~name:"management_reconfigure" + ~in_oss_since:None + ~in_product_since:rel_inverness + ~params:[ + Ref _network, "network", "The network"; + ] + ~doc:"Reconfigure the management network interface for all Hosts in the Pool" + ~errs:[ Api_errors.ha_is_enabled; + Api_errors.pif_not_present; + Api_errors.cannot_plug_bond_slave; + Api_errors.pif_incompatible_primary_address_type; + Api_errors.pif_has_no_network_configuration; + Api_errors.pif_has_no_v6_network_configuration + ] + ~allowed_roles:_R_POOL_OP + () + +let hello_return = Enum("hello_return", [ + "ok", ""; + "unknown_host", ""; + "cannot_talk_back", "" + ]) + +let hello = call + ~name:"hello" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[String, "host_uuid", ""; + String, "host_address", "" + ] + ~result:(hello_return, "") + ~doc:"Internal use only" + ~hide_from_docs:true + ~allowed_roles:_R_POOL_OP + () + +let slave_network_report = call + ~name:"slave_network_report" + ~in_oss_since:None + ~in_product_since:rel_rio + ~doc:"Internal use only" + ~params:[Map (String, String), "phydevs", "(device,bridge) pairs of physical NICs on slave"; + Map (String, String), "dev_to_mac", "(device,mac) pairs of physical NICs on slave"; + Map (String, Int), "dev_to_mtu", "(device,mtu) pairs of physical NICs on slave"; + Ref _host, "slave_host", "the host that the PIFs will be attached to when created" + ] + ~result:(Set(Ref _pif), "refs for pifs corresponding to device list") + ~hide_from_docs:true + ~allowed_roles:_R_POOL_ADMIN + () + +let ping_slave = call ~flags:[`Session] + ~name:"is_slave" + ~in_oss_since:None + ~in_product_since:rel_rio + ~params:[Ref _host, "host", ""] + ~doc:"Internal use only" + ~result:(Bool, "returns false if pinged host is master [indicating critical error condition]; true if pinged host is slave") + ~hide_from_docs:true + ~allowed_roles:_R_POOL_ADMIN + () + +let ha_prevent_restarts_for = call ~flags:[`Session] + ~name:"ha_prevent_restarts_for" + ~in_product_since:rel_orlando_update_1 + ~doc:"When this call returns the VM restart logic will not run for the requested number of seconds. If the argument is zero then the restart thread is immediately unblocked" + ~params:[Int, "seconds", "The number of seconds to block the restart thread for"] + ~allowed_roles:_R_POOL_OP + () + +let ha_failover_plan_exists = call ~flags:[`Session] + ~name:"ha_failover_plan_exists" + ~in_product_since:rel_orlando + ~doc:"Returns true if a VM failover plan exists for up to 'n' host failures" + ~params:[Int, "n", "The number of host failures to plan for" ] + ~result:(Bool, "true if a failover plan exists for the supplied number of host failures") + ~allowed_roles:_R_POOL_OP + () + +let ha_compute_max_host_failures_to_tolerate = call ~flags:[`Session] + ~name:"ha_compute_max_host_failures_to_tolerate" + ~in_product_since:rel_orlando + ~doc:"Returns the maximum number of host failures we could tolerate before we would be unable to restart configured VMs" + ~params:[] + ~result:(Int, "maximum value for ha_host_failures_to_tolerate given current configuration") + ~allowed_roles:_R_POOL_OP + () + +let ha_compute_hypothetical_max_host_failures_to_tolerate = call ~flags:[`Session] + ~name:"ha_compute_hypothetical_max_host_failures_to_tolerate" + ~in_product_since:rel_orlando + ~doc:"Returns the maximum number of host failures we could tolerate before we would be unable to restart the provided VMs" + ~params:[ Map(Ref _vm, String), "configuration", "Map of protected VM reference to restart priority" ] + ~result:(Int, "maximum value for ha_host_failures_to_tolerate given provided configuration") + ~allowed_roles:_R_READ_ONLY + () + +let ha_compute_vm_failover_plan = call ~flags:[`Session] + ~name:"ha_compute_vm_failover_plan" + ~in_product_since:rel_orlando + ~doc:"Return a VM failover plan assuming a given subset of hosts fail" + ~params:[Set(Ref _host), "failed_hosts", "The set of hosts to assume have failed"; + Set(Ref _vm), "failed_vms", "The set of VMs to restart" ] + ~result:(Map(Ref _vm, Map(String, String)), "VM failover plan: a map of VM to host to restart the host on") + ~allowed_roles:_R_POOL_OP + () + +let create_new_blob = call + ~name: "create_new_blob" + ~in_product_since:rel_orlando + ~doc:"Create a placeholder for a named binary blob of data that is associated with this pool" + ~versioned_params: + [{param_type=Ref _pool; param_name="pool"; param_doc="The pool"; param_release=orlando_release; param_default=None}; + {param_type=String; param_name="name"; param_doc="The name associated with the blob"; param_release=orlando_release; param_default=None}; + {param_type=String; param_name="mime_type"; param_doc="The mime type for the data. Empty string translates to application/octet-stream"; param_release=orlando_release; param_default=None}; + {param_type=Bool; param_name="public"; param_doc="True if the blob should be publicly available"; param_release=tampa_release; param_default=Some (VBool false)} ] - ~allowed_roles:_R_POOL_ADMIN - () - - let remove_from_guest_agent_config = call - ~name:"remove_from_guest_agent_config" - ~in_product_since:rel_dundee - ~doc:"Remove a key-value pair from the pool-wide guest agent configuration" - ~params:[ - Ref _pool, "self", "The pool"; - String, "key", "The key to remove"; + ~result:(Ref _blob, "The reference of the blob, needed for populating its data") + ~allowed_roles:_R_POOL_OP + () + +let set_ha_host_failures_to_tolerate = call + ~name:"set_ha_host_failures_to_tolerate" + ~in_product_since:rel_orlando + ~doc:"Set the maximum number of host failures to consider in the HA VM restart planner" + ~params:[Ref _pool, "self", "The pool"; + Int, "value", "New number of host failures to consider"] + ~allowed_roles:_R_POOL_OP + () + +let ha_schedule_plan_recomputation = call + ~name:"ha_schedule_plan_recomputation" + ~in_product_since:rel_orlando + ~doc:"Signal that the plan should be recomputed (eg a host has come online)" + ~params:[] + ~hide_from_docs:true + ~pool_internal:true + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let enable_binary_storage = call + ~name:"enable_binary_storage" + ~in_product_since:rel_orlando + ~hide_from_docs:true + ~doc:"Enable the storage of larger objects, such as RRDs, messages and binary blobs across all hosts in the pool" + ~params:[] + ~allowed_roles:_R_POOL_OP + () + +let disable_binary_storage = call + ~name:"disable_binary_storage" + ~in_product_since:rel_orlando + ~hide_from_docs:true + ~doc:"Disable the storage of larger objects, such as RRDs, messages and binary blobs across all hosts in the pool. This will destroy all of these objects where they exist." + ~params:[] + ~allowed_roles:_R_POOL_OP + () + +let enable_external_auth = call ~flags:[`Session] + ~name:"enable_external_auth" + ~in_oss_since:None + ~in_product_since:rel_george + ~params:[ + Ref _pool, "pool", "The pool whose external authentication should be enabled"; + Map (String,String), "config", "A list of key-values containing the configuration data" ; + String, "service_name", "The name of the service" ; + String, "auth_type", "The type of authentication (e.g. AD for Active Directory)" + ] + ~doc:"This call enables external authentication on all the hosts of the pool" + ~allowed_roles:_R_POOL_ADMIN + () + +let disable_external_auth = call ~flags:[`Session] + ~name:"disable_external_auth" + ~in_oss_since:None + ~in_product_since:rel_george + ~versioned_params:[ + {param_type=Ref _pool; param_name="pool"; param_doc="The pool whose external authentication should be disabled"; param_release=george_release; param_default=None}; + {param_type=Map (String, String); param_name="config"; param_doc="Optional parameters as a list of key-values containing the configuration data"; param_release=george_release; param_default=Some (VMap [])} + ] + ~doc:"This call disables external authentication on all the hosts of the pool" + ~allowed_roles:_R_POOL_ADMIN + () + +let detect_nonhomogeneous_external_auth = call ~flags:[`Session] + ~name:"detect_nonhomogeneous_external_auth" + ~in_oss_since:None + ~in_product_since:rel_george + ~params:[ + Ref _pool, "pool", "The pool where to detect non-homogeneous external authentication configuration"; + ] + ~doc:"This call asynchronously detects if the external authentication configuration in any slave is different from that in the master and raises appropriate alerts" + ~allowed_roles:_R_POOL_OP + () + +let initialize_wlb = call + ~name:"initialize_wlb" + ~in_product_since:rel_george + ~doc:"Initializes workload balancing monitoring on this pool with the specified wlb server" + ~params:[String, "wlb_url", "The ip address and port to use when accessing the wlb server"; + String, "wlb_username", "The username used to authenticate with the wlb server"; + String, "wlb_password", "The password used to authenticate with the wlb server"; + String, "xenserver_username", "The username used by the wlb server to authenticate with the xenserver"; + String, "xenserver_password", "The password used by the wlb server to authenticate with the xenserver"] + ~allowed_roles:_R_POOL_OP + () + +let deconfigure_wlb = call + ~name:"deconfigure_wlb" + ~in_product_since:rel_george + ~doc:"Permanently deconfigures workload balancing monitoring on this pool" + ~params:[] + ~allowed_roles:_R_POOL_OP + () + +let send_wlb_configuration = call + ~name:"send_wlb_configuration" + ~in_product_since:rel_george + ~doc:"Sets the pool optimization criteria for the workload balancing server" + ~params:[Map(String, String), "config", "The configuration to use in optimizing this pool"] + ~allowed_roles:_R_POOL_OP + () + +let retrieve_wlb_configuration = call + ~name:"retrieve_wlb_configuration" + ~in_product_since:rel_george + ~doc:"Retrieves the pool optimization criteria from the workload balancing server" + ~params:[] + ~result:(Map(String,String), "The configuration used in optimizing this pool") + ~allowed_roles:_R_READ_ONLY + () + +let retrieve_wlb_recommendations = call + ~name:"retrieve_wlb_recommendations" + ~in_product_since:rel_george + ~doc:"Retrieves vm migrate recommendations for the pool from the workload balancing server" + ~params:[] + ~result:(Map(Ref _vm,Set(String)), "The list of vm migration recommendations") + ~allowed_roles:_R_READ_ONLY + () + +let send_test_post = call + ~name:"send_test_post" + ~in_product_since:rel_george + ~doc:"Send the given body to the given host and port, using HTTPS, and print the response. This is used for debugging the SSL layer." + ~params:[(String, "host", ""); (Int, "port", ""); (String, "body", "")] + ~result:(String, "The response") + ~allowed_roles:_R_POOL_ADMIN + () + +let certificate_install = call + ~in_oss_since:None + ~in_product_since:rel_george + ~name:"certificate_install" + ~doc:"Install an SSL certificate pool-wide." + ~params:[String, "name", "A name to give the certificate"; + String, "cert", "The certificate"] + ~allowed_roles:_R_POOL_OP + () + +let certificate_uninstall = call + ~in_oss_since:None + ~in_product_since:rel_george + ~name:"certificate_uninstall" + ~doc:"Remove an SSL certificate." + ~params:[String, "name", "The certificate name"] + ~allowed_roles:_R_POOL_OP + () + +let certificate_list = call + ~in_oss_since:None + ~in_product_since:rel_george + ~name:"certificate_list" + ~doc:"List all installed SSL certificates." + ~result:(Set(String),"All installed certificates") + ~allowed_roles:_R_POOL_OP + () + +let crl_install = call + ~in_oss_since:None + ~in_product_since:rel_george + ~name:"crl_install" + ~doc:"Install an SSL certificate revocation list, pool-wide." + ~params:[String, "name", "A name to give the CRL"; + String, "cert", "The CRL"] + ~allowed_roles:_R_POOL_OP + () + +let crl_uninstall = call + ~in_oss_since:None + ~in_product_since:rel_george + ~name:"crl_uninstall" + ~doc:"Remove an SSL certificate revocation list." + ~params:[String, "name", "The CRL name"] + ~allowed_roles:_R_POOL_OP + () + +let crl_list = call + ~in_oss_since:None + ~in_product_since:rel_george + ~name:"crl_list" + ~doc:"List all installed SSL certificate revocation lists." + ~result:(Set(String), "All installed CRLs") + ~allowed_roles:_R_POOL_OP + () + +let certificate_sync = call + ~in_oss_since:None + ~in_product_since:rel_george + ~name:"certificate_sync" + ~doc:"Sync SSL certificates from master to slaves." + ~allowed_roles:_R_POOL_OP + () + +let enable_redo_log = call + ~in_oss_since:None + ~in_product_since:rel_midnight_ride + ~name:"enable_redo_log" + ~params:[Ref _sr, "sr", "SR to hold the redo log."] + ~doc:"Enable the redo log on the given SR and start using it, unless HA is enabled." + ~allowed_roles:_R_POOL_OP + () + +let disable_redo_log = call + ~in_oss_since:None + ~in_product_since:rel_midnight_ride + ~name:"disable_redo_log" + ~doc:"Disable the redo log if in use, unless HA is enabled." + ~allowed_roles:_R_POOL_OP + () + +let audit_log_append = call + ~in_oss_since:None + ~pool_internal:true + ~hide_from_docs:true + ~in_product_since:rel_midnight_ride + ~name:"audit_log_append" + ~params:[String, "line", "line to be appended to the audit log"] + ~doc:"Append a line to the audit log on the master." + ~allowed_roles:_R_POOL_ADMIN + () + +let set_vswitch_controller = call + ~in_oss_since:None + ~in_product_since:rel_midnight_ride + ~lifecycle:[ + Published, rel_midnight_ride, "Set the IP address of the vswitch controller."; + Extended, rel_cowley, "Allow to be set to the empty string (no controller is used)."; + Deprecated, rel_falcon, "Deprecated: use 'SDN_controller.introduce' and 'SDN_controller.forget' instead."] + ~name:"set_vswitch_controller" + ~params:[String, "address", "IP address of the vswitch controller."] + ~doc:"Set the IP address of the vswitch controller." + ~allowed_roles:_R_POOL_OP + () + +let test_archive_target = call ~flags:[`Session] + ~name:"test_archive_target" + ~in_oss_since:None + ~in_product_since:rel_cowley + ~params:[Ref _pool, "self", "Reference to the pool"; + Map(String,String), "config", "Location config settings to test"; + ] + ~doc:"This call tests if a location is valid" + ~allowed_roles:_R_POOL_OP + ~result:(String, "An XMLRPC result") + () + +let enable_local_storage_caching = call + ~name:"enable_local_storage_caching" + ~in_oss_since:None + ~in_product_since:rel_cowley + ~params:[Ref _pool, "self", "Reference to the pool"] + ~doc:"This call attempts to enable pool-wide local storage caching" + ~allowed_roles:_R_POOL_OP + () + +let disable_local_storage_caching = call + ~name:"disable_local_storage_caching" + ~in_oss_since:None + ~in_product_since:rel_cowley + ~params:[Ref _pool, "self", "Reference to the pool"] + ~doc:"This call disables pool-wide local storage caching" + ~allowed_roles:_R_POOL_OP + () + +let get_license_state = call + ~name:"get_license_state" + ~in_oss_since:None + ~in_product_since:rel_clearwater + ~params:[Ref _pool, "self", "Reference to the pool"] + ~doc:"This call returns the license state for the pool" + ~allowed_roles:_R_READ_ONLY + ~result:(Map(String,String), "The pool's license state") + () + +let apply_edition = call + ~name:"apply_edition" + ~in_oss_since:None + ~in_product_since:rel_clearwater + ~params:[ + Ref _pool, "self", "Reference to the pool"; + String, "edition", "The requested edition"; + ] + ~doc:"Apply an edition to all hosts in the pool" + ~allowed_roles:_R_POOL_OP + () + +let enable_ssl_legacy = call + ~name:"enable_ssl_legacy" + ~in_oss_since:None + ~lifecycle:[ + Published, rel_dundee, ""; + ] + ~params:[Ref _pool, "self", "(ignored)";] + ~doc:"Sets ssl_legacy true on each host, pool-master last. See Host.ssl_legacy and Host.set_ssl_legacy." + ~allowed_roles:_R_POOL_OP + () + +let disable_ssl_legacy = call + ~name:"disable_ssl_legacy" + ~in_oss_since:None + ~lifecycle:[ + Published, rel_dundee, ""; + ] + ~params:[Ref _pool, "self", "(ignored)";] + ~doc:"Sets ssl_legacy true on each host, pool-master last. See Host.ssl_legacy and Host.set_ssl_legacy." + ~allowed_roles:_R_POOL_OP + () + +let set_igmp_snooping_enabled = call + ~in_oss_since:None + ~lifecycle:[ + Published, rel_inverness, "Enable or disable IGMP Snooping on the pool."; + ] + ~name:"set_igmp_snooping_enabled" + ~params:[ + Ref _pool, "self", "The pool"; + Bool, "value", "Enable or disable IGMP Snooping on the pool" + ] + ~doc:"Enable or disable IGMP Snooping on the pool." + ~allowed_roles:_R_POOL_OP + () + +let has_extension = call + ~name:"has_extension" + ~in_product_since:rel_dundee + ~doc:"Return true if the extension is available on the pool" + ~params:[ + Ref _pool, "self", "The pool"; + String, "name", "The name of the API call" + ] + ~result:(Bool, "True if the extension exists, false otherwise") + ~allowed_roles:_R_POOL_ADMIN + () + +let add_to_guest_agent_config = call + ~name:"add_to_guest_agent_config" + ~in_product_since:rel_dundee + ~doc:"Add a key-value pair to the pool-wide guest agent configuration" + ~params:[ + Ref _pool, "self", "The pool"; + String, "key", "The key to add"; + String, "value", "The value to add"; + ] + ~allowed_roles:_R_POOL_ADMIN + () + +let remove_from_guest_agent_config = call + ~name:"remove_from_guest_agent_config" + ~in_product_since:rel_dundee + ~doc:"Remove a key-value pair from the pool-wide guest agent configuration" + ~params:[ + Ref _pool, "self", "The pool"; + String, "key", "The key to remove"; + ] + ~allowed_roles:_R_POOL_ADMIN + () + +(** A pool class *) +let t = + create_obj + ~in_db:true + ~in_product_since:rel_rio + ~in_oss_since:None + ~internal_deprecated_since:None + ~persist:PersistEverything + ~gen_constructor_destructor:false + ~name:_pool + ~descr:"Pool-wide information" + ~gen_events:true + ~doccomments:[] + ~messages_default_allowed_roles:_R_POOL_OP + ~messages: + [ join + ; join_force + ; eject + ; initial_auth + ; transition_to_master + ; slave_reset_master + ; recover_slaves + ; hello + ; ping_slave + ; create_VLAN + ; management_reconfigure + ; create_VLAN_from_PIF + ; slave_network_report + ; enable_ha + ; disable_ha + ; sync_database + ; designate_new_master + ; ha_prevent_restarts_for + ; ha_failover_plan_exists + ; ha_compute_max_host_failures_to_tolerate + ; ha_compute_hypothetical_max_host_failures_to_tolerate + ; ha_compute_vm_failover_plan + ; set_ha_host_failures_to_tolerate + ; create_new_blob + ; ha_schedule_plan_recomputation + ; enable_binary_storage + ; disable_binary_storage + ; enable_external_auth + ; disable_external_auth + ; detect_nonhomogeneous_external_auth + ; initialize_wlb + ; deconfigure_wlb + ; send_wlb_configuration + ; retrieve_wlb_configuration + ; retrieve_wlb_recommendations + ; send_test_post + ; certificate_install + ; certificate_uninstall + ; certificate_list + ; crl_install + ; crl_uninstall + ; crl_list + ; certificate_sync + ; enable_redo_log + ; disable_redo_log + ; audit_log_append + ; set_vswitch_controller + ; test_archive_target + ; enable_local_storage_caching + ; disable_local_storage_caching + ; get_license_state + ; apply_edition + ; enable_ssl_legacy + ; disable_ssl_legacy + ; set_igmp_snooping_enabled + ; has_extension + ; add_to_guest_agent_config + ; remove_from_guest_agent_config ] - ~allowed_roles:_R_POOL_ADMIN - () - - (** A pool class *) - let t = - create_obj - ~in_db:true - ~in_product_since:rel_rio - ~in_oss_since:None - ~internal_deprecated_since:None - ~persist:PersistEverything - ~gen_constructor_destructor:false - ~name:_pool - ~descr:"Pool-wide information" - ~gen_events:true - ~doccomments:[] - ~messages_default_allowed_roles:_R_POOL_OP - ~messages: - [ join - ; join_force - ; eject - ; initial_auth - ; transition_to_master - ; slave_reset_master - ; recover_slaves - ; hello - ; ping_slave - ; create_VLAN - ; management_reconfigure - ; create_VLAN_from_PIF - ; slave_network_report - ; enable_ha - ; disable_ha - ; sync_database - ; designate_new_master - ; ha_prevent_restarts_for - ; ha_failover_plan_exists - ; ha_compute_max_host_failures_to_tolerate - ; ha_compute_hypothetical_max_host_failures_to_tolerate - ; ha_compute_vm_failover_plan - ; set_ha_host_failures_to_tolerate - ; create_new_blob - ; ha_schedule_plan_recomputation - ; enable_binary_storage - ; disable_binary_storage - ; enable_external_auth - ; disable_external_auth - ; detect_nonhomogeneous_external_auth - ; initialize_wlb - ; deconfigure_wlb - ; send_wlb_configuration - ; retrieve_wlb_configuration - ; retrieve_wlb_recommendations - ; send_test_post - ; certificate_install - ; certificate_uninstall - ; certificate_list - ; crl_install - ; crl_uninstall - ; crl_list - ; certificate_sync - ; enable_redo_log - ; disable_redo_log - ; audit_log_append - ; set_vswitch_controller - ; test_archive_target - ; enable_local_storage_caching - ; disable_local_storage_caching - ; get_license_state - ; apply_edition - ; enable_ssl_legacy - ; disable_ssl_legacy - ; set_igmp_snooping_enabled - ; has_extension - ; add_to_guest_agent_config - ; remove_from_guest_agent_config - ] - ~contents: - ([uid ~in_oss_since:None _pool] @ - [ field ~in_oss_since:None ~qualifier:RW ~ty:String "name_label" "Short name" - ; field ~in_oss_since:None ~qualifier:RW ~ty:String "name_description" "Description" - ; field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Ref _host) "master" "The host that is pool master" - ; field ~in_oss_since:None ~qualifier:RW ~ty:(Ref _sr) "default_SR" "Default SR for VDIs" - ; field ~in_oss_since:None ~qualifier:RW ~ty:(Ref _sr) "suspend_image_SR" "The SR in which VDIs for suspend images are created" - ; field ~in_oss_since:None ~qualifier:RW ~ty:(Ref _sr) "crash_dump_SR" "The SR in which VDIs for crash dumps are created" - ; field ~in_oss_since:None ~ty:(Map(String, String)) "other_config" "additional configuration" ~map_keys_roles:[("folder",(_R_VM_OP));("XenCenter.CustomFields.*",(_R_VM_OP));("EMPTY_FOLDERS",(_R_VM_OP))] - ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "ha_enabled" "true if HA is enabled on the pool, false otherwise" - ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:(Map(String, String)) ~default_value:(Some (VMap [])) "ha_configuration" "The current HA configuration" - ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:(Set String) ~default_value:(Some (VSet [])) "ha_statefiles" "HA statefile VDIs in use" - ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Int ~default_value:(Some (VInt 0L)) "ha_host_failures_to_tolerate" "Number of host failures to tolerate before the Pool is declared to be overcommitted" - ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Int ~default_value:(Some (VInt 0L)) "ha_plan_exists_for" "Number of future host failures we have managed to find a plan for. Once this reaches zero any future host failures will cause the failure of protected VMs." - ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:RW ~ty:Bool ~default_value:(Some (VBool false)) "ha_allow_overcommit" "If set to false then operations which would cause the Pool to become overcommitted will be blocked." - ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "ha_overcommitted" "True if the Pool is considered to be overcommitted i.e. if there exist insufficient physical resources to tolerate the configured number of host failures" - ; field ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Map(String, Ref _blob)) ~default_value:(Some (VMap [])) "blobs" "Binary blobs associated with this pool" - ; field ~writer_roles:_R_VM_OP ~in_product_since:rel_orlando ~default_value:(Some (VSet [])) ~ty:(Set String) "tags" "user-specified tags for categorization purposes" - ; field ~writer_roles:_R_VM_OP ~in_product_since:rel_orlando ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "gui_config" "gui-specific configuration for pool" - ; field ~writer_roles:_R_POOL_OP ~in_product_since:rel_dundee ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "health_check_config" "Configuration for the automatic health check feature" - ; field ~in_product_since:rel_george ~qualifier:DynamicRO ~ty:String ~default_value:(Some (VString "")) "wlb_url" "Url for the configured workload balancing host" - ; field ~in_product_since:rel_george ~qualifier:DynamicRO ~ty:String ~default_value:(Some (VString "")) "wlb_username" "Username for accessing the workload balancing host" - ; field ~in_product_since:rel_george ~internal_only:true ~qualifier:DynamicRO ~ty:(Ref _secret) "wlb_password" "Password for accessing the workload balancing host" - ; field ~in_product_since:rel_george ~qualifier:RW ~ty:Bool ~default_value:(Some (VBool false)) "wlb_enabled" "true if workload balancing is enabled on the pool, false otherwise" - ; field ~in_product_since:rel_george ~qualifier:RW ~ty:Bool ~default_value:(Some (VBool false)) "wlb_verify_cert" "true if communication with the WLB server should enforce SSL certificate verification." - ; field ~in_oss_since:None ~in_product_since:rel_midnight_ride ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "redo_log_enabled" "true a redo-log is to be used other than when HA is enabled, false otherwise" - ; field ~in_oss_since:None ~in_product_since:rel_midnight_ride ~qualifier:DynamicRO ~ty:(Ref _vdi) ~default_value:(Some (VRef null_ref)) "redo_log_vdi" "indicates the VDI to use for the redo-log other than when HA is enabled" - ; field ~in_oss_since:None ~qualifier:DynamicRO ~ty:String ~default_value:(Some (VString "")) "vswitch_controller" "address of the vswitch controller" - ~lifecycle:[ - Published, rel_midnight_ride, "the IP address of the vswitch controller."; - Deprecated, rel_falcon, "Deprecated: set the IP address of the vswitch controller in SDN_controller instead."] - ; field ~in_oss_since:None ~in_product_since:rel_midnight_ride ~qualifier:DynamicRO ~ty:(Map(String, String)) ~default_value:(Some (VMap [])) "restrictions" "Pool-wide restrictions currently in effect" - ; field ~in_oss_since:None ~in_product_since:rel_boston ~qualifier:DynamicRO ~ty:(Set (Ref _vdi)) "metadata_VDIs" "The set of currently known metadata VDIs for this pool" - ; field ~in_oss_since:None ~in_product_since:rel_dundee ~qualifier:DynamicRO ~default_value:(Some (VString "")) ~ty:String "ha_cluster_stack" "The HA cluster stack that is currently in use. Only valid when HA is enabled." - ] @ (allowed_and_current_operations operations) @ - [ field ~in_oss_since:None ~in_product_since:rel_dundee ~qualifier:DynamicRO ~ty:(Map(String, String)) ~default_value:(Some (VMap [])) "guest_agent_config" "Pool-wide guest agent configuration information" - ; field ~qualifier:DynamicRO ~in_product_since:rel_dundee ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "cpu_info" "Details about the physical CPUs on the pool" - ; field ~qualifier:RW ~in_product_since:rel_dundee ~default_value:(Some (VBool false)) ~ty:Bool "policy_no_vendor_device" "The pool-wide policy for clients on whether to use the vendor device or not on newly created VMs. This field will also be consulted if the 'has_vendor_device' field is not specified in the VM.create call." - ; field ~qualifier:RW ~in_product_since:rel_ely ~default_value:(Some (VBool false)) ~ty:Bool "live_patching_disabled" "The pool-wide flag to show if the live patching feauture is disabled or not." - ; field ~in_product_since:rel_inverness ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "igmp_snooping_enabled" "true if IGMP snooping is enabled in the pool, false otherwise." - ]) - () + ~contents: + ([uid ~in_oss_since:None _pool] @ + [ field ~in_oss_since:None ~qualifier:RW ~ty:String "name_label" "Short name" + ; field ~in_oss_since:None ~qualifier:RW ~ty:String "name_description" "Description" + ; field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Ref _host) "master" "The host that is pool master" + ; field ~in_oss_since:None ~qualifier:RW ~ty:(Ref _sr) "default_SR" "Default SR for VDIs" + ; field ~in_oss_since:None ~qualifier:RW ~ty:(Ref _sr) "suspend_image_SR" "The SR in which VDIs for suspend images are created" + ; field ~in_oss_since:None ~qualifier:RW ~ty:(Ref _sr) "crash_dump_SR" "The SR in which VDIs for crash dumps are created" + ; field ~in_oss_since:None ~ty:(Map(String, String)) "other_config" "additional configuration" ~map_keys_roles:[("folder",(_R_VM_OP));("XenCenter.CustomFields.*",(_R_VM_OP));("EMPTY_FOLDERS",(_R_VM_OP))] + ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "ha_enabled" "true if HA is enabled on the pool, false otherwise" + ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:(Map(String, String)) ~default_value:(Some (VMap [])) "ha_configuration" "The current HA configuration" + ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:(Set String) ~default_value:(Some (VSet [])) "ha_statefiles" "HA statefile VDIs in use" + ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Int ~default_value:(Some (VInt 0L)) "ha_host_failures_to_tolerate" "Number of host failures to tolerate before the Pool is declared to be overcommitted" + ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Int ~default_value:(Some (VInt 0L)) "ha_plan_exists_for" "Number of future host failures we have managed to find a plan for. Once this reaches zero any future host failures will cause the failure of protected VMs." + ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:RW ~ty:Bool ~default_value:(Some (VBool false)) "ha_allow_overcommit" "If set to false then operations which would cause the Pool to become overcommitted will be blocked." + ; field ~in_oss_since:None ~in_product_since:rel_orlando ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "ha_overcommitted" "True if the Pool is considered to be overcommitted i.e. if there exist insufficient physical resources to tolerate the configured number of host failures" + ; field ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Map(String, Ref _blob)) ~default_value:(Some (VMap [])) "blobs" "Binary blobs associated with this pool" + ; field ~writer_roles:_R_VM_OP ~in_product_since:rel_orlando ~default_value:(Some (VSet [])) ~ty:(Set String) "tags" "user-specified tags for categorization purposes" + ; field ~writer_roles:_R_VM_OP ~in_product_since:rel_orlando ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "gui_config" "gui-specific configuration for pool" + ; field ~writer_roles:_R_POOL_OP ~in_product_since:rel_dundee ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "health_check_config" "Configuration for the automatic health check feature" + ; field ~in_product_since:rel_george ~qualifier:DynamicRO ~ty:String ~default_value:(Some (VString "")) "wlb_url" "Url for the configured workload balancing host" + ; field ~in_product_since:rel_george ~qualifier:DynamicRO ~ty:String ~default_value:(Some (VString "")) "wlb_username" "Username for accessing the workload balancing host" + ; field ~in_product_since:rel_george ~internal_only:true ~qualifier:DynamicRO ~ty:(Ref _secret) "wlb_password" "Password for accessing the workload balancing host" + ; field ~in_product_since:rel_george ~qualifier:RW ~ty:Bool ~default_value:(Some (VBool false)) "wlb_enabled" "true if workload balancing is enabled on the pool, false otherwise" + ; field ~in_product_since:rel_george ~qualifier:RW ~ty:Bool ~default_value:(Some (VBool false)) "wlb_verify_cert" "true if communication with the WLB server should enforce SSL certificate verification." + ; field ~in_oss_since:None ~in_product_since:rel_midnight_ride ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "redo_log_enabled" "true a redo-log is to be used other than when HA is enabled, false otherwise" + ; field ~in_oss_since:None ~in_product_since:rel_midnight_ride ~qualifier:DynamicRO ~ty:(Ref _vdi) ~default_value:(Some (VRef null_ref)) "redo_log_vdi" "indicates the VDI to use for the redo-log other than when HA is enabled" + ; field ~in_oss_since:None ~qualifier:DynamicRO ~ty:String ~default_value:(Some (VString "")) "vswitch_controller" "address of the vswitch controller" + ~lifecycle:[ + Published, rel_midnight_ride, "the IP address of the vswitch controller."; + Deprecated, rel_falcon, "Deprecated: set the IP address of the vswitch controller in SDN_controller instead."] + ; field ~in_oss_since:None ~in_product_since:rel_midnight_ride ~qualifier:DynamicRO ~ty:(Map(String, String)) ~default_value:(Some (VMap [])) "restrictions" "Pool-wide restrictions currently in effect" + ; field ~in_oss_since:None ~in_product_since:rel_boston ~qualifier:DynamicRO ~ty:(Set (Ref _vdi)) "metadata_VDIs" "The set of currently known metadata VDIs for this pool" + ; field ~in_oss_since:None ~in_product_since:rel_dundee ~qualifier:DynamicRO ~default_value:(Some (VString "")) ~ty:String "ha_cluster_stack" "The HA cluster stack that is currently in use. Only valid when HA is enabled." + ] @ (allowed_and_current_operations operations) @ + [ field ~in_oss_since:None ~in_product_since:rel_dundee ~qualifier:DynamicRO ~ty:(Map(String, String)) ~default_value:(Some (VMap [])) "guest_agent_config" "Pool-wide guest agent configuration information" + ; field ~qualifier:DynamicRO ~in_product_since:rel_dundee ~default_value:(Some (VMap [])) ~ty:(Map(String, String)) "cpu_info" "Details about the physical CPUs on the pool" + ; field ~qualifier:RW ~in_product_since:rel_dundee ~default_value:(Some (VBool false)) ~ty:Bool "policy_no_vendor_device" "The pool-wide policy for clients on whether to use the vendor device or not on newly created VMs. This field will also be consulted if the 'has_vendor_device' field is not specified in the VM.create call." + ; field ~qualifier:RW ~in_product_since:rel_ely ~default_value:(Some (VBool false)) ~ty:Bool "live_patching_disabled" "The pool-wide flag to show if the live patching feauture is disabled or not." + ; field ~in_product_since:rel_inverness ~qualifier:DynamicRO ~ty:Bool ~default_value:(Some (VBool false)) "igmp_snooping_enabled" "true if IGMP snooping is enabled in the pool, false otherwise." + ]) + () diff --git a/ocaml/idl/datamodel_types.ml b/ocaml/idl/datamodel_types.ml index ebc2e9ac24b..4c70a2e738c 100644 --- a/ocaml/idl/datamodel_types.ml +++ b/ocaml/idl/datamodel_types.ml @@ -240,7 +240,7 @@ type ty = | Map of ty * ty | Ref of string | Record of string - [@@deriving rpc] +[@@deriving rpc] type api_value = VString of string @@ -253,7 +253,7 @@ type api_value = | VSet of api_value list | VRef of string | VCustom of string * api_value - [@@deriving rpc] +[@@deriving rpc] (* For convenience, we use the same value here as is defined in the Ref module in * xapi-types. It's not terribly important, since all refs should be validated before @@ -269,7 +269,7 @@ type qualifier = | RW (** Implicitly static: set in constructor and updatable through API *) | StaticRO (** Specified in constructor; no autogenerated setter in XenAPI. *) | DynamicRO (** Initial value is a default; no autogenerated setter in XenAPI. *) - [@@deriving rpc] +[@@deriving rpc] (** Release keeps track of which versions of opensource/internal products fields and messages are included in *) type release = { @@ -287,7 +287,7 @@ type lifecycle_change = | Removed and lifecycle_transition = lifecycle_change * string * string - [@@deriving rpc] +[@@deriving rpc] (** Messages are tagged with one of these indicating whether the message was specified explicitly in the datamodel, or is one of the automatically @@ -405,7 +405,7 @@ let default_message = { type content = | Field of field (** An individual field *) | Namespace of string * content list (** A nice namespace for a group of fields *) - [@@deriving rpc] +[@@deriving rpc] (* Note: there used be more than 2 persist_options -- that's why it isn't a bool. I figured even though there's only 2 now I may as well leave it as an enumeration type.. *) diff --git a/ocaml/idl/datamodel_vm.ml b/ocaml/idl/datamodel_vm.ml index 3f142f9eef4..a442109dce9 100644 --- a/ocaml/idl/datamodel_vm.ml +++ b/ocaml/idl/datamodel_vm.ml @@ -4,26 +4,26 @@ open Datamodel_common open Datamodel_roles open Datamodel_types - let pv = - [ - field "bootloader" "name of or path to bootloader"; - field "kernel" "path to the kernel"; - field "ramdisk" "path to the initrd"; - field "args" "kernel command-line arguments"; - field "bootloader_args" "miscellaneous arguments for the bootloader"; - field ~in_oss_since:None "legacy_args" "to make Zurich guests boot"; - ] +let pv = + [ + field "bootloader" "name of or path to bootloader"; + field "kernel" "path to the kernel"; + field "ramdisk" "path to the initrd"; + field "args" "kernel command-line arguments"; + field "bootloader_args" "miscellaneous arguments for the bootloader"; + field ~in_oss_since:None "legacy_args" "to make Zurich guests boot"; + ] - (** HVM domain booting *) - let hvm = - [ - field - ~qualifier:StaticRO - ~lifecycle:[Published, rel_rio, ""; Deprecated, rel_kolkata, "Replaced by VM.domain_type"] - "boot_policy" "HVM boot policy"; - field ~ty:(Map(String, String)) "boot_params" "HVM boot params"; - field ~writer_roles:_R_VM_POWER_ADMIN ~in_oss_since:None ~ty:Float ~in_product_since:rel_miami ~qualifier:StaticRO "shadow_multiplier" "multiplier applied to the amount of shadow that will be made available to the guest" ~default_value:(Some (VFloat 1.)) - ] +(** HVM domain booting *) +let hvm = + [ + field + ~qualifier:StaticRO + ~lifecycle:[Published, rel_rio, ""; Deprecated, rel_kolkata, "Replaced by VM.domain_type"] + "boot_policy" "HVM boot policy"; + field ~ty:(Map(String, String)) "boot_params" "HVM boot params"; + field ~writer_roles:_R_VM_POWER_ADMIN ~in_oss_since:None ~ty:Float ~in_product_since:rel_miami ~qualifier:StaticRO "shadow_multiplier" "multiplier applied to the amount of shadow that will be made available to the guest" ~default_value:(Some (VFloat 1.)) + ] let guest_memory = let field = field ~ty:Int in @@ -36,7 +36,7 @@ let guest_memory = field "static_min" ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:StaticRO "Statically-set (i.e. absolute) mininum (bytes). The value of this field indicates the least amount of memory this VM can boot with without crashing." ~doc_tags:[Memory]; ] - (** Action to take on guest reboot/power off/sleep etc *) +(** Action to take on guest reboot/power off/sleep etc *) (* let power_behaviour = Enum ("power_behaviour", [ "destroy", "destroy the VM state"; @@ -44,1137 +44,1137 @@ let power_behaviour = "preserve", "leave VM running"; "rename_restart", "leave VM running and restart a new one" ]) *) - let on_crash_behaviour = - Enum ("on_crash_behaviour", [ "destroy", "destroy the VM state"; - "coredump_and_destroy", "record a coredump and then destroy the VM state"; - "restart", "restart the VM"; - "coredump_and_restart", "record a coredump and then restart the VM"; - "preserve", "leave the crashed VM paused"; - "rename_restart", "rename the crashed VM and start a new copy" ]) - - let on_normal_exit_behaviour = - Enum ("on_normal_exit", [ "destroy", "destroy the VM state"; - "restart", "restart the VM" ]) - - - (** Virtual CPUs *) - let vcpus = - [ - field ~ty:(Map(String, String)) "params" "configuration parameters for the selected VCPU policy"; - field ~qualifier:StaticRO ~ty:Int "max" "Max number of VCPUs"; - field ~qualifier:StaticRO ~ty:Int "at_startup" "Boot number of VCPUs"; - ] +let on_crash_behaviour = + Enum ("on_crash_behaviour", [ "destroy", "destroy the VM state"; + "coredump_and_destroy", "record a coredump and then destroy the VM state"; + "restart", "restart the VM"; + "coredump_and_restart", "record a coredump and then restart the VM"; + "preserve", "leave the crashed VM paused"; + "rename_restart", "rename the crashed VM and start a new copy" ]) - (** Default actions *) - let actions = - let crash = field ~qualifier:StaticRO ~ty:on_crash_behaviour in - let normal = field ~ty:on_normal_exit_behaviour in - [ - normal "after_shutdown" "action to take after the guest has shutdown itself"; - normal "after_reboot" "action to take after the guest has rebooted itself"; - crash "after_crash" "action to take if the guest crashes"; - ] +let on_normal_exit_behaviour = + Enum ("on_normal_exit", [ "destroy", "destroy the VM state"; + "restart", "restart the VM" ]) + + +(** Virtual CPUs *) +let vcpus = + [ + field ~ty:(Map(String, String)) "params" "configuration parameters for the selected VCPU policy"; + field ~qualifier:StaticRO ~ty:Int "max" "Max number of VCPUs"; + field ~qualifier:StaticRO ~ty:Int "at_startup" "Boot number of VCPUs"; + ] - let set_actions_after_crash = call +(** Default actions *) +let actions = + let crash = field ~qualifier:StaticRO ~ty:on_crash_behaviour in + let normal = field ~ty:on_normal_exit_behaviour in + [ + normal "after_shutdown" "action to take after the guest has shutdown itself"; + normal "after_reboot" "action to take after the guest has rebooted itself"; + crash "after_crash" "action to take if the guest crashes"; + ] + +let set_actions_after_crash = call ~name:"set_actions_after_crash" ~in_oss_since:None ~in_product_since:rel_rio ~doc:"Sets the actions_after_crash parameter" ~params:[ - Ref _vm, "self", "The VM to set"; - on_crash_behaviour, "value", "The new value to set"] + Ref _vm, "self", "The VM to set"; + on_crash_behaviour, "value", "The new value to set"] ~allowed_roles:_R_VM_ADMIN () - let power_state = - Enum ("vm_power_state", [ "Halted", "VM is offline and not using any resources"; - "Paused", "All resources have been allocated but the VM itself is paused and its vCPUs are not running"; - "Running", "Running"; - "Suspended", "VM state has been saved to disk and it is nolonger running. Note that disks remain in-use while the VM is suspended."]) - - - let get_boot_record = call - ~name:"get_boot_record" - ~in_oss_since:None - ~lifecycle:[Published, rel_rio, ""; Deprecated, rel_inverness, "Use the current VM record/fields instead"] - ~doc:"Returns a record describing the VM's dynamic state, initialised when the VM boots and updated to reflect runtime configuration changes e.g. CPU hotplug" - ~result:(Record _vm, "A record describing the VM") - ~params:[Ref _vm, "self", "The VM whose boot-time state to return"] - ~errs:[] - ~flags:[`Session] (* no async *) - ~allowed_roles:_R_READ_ONLY - () - - let get_data_sources = call - ~name:"get_data_sources" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"" - ~result:(Set (Record _data_source), "A set of data sources") - ~params:[Ref _vm, "self", "The VM to interrogate"] - ~errs:[] - ~flags:[`Session] - ~allowed_roles:_R_READ_ONLY - () - - let record_data_source = call - ~name:"record_data_source" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Start recording the specified data source" - ~params:[Ref _vm, "self", "The VM"; - String, "data_source", "The data source to record"] - ~errs:[] - ~flags:[`Session] - ~allowed_roles:_R_VM_ADMIN - () - - let query_data_source = call - ~name:"query_data_source" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Query the latest value of the specified data source" - ~params:[Ref _vm, "self", "The VM"; - String, "data_source", "The data source to query"] - ~result:(Float,"The latest value, averaged over the last 5 seconds") - ~errs:[] - ~flags:[`Session] - ~allowed_roles:_R_READ_ONLY - () - - let forget_data_source_archives = call - ~name:"forget_data_source_archives" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Forget the recorded statistics related to the specified data source" - ~params:[Ref _vm, "self", "The VM"; - String, "data_source", "The data source whose archives are to be forgotten"] - ~flags:[`Session] - ~allowed_roles:_R_VM_ADMIN - () - - let set_ha_always_run = call - ~name:"set_ha_always_run" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Set the value of the ha_always_run" - ~params:[Ref _vm, "self", "The VM"; - Bool, "value", "The value"] - ~flags:[`Session] - ~allowed_roles:_R_POOL_OP - ~internal_deprecated_since:rel_boston - () - - let set_ha_restart_priority = call - ~name:"set_ha_restart_priority" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Set the value of the ha_restart_priority field" - ~params:[Ref _vm, "self", "The VM"; - String, "value", "The value"] - ~flags:[`Session] - ~allowed_roles:_R_POOL_OP - () - - (* VM.Clone *) - - let clone = call - ~name:"clone" - ~in_product_since:rel_rio - ~doc:"Clones the specified VM, making a new VM. Clone automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write). This function can only be called when the VM is in the Halted State." - ~result:(Ref _vm, "The reference of the newly created VM.") - ~params:[ - Ref _vm, "vm", "The VM to be cloned"; - String, "new_name", "The name of the cloned VM" - ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed - ;Api_errors.license_restriction +let power_state = + Enum ("vm_power_state", [ "Halted", "VM is offline and not using any resources"; + "Paused", "All resources have been allocated but the VM itself is paused and its vCPUs are not running"; + "Running", "Running"; + "Suspended", "VM state has been saved to disk and it is nolonger running. Note that disks remain in-use while the VM is suspended."]) + + +let get_boot_record = call + ~name:"get_boot_record" + ~in_oss_since:None + ~lifecycle:[Published, rel_rio, ""; Deprecated, rel_inverness, "Use the current VM record/fields instead"] + ~doc:"Returns a record describing the VM's dynamic state, initialised when the VM boots and updated to reflect runtime configuration changes e.g. CPU hotplug" + ~result:(Record _vm, "A record describing the VM") + ~params:[Ref _vm, "self", "The VM whose boot-time state to return"] + ~errs:[] + ~flags:[`Session] (* no async *) + ~allowed_roles:_R_READ_ONLY + () + +let get_data_sources = call + ~name:"get_data_sources" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"" + ~result:(Set (Record _data_source), "A set of data sources") + ~params:[Ref _vm, "self", "The VM to interrogate"] + ~errs:[] + ~flags:[`Session] + ~allowed_roles:_R_READ_ONLY + () + +let record_data_source = call + ~name:"record_data_source" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Start recording the specified data source" + ~params:[Ref _vm, "self", "The VM"; + String, "data_source", "The data source to record"] + ~errs:[] + ~flags:[`Session] + ~allowed_roles:_R_VM_ADMIN + () + +let query_data_source = call + ~name:"query_data_source" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Query the latest value of the specified data source" + ~params:[Ref _vm, "self", "The VM"; + String, "data_source", "The data source to query"] + ~result:(Float,"The latest value, averaged over the last 5 seconds") + ~errs:[] + ~flags:[`Session] + ~allowed_roles:_R_READ_ONLY + () + +let forget_data_source_archives = call + ~name:"forget_data_source_archives" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Forget the recorded statistics related to the specified data source" + ~params:[Ref _vm, "self", "The VM"; + String, "data_source", "The data source whose archives are to be forgotten"] + ~flags:[`Session] + ~allowed_roles:_R_VM_ADMIN + () + +let set_ha_always_run = call + ~name:"set_ha_always_run" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Set the value of the ha_always_run" + ~params:[Ref _vm, "self", "The VM"; + Bool, "value", "The value"] + ~flags:[`Session] + ~allowed_roles:_R_POOL_OP + ~internal_deprecated_since:rel_boston + () + +let set_ha_restart_priority = call + ~name:"set_ha_restart_priority" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Set the value of the ha_restart_priority field" + ~params:[Ref _vm, "self", "The VM"; + String, "value", "The value"] + ~flags:[`Session] + ~allowed_roles:_R_POOL_OP + () + +(* VM.Clone *) + +let clone = call + ~name:"clone" + ~in_product_since:rel_rio + ~doc:"Clones the specified VM, making a new VM. Clone automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write). This function can only be called when the VM is in the Halted State." + ~result:(Ref _vm, "The reference of the newly created VM.") + ~params:[ + Ref _vm, "vm", "The VM to be cloned"; + String, "new_name", "The name of the cloned VM" + ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed + ;Api_errors.license_restriction + ] + ~allowed_roles:_R_VM_ADMIN + () + +(* VM.Copy *) +let copy = call + ~name:"copy" + ~lifecycle:[ + Published, rel_rio, "Copies a VM to an SR. There must be a host that can see both the source and destination SRs simultaneously"; + Extended, rel_cowley, "The copy can now be performed between any two SRs." ] + ~doc:"Copied the specified VM, making a new VM. Unlike clone, copy does not exploits the capabilities of the underlying storage repository in which the VM's disk images are stored. Instead, copy guarantees that the disk images of the newly created VM will be 'full disks' - i.e. not part of a CoW chain. This function can only be called when the VM is in the Halted State." + ~result:(Ref _vm, "The reference of the newly created VM.") + ~params:[ + Ref _vm, "vm", "The VM to be copied"; + String, "new_name", "The name of the copied VM"; + Ref _sr, "sr", "An SR to copy all the VM's disks into (if an invalid reference then it uses the existing SRs)"; + ] + ~errs:(errnames_of_call clone) + ~allowed_roles:_R_VM_ADMIN + () + +(* VM.snapshot *) +let snapshot_with_quiesce = call + ~name:"snapshot_with_quiesce" + ~in_product_since: rel_orlando + ~doc:"Snapshots the specified VM with quiesce, making a new VM. Snapshot automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write)." + ~result: (Ref _vm, "The reference of the newly created VM.") + ~params:[ + Ref _vm, "vm", "The VM to be snapshotted"; + String, "new_name", "The name of the snapshotted VM" + ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed; + Api_errors.vm_snapshot_with_quiesce_failed; + Api_errors.vm_snapshot_with_quiesce_timeout; + Api_errors.vm_snapshot_with_quiesce_plugin_does_not_respond; + Api_errors.vm_snapshot_with_quiesce_not_supported ] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let update_snapshot_metadata = call + ~name:"update_snapshot_metadata" + ~in_product_since: rel_george + ~internal_deprecated_since:rel_midnight_ride + ~doc:"" + ~hide_from_docs:true + ~params:[ + Ref _vm, "vm", "The VM to update"; + Ref _vm, "snapshot_of", ""; + DateTime, "snapshot_time", ""; + String, "transportable_snapshot_id", "" ] + ~allowed_roles:_R_POOL_OP + () + +let snapshot = call + ~name:"snapshot" + ~in_product_since: rel_orlando + ~doc:"Snapshots the specified VM, making a new VM. Snapshot automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write)." + ~result: (Ref _vm, "The reference of the newly created VM.") + ~params:[ + Ref _vm, "vm", "The VM to be snapshotted"; + String, "new_name", "The name of the snapshotted VM" + ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed] + ~allowed_roles:_R_VM_POWER_ADMIN + ~doc_tags:[Snapshots] + () + +let revert = call + ~name:"revert" + ~in_product_since: rel_midnight_ride + ~doc:"Reverts the specified VM to a previous state." + ~params:[Ref _vm, "snapshot", "The snapshotted state that we revert to"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; + Api_errors.sr_full; Api_errors.vm_revert_failed ] + ~allowed_roles:_R_VM_POWER_ADMIN + ~doc_tags:[Snapshots] + () + +let checkpoint = call + ~name:"checkpoint" + ~in_product_since: rel_midnight_ride + ~doc:"Checkpoints the specified VM, making a new VM. Checkpoint automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write) and saves the memory image as well." + ~result: (Ref _vm, "The reference of the newly created VM.") + ~params:[ + Ref _vm, "vm", "The VM to be checkpointed"; + String, "new_name", "The name of the checkpointed VM" + ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed; + Api_errors.vm_checkpoint_suspend_failed; Api_errors.vm_checkpoint_resume_failed] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let create_template = call + ~name:"create_template" + ~hide_from_docs:true + ~internal_deprecated_since:rel_midnight_ride + ~in_product_since:rel_midnight_ride + ~doc:"Deprecated: use VM.clone or VM.copy instead." + ~result:(Ref _vm, "") + ~params:[ + Ref _vm, "vm", ""; + String, "new_name", "" + ] + ~errs:[] + ~allowed_roles:_R_VM_ADMIN + () + +let set_is_default_template = call + ~name:"set_is_default_template" + ~hide_from_docs:true + ~lifecycle: [Published, rel_falcon, "Allows to define XenServer default templates"] + ~doc:"Makes the specified VM a default template." + ~params:[ + Ref _vm, "vm", "The VM that will become a default template"; + Bool, "value", "The boolean value for the is_default_template flag" + ] + ~errs:[] + ~allowed_roles:_R_POOL_ADMIN + () + +let import_convert = call + ~name:"import_convert" + ~in_product_since:rel_tampa + ~doc:"Import using a conversion service." + ~params:[ + String, "type", "Type of the conversion"; + String, "username", "Admin username on the host"; + String, "password", "Password on the host"; + Ref _sr, "sr", "The destination SR"; + Map(String, String), "remote_config", "Remote configuration options" + ] + ~errs:[] + ~allowed_roles:_R_VM_ADMIN + () + +(* VM.Provision -- causes the template's disks to be instantiated *) + +let provision = call + ~name:"provision" + ~doc:"Inspects the disk configuration contained within the VM's other_config, creates VDIs and VBDs and then executes any applicable post-install script." + ~params:[ + Ref _vm, "vm", "The VM to be provisioned"; + ] + ~in_oss_since:None + ~in_product_since:rel_rio + ~errs:(errnames_of_call clone) + ~allowed_roles:_R_VM_ADMIN + () + +(* VM.Start *) + +let start = call + ~name:"start" + ~in_product_since:rel_rio + ~doc:"Start the specified VM. This function can only be called with the VM is in the Halted State." + ~params:[ + Ref _vm, "vm", "The VM to start"; + Bool, "start_paused", "Instantiate VM in paused state if set to true."; + Bool, "force", "Attempt to force the VM to start. If this flag is false then the VM may fail pre-boot safety checks (e.g. if the CPU the VM last booted on looks substantially different to the current one)"; + ] + ~errs:[ + Api_errors.vm_bad_power_state; + Api_errors.vm_hvm_required; + Api_errors.vm_is_template; + Api_errors.other_operation_in_progress; + Api_errors.operation_not_allowed; + Api_errors.bootloader_failed; + Api_errors.unknown_bootloader; + Api_errors.no_hosts_available; + Api_errors.license_restriction; + ] + ~allowed_roles:_R_VM_OP + () + +let assert_can_boot_here = call + ~name:"assert_can_boot_here" + ~in_product_since:rel_rio + ~doc:"Returns an error if the VM could not boot on this host for some reason" + ~params:[ + Ref _vm, "self", "The VM"; + Ref _host, "host", "The host"; + ] + ~allowed_roles:_R_READ_ONLY + ~errs:[ + Api_errors.host_not_enough_free_memory; + Api_errors.vm_requires_sr; + Api_errors.vm_host_incompatible_version; + Api_errors.vm_host_incompatible_virtual_hardware_platform_version; + ] + ~doc_tags:[Memory] + () + +let assert_agile = call + ~name:"assert_agile" + ~in_product_since:rel_orlando + ~doc:"Returns an error if the VM is not considered agile e.g. because it is tied to a resource local to a host" + ~params:[Ref _vm, "self", "The VM"] + ~allowed_roles:_R_READ_ONLY + () + +let get_possible_hosts = call + ~name:"get_possible_hosts" + ~in_product_since:rel_rio + ~doc:"Return the list of hosts on which this VM may run." + ~params:[Ref _vm, "vm", "The VM" ] + ~result:(Set (Ref _host), "The possible hosts") + ~allowed_roles:_R_READ_ONLY + () + +let retrieve_wlb_recommendations = call + ~name:"retrieve_wlb_recommendations" + ~in_product_since:rel_george + ~doc:"Returns mapping of hosts to ratings, indicating the suitability of starting the VM at that location according to wlb. Rating is replaced with an error if the VM cannot boot there." + ~params:[Ref _vm, "vm", "The VM";] + ~result:(Map (Ref _host, Set(String)), "The potential hosts and their corresponding recommendations or errors") + ~allowed_roles:_R_READ_ONLY + () + + +let maximise_memory = call + ~in_product_since:rel_miami + ~name:"maximise_memory" + ~doc:"Returns the maximum amount of guest memory which will fit, together with overheads, in the supplied amount of physical memory. If 'exact' is true then an exact calculation is performed using the VM's current settings. If 'exact' is false then a more conservative approximation is used" + ~params:[Ref _vm, "self", "The VM"; + Int, "total", "Total amount of physical RAM to fit within"; + Bool, "approximate", "If false the limit is calculated with the guest's current exact configuration. Otherwise a more approximate calculation is performed"; ] - ~allowed_roles:_R_VM_ADMIN - () - - (* VM.Copy *) - let copy = call - ~name:"copy" - ~lifecycle:[ - Published, rel_rio, "Copies a VM to an SR. There must be a host that can see both the source and destination SRs simultaneously"; - Extended, rel_cowley, "The copy can now be performed between any two SRs." ] - ~doc:"Copied the specified VM, making a new VM. Unlike clone, copy does not exploits the capabilities of the underlying storage repository in which the VM's disk images are stored. Instead, copy guarantees that the disk images of the newly created VM will be 'full disks' - i.e. not part of a CoW chain. This function can only be called when the VM is in the Halted State." - ~result:(Ref _vm, "The reference of the newly created VM.") - ~params:[ - Ref _vm, "vm", "The VM to be copied"; - String, "new_name", "The name of the copied VM"; - Ref _sr, "sr", "An SR to copy all the VM's disks into (if an invalid reference then it uses the existing SRs)"; - ] - ~errs:(errnames_of_call clone) - ~allowed_roles:_R_VM_ADMIN - () - - (* VM.snapshot *) - let snapshot_with_quiesce = call - ~name:"snapshot_with_quiesce" - ~in_product_since: rel_orlando - ~doc:"Snapshots the specified VM with quiesce, making a new VM. Snapshot automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write)." - ~result: (Ref _vm, "The reference of the newly created VM.") - ~params:[ - Ref _vm, "vm", "The VM to be snapshotted"; - String, "new_name", "The name of the snapshotted VM" - ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed; - Api_errors.vm_snapshot_with_quiesce_failed; - Api_errors.vm_snapshot_with_quiesce_timeout; - Api_errors.vm_snapshot_with_quiesce_plugin_does_not_respond; - Api_errors.vm_snapshot_with_quiesce_not_supported ] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let update_snapshot_metadata = call - ~name:"update_snapshot_metadata" - ~in_product_since: rel_george - ~internal_deprecated_since:rel_midnight_ride - ~doc:"" - ~hide_from_docs:true - ~params:[ - Ref _vm, "vm", "The VM to update"; - Ref _vm, "snapshot_of", ""; - DateTime, "snapshot_time", ""; - String, "transportable_snapshot_id", "" ] - ~allowed_roles:_R_POOL_OP - () - - let snapshot = call - ~name:"snapshot" - ~in_product_since: rel_orlando - ~doc:"Snapshots the specified VM, making a new VM. Snapshot automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write)." - ~result: (Ref _vm, "The reference of the newly created VM.") - ~params:[ - Ref _vm, "vm", "The VM to be snapshotted"; - String, "new_name", "The name of the snapshotted VM" - ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed] - ~allowed_roles:_R_VM_POWER_ADMIN - ~doc_tags:[Snapshots] - () - - let revert = call - ~name:"revert" - ~in_product_since: rel_midnight_ride - ~doc:"Reverts the specified VM to a previous state." - ~params:[Ref _vm, "snapshot", "The snapshotted state that we revert to"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; - Api_errors.sr_full; Api_errors.vm_revert_failed ] - ~allowed_roles:_R_VM_POWER_ADMIN - ~doc_tags:[Snapshots] - () - - let checkpoint = call - ~name:"checkpoint" - ~in_product_since: rel_midnight_ride - ~doc:"Checkpoints the specified VM, making a new VM. Checkpoint automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write) and saves the memory image as well." - ~result: (Ref _vm, "The reference of the newly created VM.") - ~params:[ - Ref _vm, "vm", "The VM to be checkpointed"; - String, "new_name", "The name of the checkpointed VM" - ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed; - Api_errors.vm_checkpoint_suspend_failed; Api_errors.vm_checkpoint_resume_failed] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let create_template = call - ~name:"create_template" - ~hide_from_docs:true - ~internal_deprecated_since:rel_midnight_ride - ~in_product_since:rel_midnight_ride - ~doc:"Deprecated: use VM.clone or VM.copy instead." - ~result:(Ref _vm, "") - ~params:[ - Ref _vm, "vm", ""; - String, "new_name", "" - ] - ~errs:[] - ~allowed_roles:_R_VM_ADMIN - () - - let set_is_default_template = call - ~name:"set_is_default_template" - ~hide_from_docs:true - ~lifecycle: [Published, rel_falcon, "Allows to define XenServer default templates"] - ~doc:"Makes the specified VM a default template." - ~params:[ - Ref _vm, "vm", "The VM that will become a default template"; - Bool, "value", "The boolean value for the is_default_template flag" - ] - ~errs:[] - ~allowed_roles:_R_POOL_ADMIN - () - - let import_convert = call - ~name:"import_convert" - ~in_product_since:rel_tampa - ~doc:"Import using a conversion service." - ~params:[ - String, "type", "Type of the conversion"; - String, "username", "Admin username on the host"; - String, "password", "Password on the host"; - Ref _sr, "sr", "The destination SR"; - Map(String, String), "remote_config", "Remote configuration options" - ] - ~errs:[] - ~allowed_roles:_R_VM_ADMIN - () + ~result:(Int, "The maximum possible static-max") + ~allowed_roles:_R_READ_ONLY + ~doc_tags:[Memory] + () - (* VM.Provision -- causes the template's disks to be instantiated *) +let get_allowed_VBD_devices = call ~flags:[`Session] ~no_current_operations:true + ~in_product_since:rel_rio + ~name:"get_allowed_VBD_devices" + ~doc:"Returns a list of the allowed values that a VBD device field can take" + ~params:[Ref _vm,"vm","The VM to query"] + ~result:(Set String, "The allowed values") + ~allowed_roles:_R_READ_ONLY + () - let provision = call - ~name:"provision" - ~doc:"Inspects the disk configuration contained within the VM's other_config, creates VDIs and VBDs and then executes any applicable post-install script." - ~params:[ - Ref _vm, "vm", "The VM to be provisioned"; - ] - ~in_oss_since:None - ~in_product_since:rel_rio - ~errs:(errnames_of_call clone) - ~allowed_roles:_R_VM_ADMIN - () - - (* VM.Start *) - - let start = call - ~name:"start" - ~in_product_since:rel_rio - ~doc:"Start the specified VM. This function can only be called with the VM is in the Halted State." - ~params:[ - Ref _vm, "vm", "The VM to start"; - Bool, "start_paused", "Instantiate VM in paused state if set to true."; - Bool, "force", "Attempt to force the VM to start. If this flag is false then the VM may fail pre-boot safety checks (e.g. if the CPU the VM last booted on looks substantially different to the current one)"; - ] - ~errs:[ - Api_errors.vm_bad_power_state; - Api_errors.vm_hvm_required; - Api_errors.vm_is_template; - Api_errors.other_operation_in_progress; - Api_errors.operation_not_allowed; - Api_errors.bootloader_failed; - Api_errors.unknown_bootloader; - Api_errors.no_hosts_available; - Api_errors.license_restriction; - ] - ~allowed_roles:_R_VM_OP - () - - let assert_can_boot_here = call - ~name:"assert_can_boot_here" - ~in_product_since:rel_rio - ~doc:"Returns an error if the VM could not boot on this host for some reason" - ~params:[ - Ref _vm, "self", "The VM"; - Ref _host, "host", "The host"; - ] - ~allowed_roles:_R_READ_ONLY - ~errs:[ - Api_errors.host_not_enough_free_memory; - Api_errors.vm_requires_sr; - Api_errors.vm_host_incompatible_version; - Api_errors.vm_host_incompatible_virtual_hardware_platform_version; - ] - ~doc_tags:[Memory] - () - - let assert_agile = call - ~name:"assert_agile" - ~in_product_since:rel_orlando - ~doc:"Returns an error if the VM is not considered agile e.g. because it is tied to a resource local to a host" - ~params:[Ref _vm, "self", "The VM"] - ~allowed_roles:_R_READ_ONLY - () - - let get_possible_hosts = call - ~name:"get_possible_hosts" - ~in_product_since:rel_rio - ~doc:"Return the list of hosts on which this VM may run." - ~params:[Ref _vm, "vm", "The VM" ] - ~result:(Set (Ref _host), "The possible hosts") - ~allowed_roles:_R_READ_ONLY - () - - let retrieve_wlb_recommendations = call - ~name:"retrieve_wlb_recommendations" - ~in_product_since:rel_george - ~doc:"Returns mapping of hosts to ratings, indicating the suitability of starting the VM at that location according to wlb. Rating is replaced with an error if the VM cannot boot there." - ~params:[Ref _vm, "vm", "The VM";] - ~result:(Map (Ref _host, Set(String)), "The potential hosts and their corresponding recommendations or errors") - ~allowed_roles:_R_READ_ONLY - () - - - let maximise_memory = call - ~in_product_since:rel_miami - ~name:"maximise_memory" - ~doc:"Returns the maximum amount of guest memory which will fit, together with overheads, in the supplied amount of physical memory. If 'exact' is true then an exact calculation is performed using the VM's current settings. If 'exact' is false then a more conservative approximation is used" - ~params:[Ref _vm, "self", "The VM"; - Int, "total", "Total amount of physical RAM to fit within"; - Bool, "approximate", "If false the limit is calculated with the guest's current exact configuration. Otherwise a more approximate calculation is performed"; - ] - ~result:(Int, "The maximum possible static-max") - ~allowed_roles:_R_READ_ONLY - ~doc_tags:[Memory] - () - - let get_allowed_VBD_devices = call ~flags:[`Session] ~no_current_operations:true - ~in_product_since:rel_rio - ~name:"get_allowed_VBD_devices" - ~doc:"Returns a list of the allowed values that a VBD device field can take" - ~params:[Ref _vm,"vm","The VM to query"] - ~result:(Set String, "The allowed values") - ~allowed_roles:_R_READ_ONLY - () - - let get_allowed_VIF_devices = call ~flags:[`Session] ~no_current_operations:true - ~in_product_since:rel_rio - ~name:"get_allowed_VIF_devices" - ~doc:"Returns a list of the allowed values that a VIF device field can take" - ~params:[Ref _vm,"vm","The VM to query"] - ~result:(Set String, "The allowed values") - ~allowed_roles:_R_READ_ONLY - () - - (* VM.atomic_set_resident_on *) - (* an internal call that sets resident_on and clears the scheduled_to_be_resident_on atomically *) - - let atomic_set_resident_on = call - ~in_product_since:rel_rio - ~pool_internal:true - ~hide_from_docs:true - ~name:"atomic_set_resident_on" - ~doc:"" - ~params:[Ref _vm, "vm", "The VM to modify"; - Ref _host, "host", "The host to set resident_on to" - ] - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - let compute_memory_overhead = call - ~in_product_since:rel_midnight_ride - ~name:"compute_memory_overhead" - ~doc:"Computes the virtualization memory overhead of a VM." - ~params:[Ref _vm, "vm", "The VM for which to compute the memory overhead"] - ~pool_internal:false - ~hide_from_docs:false - ~result:(Int, "the virtualization memory overhead of the VM.") - ~allowed_roles:_R_READ_ONLY - ~doc_tags:[Memory] - () - - let set_memory_dynamic_max = call ~flags:[`Session] - ~in_product_since:rel_midnight_ride - ~name:"set_memory_dynamic_max" - ~doc:"Set the value of the memory_dynamic_max field" - ~params:[ - Ref _vm, "self", "The VM to modify"; - Int, "value", "The new value of memory_dynamic_max"; - ] - ~allowed_roles:_R_VM_POWER_ADMIN - ~errs:[] - ~doc_tags:[Memory] - () - - let set_memory_dynamic_min = call ~flags:[`Session] - ~in_product_since:rel_midnight_ride - ~name:"set_memory_dynamic_min" - ~doc:"Set the value of the memory_dynamic_min field" - ~params:[ - Ref _vm, "self", "The VM to modify"; - Int, "value", "The new value of memory_dynamic_min"; - ] - ~allowed_roles:_R_VM_POWER_ADMIN - ~errs:[] - ~doc_tags:[Memory] - () - - let set_memory_dynamic_range = call - ~name:"set_memory_dynamic_range" - ~in_product_since:rel_midnight_ride - ~doc:"Set the minimum and maximum amounts of physical memory the VM is \ - allowed to use." - ~allowed_roles:_R_VM_POWER_ADMIN - ~params:[ - Ref _vm, "self", "The VM"; - Int, "min", "The new minimum value"; - Int, "max", "The new maximum value"; - ] - ~doc_tags:[Memory] - () - - (* When HA is enabled we need to prevent memory *) - (* changes which will break the recovery plan. *) - let set_memory_static_max = call ~flags:[`Session] - ~in_product_since:rel_orlando - ~name:"set_memory_static_max" - ~doc:"Set the value of the memory_static_max field" - ~errs:[Api_errors.ha_operation_would_break_failover_plan] - ~allowed_roles:_R_VM_POWER_ADMIN - ~params:[ - Ref _vm, "self", "The VM to modify"; - Int, "value", "The new value of memory_static_max"; - ] - ~doc_tags:[Memory] - () - - let set_memory_static_min = call ~flags:[`Session] - ~in_product_since:rel_midnight_ride - ~name:"set_memory_static_min" - ~doc:"Set the value of the memory_static_min field" - ~errs:[] - ~allowed_roles:_R_VM_POWER_ADMIN - ~params:[ - Ref _vm, "self", "The VM to modify"; - Int, "value", "The new value of memory_static_min"; - ] - ~doc_tags:[Memory] - () - - let set_memory_static_range = call - ~name:"set_memory_static_range" - ~in_product_since:rel_midnight_ride - ~doc:"Set the static (ie boot-time) range of virtual memory that the VM is \ - allowed to use." - ~allowed_roles:_R_VM_POWER_ADMIN - ~params:[Ref _vm, "self", "The VM"; - Int, "min", "The new minimum value"; - Int, "max", "The new maximum value"; - ] - ~doc_tags:[Memory] - () - - let set_memory_limits = call - ~name:"set_memory_limits" - ~in_product_since:rel_midnight_ride - ~doc:"Set the memory limits of this VM." - ~allowed_roles:_R_VM_POWER_ADMIN - ~params:[Ref _vm, "self", "The VM"; - Int, "static_min", "The new value of memory_static_min."; - Int, "static_max", "The new value of memory_static_max."; - Int, "dynamic_min", "The new value of memory_dynamic_min."; - Int, "dynamic_max", "The new value of memory_dynamic_max."; - ] - ~doc_tags:[Memory] - () - - let set_memory = call - ~name:"set_memory" - ~in_product_since:rel_ely - ~doc:"Set the memory allocation of this VM. Sets all of memory_static_max, memory_dynamic_min, and memory_dynamic_max to the given value, and leaves memory_static_min untouched." - ~allowed_roles:_R_VM_POWER_ADMIN - ~params:[ - Ref _vm, "self", "The VM"; - Int, "value", "The new memory allocation (bytes)."; - ] - ~doc_tags:[Memory] - () - - let set_memory_target_live = call - ~name:"set_memory_target_live" - ~in_product_since:rel_rio - ~internal_deprecated_since:rel_midnight_ride - ~doc:"Set the memory target for a running VM" - ~allowed_roles:_R_VM_POWER_ADMIN - ~params:[ - Ref _vm, "self", "The VM"; - Int, "target", "The target in bytes"; - ] - ~doc_tags:[Memory] - () - - let wait_memory_target_live = call - ~name:"wait_memory_target_live" - ~in_product_since:rel_orlando - ~internal_deprecated_since:rel_midnight_ride - ~doc:"Wait for a running VM to reach its current memory target" - ~allowed_roles:_R_READ_ONLY - ~params:[ - Ref _vm, "self", "The VM"; - ] - ~doc_tags:[Memory] - () - - let get_cooperative = call - ~name:"get_cooperative" - ~in_product_since:rel_midnight_ride - ~internal_deprecated_since:rel_tampa - ~doc:"Return true if the VM is currently 'co-operative' i.e. is expected to reach a balloon target and actually has done" - ~params:[ - Ref _vm, "self", "The VM"; +let get_allowed_VIF_devices = call ~flags:[`Session] ~no_current_operations:true + ~in_product_since:rel_rio + ~name:"get_allowed_VIF_devices" + ~doc:"Returns a list of the allowed values that a VIF device field can take" + ~params:[Ref _vm,"vm","The VM to query"] + ~result:(Set String, "The allowed values") + ~allowed_roles:_R_READ_ONLY + () + +(* VM.atomic_set_resident_on *) +(* an internal call that sets resident_on and clears the scheduled_to_be_resident_on atomically *) + +let atomic_set_resident_on = call + ~in_product_since:rel_rio + ~pool_internal:true + ~hide_from_docs:true + ~name:"atomic_set_resident_on" + ~doc:"" + ~params:[Ref _vm, "vm", "The VM to modify"; + Ref _host, "host", "The host to set resident_on to" + ] + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +let compute_memory_overhead = call + ~in_product_since:rel_midnight_ride + ~name:"compute_memory_overhead" + ~doc:"Computes the virtualization memory overhead of a VM." + ~params:[Ref _vm, "vm", "The VM for which to compute the memory overhead"] + ~pool_internal:false + ~hide_from_docs:false + ~result:(Int, "the virtualization memory overhead of the VM.") + ~allowed_roles:_R_READ_ONLY + ~doc_tags:[Memory] + () + +let set_memory_dynamic_max = call ~flags:[`Session] + ~in_product_since:rel_midnight_ride + ~name:"set_memory_dynamic_max" + ~doc:"Set the value of the memory_dynamic_max field" + ~params:[ + Ref _vm, "self", "The VM to modify"; + Int, "value", "The new value of memory_dynamic_max"; + ] + ~allowed_roles:_R_VM_POWER_ADMIN + ~errs:[] + ~doc_tags:[Memory] + () + +let set_memory_dynamic_min = call ~flags:[`Session] + ~in_product_since:rel_midnight_ride + ~name:"set_memory_dynamic_min" + ~doc:"Set the value of the memory_dynamic_min field" + ~params:[ + Ref _vm, "self", "The VM to modify"; + Int, "value", "The new value of memory_dynamic_min"; + ] + ~allowed_roles:_R_VM_POWER_ADMIN + ~errs:[] + ~doc_tags:[Memory] + () + +let set_memory_dynamic_range = call + ~name:"set_memory_dynamic_range" + ~in_product_since:rel_midnight_ride + ~doc:"Set the minimum and maximum amounts of physical memory the VM is \ + allowed to use." + ~allowed_roles:_R_VM_POWER_ADMIN + ~params:[ + Ref _vm, "self", "The VM"; + Int, "min", "The new minimum value"; + Int, "max", "The new maximum value"; + ] + ~doc_tags:[Memory] + () + +(* When HA is enabled we need to prevent memory *) +(* changes which will break the recovery plan. *) +let set_memory_static_max = call ~flags:[`Session] + ~in_product_since:rel_orlando + ~name:"set_memory_static_max" + ~doc:"Set the value of the memory_static_max field" + ~errs:[Api_errors.ha_operation_would_break_failover_plan] + ~allowed_roles:_R_VM_POWER_ADMIN + ~params:[ + Ref _vm, "self", "The VM to modify"; + Int, "value", "The new value of memory_static_max"; + ] + ~doc_tags:[Memory] + () + +let set_memory_static_min = call ~flags:[`Session] + ~in_product_since:rel_midnight_ride + ~name:"set_memory_static_min" + ~doc:"Set the value of the memory_static_min field" + ~errs:[] + ~allowed_roles:_R_VM_POWER_ADMIN + ~params:[ + Ref _vm, "self", "The VM to modify"; + Int, "value", "The new value of memory_static_min"; + ] + ~doc_tags:[Memory] + () + +let set_memory_static_range = call + ~name:"set_memory_static_range" + ~in_product_since:rel_midnight_ride + ~doc:"Set the static (ie boot-time) range of virtual memory that the VM is \ + allowed to use." + ~allowed_roles:_R_VM_POWER_ADMIN + ~params:[Ref _vm, "self", "The VM"; + Int, "min", "The new minimum value"; + Int, "max", "The new maximum value"; + ] + ~doc_tags:[Memory] + () + +let set_memory_limits = call + ~name:"set_memory_limits" + ~in_product_since:rel_midnight_ride + ~doc:"Set the memory limits of this VM." + ~allowed_roles:_R_VM_POWER_ADMIN + ~params:[Ref _vm, "self", "The VM"; + Int, "static_min", "The new value of memory_static_min."; + Int, "static_max", "The new value of memory_static_max."; + Int, "dynamic_min", "The new value of memory_dynamic_min."; + Int, "dynamic_max", "The new value of memory_dynamic_max."; + ] + ~doc_tags:[Memory] + () + +let set_memory = call + ~name:"set_memory" + ~in_product_since:rel_ely + ~doc:"Set the memory allocation of this VM. Sets all of memory_static_max, memory_dynamic_min, and memory_dynamic_max to the given value, and leaves memory_static_min untouched." + ~allowed_roles:_R_VM_POWER_ADMIN + ~params:[ + Ref _vm, "self", "The VM"; + Int, "value", "The new memory allocation (bytes)."; + ] + ~doc_tags:[Memory] + () + +let set_memory_target_live = call + ~name:"set_memory_target_live" + ~in_product_since:rel_rio + ~internal_deprecated_since:rel_midnight_ride + ~doc:"Set the memory target for a running VM" + ~allowed_roles:_R_VM_POWER_ADMIN + ~params:[ + Ref _vm, "self", "The VM"; + Int, "target", "The target in bytes"; + ] + ~doc_tags:[Memory] + () + +let wait_memory_target_live = call + ~name:"wait_memory_target_live" + ~in_product_since:rel_orlando + ~internal_deprecated_since:rel_midnight_ride + ~doc:"Wait for a running VM to reach its current memory target" + ~allowed_roles:_R_READ_ONLY + ~params:[ + Ref _vm, "self", "The VM"; + ] + ~doc_tags:[Memory] + () + +let get_cooperative = call + ~name:"get_cooperative" + ~in_product_since:rel_midnight_ride + ~internal_deprecated_since:rel_tampa + ~doc:"Return true if the VM is currently 'co-operative' i.e. is expected to reach a balloon target and actually has done" + ~params:[ + Ref _vm, "self", "The VM"; + ] + ~result:(Bool, "true if the VM is currently 'co-operative'; false otherwise") + ~allowed_roles:_R_READ_ONLY + ~doc_tags:[Memory] + () + +let query_services = call + ~name:"query_services" + ~in_product_since:rel_tampa + ~doc:"Query the system services advertised by this VM and register them. This can only be applied to a system domain." + ~params:[ + Ref _vm, "self", "The VM"; + ] + ~result:(Map(String, String), "map of service type to name") + ~allowed_roles:_R_POOL_ADMIN + () + +(* VM.StartOn *) + +let start_on = call + ~in_product_since:rel_rio + ~name:"start_on" + ~doc:"Start the specified VM on a particular host. This function can only be called with the VM is in the Halted State." + ~in_oss_since:None + ~params:[Ref _vm, "vm", "The VM to start"; + Ref _host, "host", "The Host on which to start the VM"; + Bool, "start_paused", "Instantiate VM in paused state if set to true."; + Bool, "force", "Attempt to force the VM to start. If this flag is false then the VM may fail pre-boot safety checks (e.g. if the CPU the VM last booted on looks substantially different to the current one)"; + ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.vm_is_template; Api_errors.other_operation_in_progress; + Api_errors.operation_not_allowed; + Api_errors.bootloader_failed; + Api_errors.unknown_bootloader; + ] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +(* VM.Pause *) + +let pause = call + ~in_product_since:rel_rio + ~name:"pause" + ~doc:"Pause the specified VM. This can only be called when the specified VM is in the Running state." + ~params:[Ref _vm, "vm", "The VM to pause"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; + Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +(* VM.UnPause *) + +let unpause = call + ~in_product_since:rel_rio + ~name:"unpause" + ~doc:"Resume the specified VM. This can only be called when the specified VM is in the Paused state." + ~params:[Ref _vm, "vm", "The VM to unpause"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + + +(* VM.CleanShutdown *) + +let cleanShutdown = call + ~in_product_since:rel_rio + ~name:"clean_shutdown" + ~doc:"Attempt to cleanly shutdown the specified VM. (Note: this may not be supported---e.g. if a guest agent is not installed). This can only be called when the specified VM is in the Running state." + ~params:[Ref _vm, "vm", "The VM to shutdown"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; + Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +(* VM.CleanReboot *) + +let cleanReboot = call + ~in_product_since:rel_rio + ~name:"clean_reboot" + ~doc:"Attempt to cleanly shutdown the specified VM (Note: this may not be supported---e.g. if a guest agent is not installed). This can only be called when the specified VM is in the Running state." + ~params:[Ref _vm, "vm", "The VM to shutdown"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; + Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +(* VM.HardShutdown *) + +let hardShutdown = call + ~in_product_since:rel_rio + ~name:"hard_shutdown" + ~doc:"Stop executing the specified VM without attempting a clean shutdown." + ~params:[Ref _vm, "vm", "The VM to destroy"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; + Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +(* VM.Shutdown *) + +let shutdown = call + ~in_product_since:rel_clearwater + ~name:"shutdown" + ~doc:"Attempts to first clean shutdown a VM and if it should fail then perform a hard shutdown on it." + ~params:[Ref _vm, "vm", "The VM to shutdown"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; + Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +(* VM.PowerStateReset *) + +let stateReset = call + ~in_product_since:rel_rio + ~name:"power_state_reset" + ~doc:"Reset the power-state of the VM to halted in the database only. (Used to recover from slave failures in pooling scenarios by resetting the power-states of VMs running on dead slaves to halted.) This is a potentially dangerous operation; use with care." + ~params:[Ref _vm, "vm", "The VM to reset"] + ~errs:[] + ~allowed_roles:_R_POOL_OP + () + +(* VM.HardReboot *) + +let hardReboot = call + ~in_product_since:rel_rio + ~name:"hard_reboot" + ~doc:"Stop executing the specified VM without attempting a clean shutdown and immediately restart the VM." + ~params:[Ref _vm, "vm", "The VM to reboot"] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; + Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +let hardReboot_internal = call + ~in_product_since:rel_orlando + ~name:"hard_reboot_internal" + ~doc:"Internal function which immediately restarts the specified VM." + ~params:[Ref _vm, "vm", "The VM to reboot"] + ~pool_internal:true + ~hide_from_docs:true + ~internal_deprecated_since:rel_midnight_ride + ~allowed_roles:_R_LOCAL_ROOT_ONLY + () + +(* VM.Hibernate *) + +let suspend = call + ~in_product_since:rel_rio + ~name:"suspend" + ~doc:"Suspend the specified VM to disk. This can only be called when the specified VM is in the Running state." + ~params:[Ref _vm, "vm", "The VM to suspend"] + (* Bool, "live", "If set to true, perform a live hibernate; otherwise suspend the VM before commencing hibernate" *) + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; + Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +(* VM.clsp -- clone suspended, undocumented API for VMLogix *) +let csvm = call + ~name:"csvm" + ~in_product_since:rel_rio + ~doc:"undocumented. internal use only. This call is deprecated." + ~params:[Ref _vm, "vm", ""] + ~result:(Ref _vm, "") + ~errs:(errnames_of_call clone) + ~hide_from_docs:true + ~internal_deprecated_since:rel_miami + ~allowed_roles:_R_VM_ADMIN + () + +(* VM.UnHibernate *) + +let resume = call + ~name:"resume" + ~in_product_since:rel_rio + ~doc:"Awaken the specified VM and resume it. This can only be called when the specified VM is in the Suspended state." + ~params:[Ref _vm, "vm", "The VM to resume"; + Bool, "start_paused", "Resume VM in paused state if set to true."; + Bool, "force", "Attempt to force the VM to resume. If this flag is false then the VM may fail pre-resume safety checks (e.g. if the CPU the VM was running on looks substantially different to the current one)"; + ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; Api_errors.vm_is_template] + ~allowed_roles:_R_VM_OP + () + +let resume_on = call + ~name:"resume_on" + ~in_product_since:rel_rio + ~doc:"Awaken the specified VM and resume it on a particular Host. This can only be called when the specified VM is in the Suspended state." + ~in_oss_since:None + ~params:[Ref _vm, "vm", "The VM to resume"; + Ref _host, "host", "The Host on which to resume the VM"; + Bool, "start_paused", "Resume VM in paused state if set to true."; + Bool, "force", "Attempt to force the VM to resume. If this flag is false then the VM may fail pre-resume safety checks (e.g. if the CPU the VM was running on looks substantially different to the current one)"; + ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; Api_errors.vm_is_template] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let pool_migrate = call + ~in_oss_since:None + ~in_product_since:rel_rio + ~name:"pool_migrate" + ~doc:"Migrate a VM to another Host." + ~params:[Ref _vm, "vm", "The VM to migrate"; + Ref _host, "host", "The target host"; + Map(String, String), "options", "Extra configuration operations" ] + ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.vm_is_template; Api_errors.operation_not_allowed; Api_errors.vm_migrate_failed] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let pool_migrate_complete = call + ~in_oss_since:None + ~in_product_since:rel_tampa + ~name:"pool_migrate_complete" + ~doc:"Tell a destination host that migration is complete." + ~params:[Ref _vm, "vm", "The VM which has finished migrating"; + Ref _host, "host", "The target host" ] + ~hide_from_docs:true + ~pool_internal:false (* needed for cross-pool migrate too *) + ~allowed_roles:_R_VM_POWER_ADMIN + () + + +let set_vcpus_number_live = call + ~name:"set_VCPUs_number_live" + ~in_product_since:rel_rio + ~lifecycle:[ + Published, rel_rio, "Set the number of VCPUs for a running VM"; + Changed, rel_ely, "Unless the feature is explicitly enabled for every host in the pool, this fails with Api_errors.license_restriction."; + ] + ~doc:"Set the number of VCPUs for a running VM" + ~params:[Ref _vm, "self", "The VM"; + Int, "nvcpu", "The number of VCPUs"] + ~allowed_roles:_R_VM_ADMIN + ~errs:[Api_errors.operation_not_allowed; Api_errors.license_restriction] + () + +let set_VCPUs_max = call ~flags:[`Session] + ~name:"set_VCPUs_max" + ~in_product_since:rel_midnight_ride + ~doc:"Set the maximum number of VCPUs for a halted VM" + ~params:[Ref _vm, "self", "The VM"; + Int, "value", "The new maximum number of VCPUs"] + ~allowed_roles:_R_VM_ADMIN + () + +let set_VCPUs_at_startup = call ~flags:[`Session] + ~name:"set_VCPUs_at_startup" + ~in_product_since:rel_midnight_ride + ~doc:"Set the number of startup VCPUs for a halted VM" + ~params:[Ref _vm, "self", "The VM"; + Int, "value", "The new maximum number of VCPUs"] + ~allowed_roles:_R_VM_ADMIN + () + +let set_HVM_shadow_multiplier = call ~flags:[`Session] + ~name:"set_HVM_shadow_multiplier" + ~in_product_since:rel_midnight_ride + ~doc:"Set the shadow memory multiplier on a halted VM" + ~params:[Ref _vm, "self", "The VM"; + Float, "value", "The new shadow memory multiplier to set"] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let set_shadow_multiplier_live = call + ~name:"set_shadow_multiplier_live" + ~in_product_since:rel_rio + ~doc:"Set the shadow memory multiplier on a running VM" + ~params:[Ref _vm, "self", "The VM"; + Float, "multiplier", "The new shadow memory multiplier to set"] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let add_to_VCPUs_params_live = call + ~name:"add_to_VCPUs_params_live" + ~in_product_since:rel_rio + ~doc:"Add the given key-value pair to VM.VCPUs_params, and apply that value on the running VM" + ~params:[Ref _vm, "self", "The VM"; + String, "key", "The key"; + String, "value", "The value"] + ~allowed_roles:_R_VM_ADMIN + () + +let send_sysrq = call + ~name:"send_sysrq" + ~in_product_since:rel_rio + ~doc:"Send the given key as a sysrq to this VM. The key is specified as a single character (a String of length 1). This can only be called when the specified VM is in the Running state." + ~params:[Ref _vm, "vm", "The VM"; + String, "key", "The key to send"] + ~errs:[Api_errors.vm_bad_power_state] + ~allowed_roles:_R_POOL_ADMIN + () + +let send_trigger = call + ~name:"send_trigger" + ~in_product_since:rel_rio + ~doc:"Send the named trigger to this VM. This can only be called when the specified VM is in the Running state." + ~params:[Ref _vm, "vm", "The VM"; + String, "trigger", "The trigger to send"] + ~errs:[Api_errors.vm_bad_power_state] + ~allowed_roles:_R_POOL_ADMIN + () + +let migrate_send = call + ~name: "migrate_send" + ~in_product_since:rel_tampa + ~doc: "Migrate the VM to another host. This can only be called when the specified VM is in the Running state." + ~versioned_params: + [{param_type=Ref _vm; param_name="vm"; param_doc="The VM"; param_release=tampa_release; param_default=None}; + {param_type=Map(String,String); param_name="dest"; param_doc="The result of a Host.migrate_receive call."; param_release=tampa_release; param_default=None}; + {param_type=Bool; param_name="live"; param_doc="Live migration"; param_release=tampa_release; param_default=None}; + {param_type=Map (Ref _vdi, Ref _sr); param_name="vdi_map"; param_doc="Map of source VDI to destination SR"; param_release=tampa_release; param_default=None}; + {param_type=Map (Ref _vif, Ref _network); param_name="vif_map"; param_doc="Map of source VIF to destination network"; param_release=tampa_release; param_default=None}; + {param_type=Map (String, String); param_name="options"; param_doc="Other parameters"; param_release=tampa_release; param_default=None}; + {param_type=Map (Ref _vgpu, Ref _gpu_group); param_name="vgpu_map"; param_doc="Map of source vGPU to destination GPU group"; param_release=inverness_release; param_default=Some (VMap [])} ] - ~result:(Bool, "true if the VM is currently 'co-operative'; false otherwise") - ~allowed_roles:_R_READ_ONLY - ~doc_tags:[Memory] - () - - let query_services = call - ~name:"query_services" - ~in_product_since:rel_tampa - ~doc:"Query the system services advertised by this VM and register them. This can only be applied to a system domain." - ~params:[ - Ref _vm, "self", "The VM"; + ~result:(Ref _vm, "The reference of the newly created VM in the destination pool") + ~errs:[Api_errors.vm_bad_power_state; Api_errors.license_restriction] + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let assert_can_migrate = call + ~name:"assert_can_migrate" + ~in_product_since:rel_tampa + ~doc:"Assert whether a VM can be migrated to the specified destination." + ~versioned_params: + [{param_type=Ref _vm; param_name="vm"; param_doc="The VM"; param_release=tampa_release; param_default=None}; + {param_type=Map(String,String); param_name="dest"; param_doc="The result of a VM.migrate_receive call."; param_release=tampa_release; param_default=None}; + {param_type=Bool; param_name="live"; param_doc="Live migration"; param_release=tampa_release; param_default=None}; + {param_type=Map (Ref _vdi, Ref _sr); param_name="vdi_map"; param_doc="Map of source VDI to destination SR"; param_release=tampa_release; param_default=None}; + {param_type=Map (Ref _vif, Ref _network); param_name="vif_map"; param_doc="Map of source VIF to destination network"; param_release=tampa_release; param_default=None}; + {param_type=Map (String, String); param_name="options"; param_doc="Other parameters"; param_release=tampa_release; param_default=None}; + {param_type=Map (Ref _vgpu, Ref _gpu_group); param_name="vgpu_map"; param_doc="Map of source vGPU to destination GPU group"; param_release=inverness_release; param_default=Some (VMap [])} ] - ~result:(Map(String, String), "map of service type to name") - ~allowed_roles:_R_POOL_ADMIN - () - - (* VM.StartOn *) - - let start_on = call - ~in_product_since:rel_rio - ~name:"start_on" - ~doc:"Start the specified VM on a particular host. This function can only be called with the VM is in the Halted State." - ~in_oss_since:None - ~params:[Ref _vm, "vm", "The VM to start"; - Ref _host, "host", "The Host on which to start the VM"; - Bool, "start_paused", "Instantiate VM in paused state if set to true."; - Bool, "force", "Attempt to force the VM to start. If this flag is false then the VM may fail pre-boot safety checks (e.g. if the CPU the VM last booted on looks substantially different to the current one)"; - ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.vm_is_template; Api_errors.other_operation_in_progress; - Api_errors.operation_not_allowed; - Api_errors.bootloader_failed; - Api_errors.unknown_bootloader; - ] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - (* VM.Pause *) - - let pause = call - ~in_product_since:rel_rio - ~name:"pause" - ~doc:"Pause the specified VM. This can only be called when the specified VM is in the Running state." - ~params:[Ref _vm, "vm", "The VM to pause"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; - Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - (* VM.UnPause *) - - let unpause = call - ~in_product_since:rel_rio - ~name:"unpause" - ~doc:"Resume the specified VM. This can only be called when the specified VM is in the Paused state." - ~params:[Ref _vm, "vm", "The VM to unpause"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - - (* VM.CleanShutdown *) - - let cleanShutdown = call - ~in_product_since:rel_rio - ~name:"clean_shutdown" - ~doc:"Attempt to cleanly shutdown the specified VM. (Note: this may not be supported---e.g. if a guest agent is not installed). This can only be called when the specified VM is in the Running state." - ~params:[Ref _vm, "vm", "The VM to shutdown"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; - Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - (* VM.CleanReboot *) - - let cleanReboot = call - ~in_product_since:rel_rio - ~name:"clean_reboot" - ~doc:"Attempt to cleanly shutdown the specified VM (Note: this may not be supported---e.g. if a guest agent is not installed). This can only be called when the specified VM is in the Running state." - ~params:[Ref _vm, "vm", "The VM to shutdown"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; - Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - (* VM.HardShutdown *) - - let hardShutdown = call - ~in_product_since:rel_rio - ~name:"hard_shutdown" - ~doc:"Stop executing the specified VM without attempting a clean shutdown." - ~params:[Ref _vm, "vm", "The VM to destroy"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; - Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - (* VM.Shutdown *) - - let shutdown = call - ~in_product_since:rel_clearwater - ~name:"shutdown" - ~doc:"Attempts to first clean shutdown a VM and if it should fail then perform a hard shutdown on it." - ~params:[Ref _vm, "vm", "The VM to shutdown"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; - Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - (* VM.PowerStateReset *) - - let stateReset = call - ~in_product_since:rel_rio - ~name:"power_state_reset" - ~doc:"Reset the power-state of the VM to halted in the database only. (Used to recover from slave failures in pooling scenarios by resetting the power-states of VMs running on dead slaves to halted.) This is a potentially dangerous operation; use with care." - ~params:[Ref _vm, "vm", "The VM to reset"] - ~errs:[] - ~allowed_roles:_R_POOL_OP - () - - (* VM.HardReboot *) - - let hardReboot = call - ~in_product_since:rel_rio - ~name:"hard_reboot" - ~doc:"Stop executing the specified VM without attempting a clean shutdown and immediately restart the VM." - ~params:[Ref _vm, "vm", "The VM to reboot"] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; - Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - let hardReboot_internal = call - ~in_product_since:rel_orlando - ~name:"hard_reboot_internal" - ~doc:"Internal function which immediately restarts the specified VM." - ~params:[Ref _vm, "vm", "The VM to reboot"] - ~pool_internal:true - ~hide_from_docs:true - ~internal_deprecated_since:rel_midnight_ride - ~allowed_roles:_R_LOCAL_ROOT_ONLY - () - - (* VM.Hibernate *) - - let suspend = call - ~in_product_since:rel_rio - ~name:"suspend" - ~doc:"Suspend the specified VM to disk. This can only be called when the specified VM is in the Running state." - ~params:[Ref _vm, "vm", "The VM to suspend"] - (* Bool, "live", "If set to true, perform a live hibernate; otherwise suspend the VM before commencing hibernate" *) - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.operation_not_allowed; - Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - (* VM.clsp -- clone suspended, undocumented API for VMLogix *) - let csvm = call - ~name:"csvm" - ~in_product_since:rel_rio - ~doc:"undocumented. internal use only. This call is deprecated." - ~params:[Ref _vm, "vm", ""] - ~result:(Ref _vm, "") - ~errs:(errnames_of_call clone) - ~hide_from_docs:true - ~internal_deprecated_since:rel_miami - ~allowed_roles:_R_VM_ADMIN - () - - (* VM.UnHibernate *) - - let resume = call - ~name:"resume" - ~in_product_since:rel_rio - ~doc:"Awaken the specified VM and resume it. This can only be called when the specified VM is in the Suspended state." - ~params:[Ref _vm, "vm", "The VM to resume"; - Bool, "start_paused", "Resume VM in paused state if set to true."; - Bool, "force", "Attempt to force the VM to resume. If this flag is false then the VM may fail pre-resume safety checks (e.g. if the CPU the VM was running on looks substantially different to the current one)"; - ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; Api_errors.vm_is_template] - ~allowed_roles:_R_VM_OP - () - - let resume_on = call - ~name:"resume_on" - ~in_product_since:rel_rio - ~doc:"Awaken the specified VM and resume it on a particular Host. This can only be called when the specified VM is in the Suspended state." - ~in_oss_since:None - ~params:[Ref _vm, "vm", "The VM to resume"; - Ref _host, "host", "The Host on which to resume the VM"; - Bool, "start_paused", "Resume VM in paused state if set to true."; - Bool, "force", "Attempt to force the VM to resume. If this flag is false then the VM may fail pre-resume safety checks (e.g. if the CPU the VM was running on looks substantially different to the current one)"; - ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.operation_not_allowed; Api_errors.vm_is_template] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let pool_migrate = call - ~in_oss_since:None - ~in_product_since:rel_rio - ~name:"pool_migrate" - ~doc:"Migrate a VM to another Host." - ~params:[Ref _vm, "vm", "The VM to migrate"; - Ref _host, "host", "The target host"; - Map(String, String), "options", "Extra configuration operations" ] - ~errs:[Api_errors.vm_bad_power_state; Api_errors.other_operation_in_progress; Api_errors.vm_is_template; Api_errors.operation_not_allowed; Api_errors.vm_migrate_failed] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let pool_migrate_complete = call - ~in_oss_since:None - ~in_product_since:rel_tampa - ~name:"pool_migrate_complete" - ~doc:"Tell a destination host that migration is complete." - ~params:[Ref _vm, "vm", "The VM which has finished migrating"; - Ref _host, "host", "The target host" ] - ~hide_from_docs:true - ~pool_internal:false (* needed for cross-pool migrate too *) - ~allowed_roles:_R_VM_POWER_ADMIN - () - - - let set_vcpus_number_live = call - ~name:"set_VCPUs_number_live" - ~in_product_since:rel_rio - ~lifecycle:[ - Published, rel_rio, "Set the number of VCPUs for a running VM"; - Changed, rel_ely, "Unless the feature is explicitly enabled for every host in the pool, this fails with Api_errors.license_restriction."; + ~allowed_roles:_R_VM_POWER_ADMIN + ~errs:[Api_errors.license_restriction] + () + +let assert_can_migrate_sender = call + ~name:"assert_can_migrate_sender" + ~lifecycle:[] + ~doc:"Assertions for VM.assert_can_migrate that must be done on the sending host." + ~params:[ + Ref _vm, "vm", "The VM"; + Map(String,String), "dest", "The result of a VM.migrate_receive call."; + Bool, "live", "Live migration"; + Map (Ref _vdi, Ref _sr), "vdi_map", "Map of source VDI to destination SR"; + Map (Ref _vif, Ref _network), "vif_map", "Map of source VIF to destination network"; + Map (Ref _vgpu, Ref _gpu_group), "vgpu_map", "Map of source vGPU to destination GPU group"; + Map (String, String), "options", "Other parameters" ] + ~allowed_roles:_R_VM_POWER_ADMIN + ~hide_from_docs:true + () + +let s3_suspend = call + ~name: "s3_suspend" + ~in_product_since:rel_midnight_ride + ~doc:"Try to put the VM into ACPI S3 state" + ~params:[Ref _vm, "vm", "The VM"] + ~hide_from_docs:true + ~allowed_roles:_R_VM_OP + () + +let s3_resume = call + ~name: "s3_resume" + ~in_product_since:rel_midnight_ride + ~doc:"Try to resume the VM from ACPI S3 state" + ~params:[Ref _vm, "vm", "The VM"] + ~hide_from_docs:true + ~allowed_roles:_R_VM_OP + () + + +let create_new_blob = call + ~name: "create_new_blob" + ~in_product_since:rel_orlando + ~doc:"Create a placeholder for a named binary blob of data that is associated with this VM" + ~versioned_params: + [{param_type=Ref _vm; param_name="vm"; param_doc="The VM"; param_release=orlando_release; param_default=None}; + {param_type=String; param_name="name"; param_doc="The name associated with the blob"; param_release=orlando_release; param_default=None}; + {param_type=String; param_name="mime_type"; param_doc="The mime type for the data. Empty string translates to application/octet-stream"; param_release=orlando_release; param_default=None}; + {param_type=Bool; param_name="public"; param_doc="True if the blob should be publicly available"; param_release=tampa_release; param_default=Some (VBool false)} ] - ~doc:"Set the number of VCPUs for a running VM" - ~params:[Ref _vm, "self", "The VM"; - Int, "nvcpu", "The number of VCPUs"] - ~allowed_roles:_R_VM_ADMIN - ~errs:[Api_errors.operation_not_allowed; Api_errors.license_restriction] - () - - let set_VCPUs_max = call ~flags:[`Session] - ~name:"set_VCPUs_max" - ~in_product_since:rel_midnight_ride - ~doc:"Set the maximum number of VCPUs for a halted VM" - ~params:[Ref _vm, "self", "The VM"; - Int, "value", "The new maximum number of VCPUs"] - ~allowed_roles:_R_VM_ADMIN - () - - let set_VCPUs_at_startup = call ~flags:[`Session] - ~name:"set_VCPUs_at_startup" - ~in_product_since:rel_midnight_ride - ~doc:"Set the number of startup VCPUs for a halted VM" - ~params:[Ref _vm, "self", "The VM"; - Int, "value", "The new maximum number of VCPUs"] - ~allowed_roles:_R_VM_ADMIN - () - - let set_HVM_shadow_multiplier = call ~flags:[`Session] - ~name:"set_HVM_shadow_multiplier" - ~in_product_since:rel_midnight_ride - ~doc:"Set the shadow memory multiplier on a halted VM" - ~params:[Ref _vm, "self", "The VM"; - Float, "value", "The new shadow memory multiplier to set"] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let set_shadow_multiplier_live = call - ~name:"set_shadow_multiplier_live" - ~in_product_since:rel_rio - ~doc:"Set the shadow memory multiplier on a running VM" - ~params:[Ref _vm, "self", "The VM"; - Float, "multiplier", "The new shadow memory multiplier to set"] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let add_to_VCPUs_params_live = call - ~name:"add_to_VCPUs_params_live" - ~in_product_since:rel_rio - ~doc:"Add the given key-value pair to VM.VCPUs_params, and apply that value on the running VM" - ~params:[Ref _vm, "self", "The VM"; - String, "key", "The key"; - String, "value", "The value"] - ~allowed_roles:_R_VM_ADMIN - () - - let send_sysrq = call - ~name:"send_sysrq" - ~in_product_since:rel_rio - ~doc:"Send the given key as a sysrq to this VM. The key is specified as a single character (a String of length 1). This can only be called when the specified VM is in the Running state." - ~params:[Ref _vm, "vm", "The VM"; - String, "key", "The key to send"] - ~errs:[Api_errors.vm_bad_power_state] - ~allowed_roles:_R_POOL_ADMIN - () - - let send_trigger = call - ~name:"send_trigger" - ~in_product_since:rel_rio - ~doc:"Send the named trigger to this VM. This can only be called when the specified VM is in the Running state." - ~params:[Ref _vm, "vm", "The VM"; - String, "trigger", "The trigger to send"] - ~errs:[Api_errors.vm_bad_power_state] - ~allowed_roles:_R_POOL_ADMIN - () - - let migrate_send = call - ~name: "migrate_send" - ~in_product_since:rel_tampa - ~doc: "Migrate the VM to another host. This can only be called when the specified VM is in the Running state." - ~versioned_params: - [{param_type=Ref _vm; param_name="vm"; param_doc="The VM"; param_release=tampa_release; param_default=None}; - {param_type=Map(String,String); param_name="dest"; param_doc="The result of a Host.migrate_receive call."; param_release=tampa_release; param_default=None}; - {param_type=Bool; param_name="live"; param_doc="Live migration"; param_release=tampa_release; param_default=None}; - {param_type=Map (Ref _vdi, Ref _sr); param_name="vdi_map"; param_doc="Map of source VDI to destination SR"; param_release=tampa_release; param_default=None}; - {param_type=Map (Ref _vif, Ref _network); param_name="vif_map"; param_doc="Map of source VIF to destination network"; param_release=tampa_release; param_default=None}; - {param_type=Map (String, String); param_name="options"; param_doc="Other parameters"; param_release=tampa_release; param_default=None}; - {param_type=Map (Ref _vgpu, Ref _gpu_group); param_name="vgpu_map"; param_doc="Map of source vGPU to destination GPU group"; param_release=inverness_release; param_default=Some (VMap [])} - ] - ~result:(Ref _vm, "The reference of the newly created VM in the destination pool") - ~errs:[Api_errors.vm_bad_power_state; Api_errors.license_restriction] - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let assert_can_migrate = call - ~name:"assert_can_migrate" - ~in_product_since:rel_tampa - ~doc:"Assert whether a VM can be migrated to the specified destination." - ~versioned_params: - [{param_type=Ref _vm; param_name="vm"; param_doc="The VM"; param_release=tampa_release; param_default=None}; - {param_type=Map(String,String); param_name="dest"; param_doc="The result of a VM.migrate_receive call."; param_release=tampa_release; param_default=None}; - {param_type=Bool; param_name="live"; param_doc="Live migration"; param_release=tampa_release; param_default=None}; - {param_type=Map (Ref _vdi, Ref _sr); param_name="vdi_map"; param_doc="Map of source VDI to destination SR"; param_release=tampa_release; param_default=None}; - {param_type=Map (Ref _vif, Ref _network); param_name="vif_map"; param_doc="Map of source VIF to destination network"; param_release=tampa_release; param_default=None}; - {param_type=Map (String, String); param_name="options"; param_doc="Other parameters"; param_release=tampa_release; param_default=None}; - {param_type=Map (Ref _vgpu, Ref _gpu_group); param_name="vgpu_map"; param_doc="Map of source vGPU to destination GPU group"; param_release=inverness_release; param_default=Some (VMap [])} - ] - ~allowed_roles:_R_VM_POWER_ADMIN - ~errs:[Api_errors.license_restriction] - () - - let assert_can_migrate_sender = call - ~name:"assert_can_migrate_sender" - ~lifecycle:[] - ~doc:"Assertions for VM.assert_can_migrate that must be done on the sending host." - ~params:[ - Ref _vm, "vm", "The VM"; - Map(String,String), "dest", "The result of a VM.migrate_receive call."; - Bool, "live", "Live migration"; - Map (Ref _vdi, Ref _sr), "vdi_map", "Map of source VDI to destination SR"; - Map (Ref _vif, Ref _network), "vif_map", "Map of source VIF to destination network"; - Map (Ref _vgpu, Ref _gpu_group), "vgpu_map", "Map of source vGPU to destination GPU group"; - Map (String, String), "options", "Other parameters" ] - ~allowed_roles:_R_VM_POWER_ADMIN - ~hide_from_docs:true - () - - let s3_suspend = call - ~name: "s3_suspend" - ~in_product_since:rel_midnight_ride - ~doc:"Try to put the VM into ACPI S3 state" - ~params:[Ref _vm, "vm", "The VM"] - ~hide_from_docs:true - ~allowed_roles:_R_VM_OP - () - - let s3_resume = call - ~name: "s3_resume" - ~in_product_since:rel_midnight_ride - ~doc:"Try to resume the VM from ACPI S3 state" - ~params:[Ref _vm, "vm", "The VM"] - ~hide_from_docs:true - ~allowed_roles:_R_VM_OP - () - - - let create_new_blob = call - ~name: "create_new_blob" - ~in_product_since:rel_orlando - ~doc:"Create a placeholder for a named binary blob of data that is associated with this VM" - ~versioned_params: - [{param_type=Ref _vm; param_name="vm"; param_doc="The VM"; param_release=orlando_release; param_default=None}; - {param_type=String; param_name="name"; param_doc="The name associated with the blob"; param_release=orlando_release; param_default=None}; - {param_type=String; param_name="mime_type"; param_doc="The mime type for the data. Empty string translates to application/octet-stream"; param_release=orlando_release; param_default=None}; - {param_type=Bool; param_name="public"; param_doc="True if the blob should be publicly available"; param_release=tampa_release; param_default=Some (VBool false)} - ] - ~result:(Ref _blob, "The reference of the blob, needed for populating its data") - ~allowed_roles:_R_VM_POWER_ADMIN - () - - let set_bios_strings = call - ~name: "set_bios_strings" - ~in_product_since:rel_inverness - ~doc:"Set custom BIOS strings to this VM. VM will be given a default set of BIOS strings, only some of which can be overridden by the supplied values. Allowed keys are: 'bios-vendor', 'bios-version', 'system-manufacturer', 'system-product-name', 'system-version', 'system-serial-number', 'enclosure-asset-tag'" - ~params:[Ref _vm, "self", "The VM to modify"; - Map (String, String), "value", "The custom BIOS strings as a list of key-value pairs"] - ~allowed_roles:_R_VM_ADMIN - ~errs:[Api_errors.vm_bios_strings_already_set; Api_errors.invalid_value] - () - - let copy_bios_strings = call - ~name: "copy_bios_strings" - ~in_product_since:rel_midnight_ride - ~doc:"Copy the BIOS strings from the given host to this VM" - ~params:[Ref _vm, "vm", "The VM to modify"; - Ref _host, "host", "The host to copy the BIOS strings from";] - ~allowed_roles:_R_VM_ADMIN - () - - let set_protection_policy = call - ~name:"set_protection_policy" - ~in_oss_since:None - ~in_product_since:rel_orlando - ~doc:"Set the value of the protection_policy field" - ~params:[Ref _vm, "self", "The VM"; - Ref _vmpp, "value", "The value"] - ~flags:[`Session] - ~allowed_roles:_R_POOL_OP - () - - let set_snapshot_schedule = call - ~name:"set_snapshot_schedule" - ~in_oss_since:None - ~in_product_since:rel_falcon - ~doc:"Set the value of the snapshot schedule field" - ~params:[Ref _vm, "self", "The VM"; - Ref _vmss, "value", "The value"] - ~flags:[`Session] - ~allowed_roles:_R_POOL_OP - () - - let set_start_delay = call - ~name:"set_start_delay" - ~in_product_since:rel_boston - ~doc:"Set this VM's start delay in seconds" - ~params:[Ref _vm, "self", "The VM"; - Int, "value", "This VM's start delay in seconds"] - ~allowed_roles:_R_POOL_OP - () - - let set_shutdown_delay = call - ~name:"set_shutdown_delay" - ~in_product_since:rel_boston - ~doc:"Set this VM's shutdown delay in seconds" - ~params:[Ref _vm, "self", "The VM"; - Int, "value", "This VM's shutdown delay in seconds"] - ~allowed_roles:_R_POOL_OP - () - - let set_order = call - ~name:"set_order" - ~in_product_since:rel_boston - ~doc:"Set this VM's boot order" - ~params:[Ref _vm, "self", "The VM"; - Int, "value", "This VM's boot order"] - ~allowed_roles:_R_POOL_OP - () - - let set_suspend_VDI = call - ~name:"set_suspend_VDI" - ~in_product_since:rel_boston - ~doc:"Set this VM's suspend VDI, which must be indentical to its current one" - ~params:[Ref _vm, "self", "The VM"; - Ref _vdi, "value", "The suspend VDI uuid"] - ~allowed_roles:_R_POOL_OP - () - - let assert_can_be_recovered = call - ~name:"assert_can_be_recovered" - ~in_product_since:rel_boston - ~doc:"Assert whether all SRs required to recover this VM are available." - ~params:[Ref _vm, "self", "The VM to recover"; - Ref _session, "session_to", "The session to which the VM is to be recovered."] - ~errs:[Api_errors.vm_is_part_of_an_appliance; Api_errors.vm_requires_sr] - ~allowed_roles:_R_READ_ONLY - () - - let get_SRs_required_for_recovery = call - ~name:"get_SRs_required_for_recovery" - ~in_product_since:rel_creedence - ~doc:"List all the SR's that are required for the VM to be recovered" - ~params:[Ref _vm , "self" , "The VM for which the SRs have to be recovered"; - Ref _session , "session_to" , "The session to which the SRs of the VM have to be recovered."] - ~result:(Set(Ref _sr),"refs for SRs required to recover the VM") - ~errs:[] - ~allowed_roles:_R_READ_ONLY - () - - let recover = call - ~name:"recover" - ~in_product_since:rel_boston - ~doc:"Recover the VM" - ~params:[Ref _vm, "self", "The VM to recover"; - Ref _session, "session_to", "The session to which the VM is to be recovered."; - Bool, "force", "Whether the VM should replace newer versions of itself."] - ~allowed_roles:_R_READ_ONLY - () - - let set_appliance = call - ~name:"set_appliance" - ~in_product_since:rel_boston - ~doc:"Assign this VM to an appliance." - ~params:[Ref _vm, "self", "The VM to assign to an appliance."; - Ref _vm_appliance, "value", "The appliance to which this VM should be assigned."] - ~allowed_roles:_R_POOL_OP - () - - let call_plugin = call - ~name:"call_plugin" - ~in_product_since:rel_cream - ~doc:"Call a XenAPI plugin on this vm" - ~params:[Ref _vm, "vm", "The vm"; - String, "plugin", "The name of the plugin"; - String, "fn", "The name of the function within the plugin"; - Map(String, String), "args", "Arguments for the function"] - ~result:(String, "Result from the plugin") - ~allowed_roles:_R_VM_OP - () - - let set_has_vendor_device = call - ~name:"set_has_vendor_device" - ~in_product_since:rel_dundee - ~doc:"Controls whether, when the VM starts in HVM mode, its virtual hardware will include the emulated PCI device for which drivers may be available through Windows Update. Usually this should never be changed on a VM on which Windows has been installed: changing it on such a VM is likely to lead to a crash on next start." - ~params:[Ref _vm, "self", "The VM on which to set this flag"; - Bool, "value", "True to provide the vendor PCI device."] - ~allowed_roles:_R_VM_ADMIN - ~doc_tags:[Windows] - () - - let import = call - ~name:"import" - ~in_product_since:rel_dundee - ~doc:"Import an XVA from a URI" - ~params:[String, "url", "The URL of the XVA file"; - Ref _sr, "sr", "The destination SR for the disks"; - Bool, "full_restore", "Perform a full restore"; - Bool, "force", "Force the import" - ] - ~result:(Set(Ref _vm), "Imported VM reference") - ~allowed_roles:_R_POOL_OP - () - let operations = - Enum ("vm_operations", - List.map operation_enum - [ snapshot; clone; copy; create_template; revert; checkpoint; snapshot_with_quiesce; - provision; start; start_on; pause; unpause; cleanShutdown; - cleanReboot; hardShutdown; stateReset; hardReboot; - suspend; csvm; resume; resume_on; - pool_migrate; - migrate_send; - get_boot_record; send_sysrq; send_trigger; - query_services;shutdown; - call_plugin; - ] - @ [ "changing_memory_live", "Changing the memory settings"; - "awaiting_memory_live", "Waiting for the memory settings to change"; - "changing_dynamic_range", "Changing the memory dynamic range"; - "changing_static_range", "Changing the memory static range"; - "changing_memory_limits", "Changing the memory limits"; - "changing_shadow_memory", "Changing the shadow memory for a halted VM."; - "changing_shadow_memory_live", "Changing the shadow memory for a running VM."; - "changing_VCPUs", "Changing VCPU settings for a halted VM."; - "changing_VCPUs_live", "Changing VCPU settings for a running VM."; - "assert_operation_valid", ""; - "data_source_op", "Add, remove, query or list data sources"; - "update_allowed_operations", ""; - "make_into_template", "Turning this VM into a template"; - "import", "importing a VM from a network stream"; - "export", "exporting a VM to a network stream"; - "metadata_export", "exporting VM metadata to a network stream"; - "reverting", "Reverting the VM to a previous snapshotted state"; - "destroy", "refers to the act of uninstalling the VM"; + ~result:(Ref _blob, "The reference of the blob, needed for populating its data") + ~allowed_roles:_R_VM_POWER_ADMIN + () + +let set_bios_strings = call + ~name: "set_bios_strings" + ~in_product_since:rel_inverness + ~doc:"Set custom BIOS strings to this VM. VM will be given a default set of BIOS strings, only some of which can be overridden by the supplied values. Allowed keys are: 'bios-vendor', 'bios-version', 'system-manufacturer', 'system-product-name', 'system-version', 'system-serial-number', 'enclosure-asset-tag'" + ~params:[Ref _vm, "self", "The VM to modify"; + Map (String, String), "value", "The custom BIOS strings as a list of key-value pairs"] + ~allowed_roles:_R_VM_ADMIN + ~errs:[Api_errors.vm_bios_strings_already_set; Api_errors.invalid_value] + () + +let copy_bios_strings = call + ~name: "copy_bios_strings" + ~in_product_since:rel_midnight_ride + ~doc:"Copy the BIOS strings from the given host to this VM" + ~params:[Ref _vm, "vm", "The VM to modify"; + Ref _host, "host", "The host to copy the BIOS strings from";] + ~allowed_roles:_R_VM_ADMIN + () + +let set_protection_policy = call + ~name:"set_protection_policy" + ~in_oss_since:None + ~in_product_since:rel_orlando + ~doc:"Set the value of the protection_policy field" + ~params:[Ref _vm, "self", "The VM"; + Ref _vmpp, "value", "The value"] + ~flags:[`Session] + ~allowed_roles:_R_POOL_OP + () + +let set_snapshot_schedule = call + ~name:"set_snapshot_schedule" + ~in_oss_since:None + ~in_product_since:rel_falcon + ~doc:"Set the value of the snapshot schedule field" + ~params:[Ref _vm, "self", "The VM"; + Ref _vmss, "value", "The value"] + ~flags:[`Session] + ~allowed_roles:_R_POOL_OP + () + +let set_start_delay = call + ~name:"set_start_delay" + ~in_product_since:rel_boston + ~doc:"Set this VM's start delay in seconds" + ~params:[Ref _vm, "self", "The VM"; + Int, "value", "This VM's start delay in seconds"] + ~allowed_roles:_R_POOL_OP + () + +let set_shutdown_delay = call + ~name:"set_shutdown_delay" + ~in_product_since:rel_boston + ~doc:"Set this VM's shutdown delay in seconds" + ~params:[Ref _vm, "self", "The VM"; + Int, "value", "This VM's shutdown delay in seconds"] + ~allowed_roles:_R_POOL_OP + () + +let set_order = call + ~name:"set_order" + ~in_product_since:rel_boston + ~doc:"Set this VM's boot order" + ~params:[Ref _vm, "self", "The VM"; + Int, "value", "This VM's boot order"] + ~allowed_roles:_R_POOL_OP + () + +let set_suspend_VDI = call + ~name:"set_suspend_VDI" + ~in_product_since:rel_boston + ~doc:"Set this VM's suspend VDI, which must be indentical to its current one" + ~params:[Ref _vm, "self", "The VM"; + Ref _vdi, "value", "The suspend VDI uuid"] + ~allowed_roles:_R_POOL_OP + () + +let assert_can_be_recovered = call + ~name:"assert_can_be_recovered" + ~in_product_since:rel_boston + ~doc:"Assert whether all SRs required to recover this VM are available." + ~params:[Ref _vm, "self", "The VM to recover"; + Ref _session, "session_to", "The session to which the VM is to be recovered."] + ~errs:[Api_errors.vm_is_part_of_an_appliance; Api_errors.vm_requires_sr] + ~allowed_roles:_R_READ_ONLY + () + +let get_SRs_required_for_recovery = call + ~name:"get_SRs_required_for_recovery" + ~in_product_since:rel_creedence + ~doc:"List all the SR's that are required for the VM to be recovered" + ~params:[Ref _vm , "self" , "The VM for which the SRs have to be recovered"; + Ref _session , "session_to" , "The session to which the SRs of the VM have to be recovered."] + ~result:(Set(Ref _sr),"refs for SRs required to recover the VM") + ~errs:[] + ~allowed_roles:_R_READ_ONLY + () + +let recover = call + ~name:"recover" + ~in_product_since:rel_boston + ~doc:"Recover the VM" + ~params:[Ref _vm, "self", "The VM to recover"; + Ref _session, "session_to", "The session to which the VM is to be recovered."; + Bool, "force", "Whether the VM should replace newer versions of itself."] + ~allowed_roles:_R_READ_ONLY + () + +let set_appliance = call + ~name:"set_appliance" + ~in_product_since:rel_boston + ~doc:"Assign this VM to an appliance." + ~params:[Ref _vm, "self", "The VM to assign to an appliance."; + Ref _vm_appliance, "value", "The appliance to which this VM should be assigned."] + ~allowed_roles:_R_POOL_OP + () + +let call_plugin = call + ~name:"call_plugin" + ~in_product_since:rel_cream + ~doc:"Call a XenAPI plugin on this vm" + ~params:[Ref _vm, "vm", "The vm"; + String, "plugin", "The name of the plugin"; + String, "fn", "The name of the function within the plugin"; + Map(String, String), "args", "Arguments for the function"] + ~result:(String, "Result from the plugin") + ~allowed_roles:_R_VM_OP + () + +let set_has_vendor_device = call + ~name:"set_has_vendor_device" + ~in_product_since:rel_dundee + ~doc:"Controls whether, when the VM starts in HVM mode, its virtual hardware will include the emulated PCI device for which drivers may be available through Windows Update. Usually this should never be changed on a VM on which Windows has been installed: changing it on such a VM is likely to lead to a crash on next start." + ~params:[Ref _vm, "self", "The VM on which to set this flag"; + Bool, "value", "True to provide the vendor PCI device."] + ~allowed_roles:_R_VM_ADMIN + ~doc_tags:[Windows] + () + +let import = call + ~name:"import" + ~in_product_since:rel_dundee + ~doc:"Import an XVA from a URI" + ~params:[String, "url", "The URL of the XVA file"; + Ref _sr, "sr", "The destination SR for the disks"; + Bool, "full_restore", "Perform a full restore"; + Bool, "force", "Force the import" ] - ) + ~result:(Set(Ref _vm), "Imported VM reference") + ~allowed_roles:_R_POOL_OP + () +let operations = + Enum ("vm_operations", + List.map operation_enum + [ snapshot; clone; copy; create_template; revert; checkpoint; snapshot_with_quiesce; + provision; start; start_on; pause; unpause; cleanShutdown; + cleanReboot; hardShutdown; stateReset; hardReboot; + suspend; csvm; resume; resume_on; + pool_migrate; + migrate_send; + get_boot_record; send_sysrq; send_trigger; + query_services;shutdown; + call_plugin; + ] + @ [ "changing_memory_live", "Changing the memory settings"; + "awaiting_memory_live", "Waiting for the memory settings to change"; + "changing_dynamic_range", "Changing the memory dynamic range"; + "changing_static_range", "Changing the memory static range"; + "changing_memory_limits", "Changing the memory limits"; + "changing_shadow_memory", "Changing the shadow memory for a halted VM."; + "changing_shadow_memory_live", "Changing the shadow memory for a running VM."; + "changing_VCPUs", "Changing VCPU settings for a halted VM."; + "changing_VCPUs_live", "Changing VCPU settings for a running VM."; + "assert_operation_valid", ""; + "data_source_op", "Add, remove, query or list data sources"; + "update_allowed_operations", ""; + "make_into_template", "Turning this VM into a template"; + "import", "importing a VM from a network stream"; + "export", "exporting a VM to a network stream"; + "metadata_export", "exporting VM metadata to a network stream"; + "reverting", "Reverting the VM to a previous snapshotted state"; + "destroy", "refers to the act of uninstalling the VM"; + ] + ) let assert_operation_valid = call ~in_oss_since:None @@ -1202,200 +1202,200 @@ let domain_type = "unspecified", "Not specified or unknown domain type" ]) let set_domain_type = call ~flags:[`Session] - ~name:"set_domain_type" - ~lifecycle:[Published, rel_kolkata, ""] - ~params:[ - Ref _vm, "self", "The VM"; - domain_type, "value", "The new domain type" - ] - ~doc:"Set the VM.domain_type field of the given VM, which will take effect when it is next started" - ~allowed_roles:_R_VM_ADMIN - () + ~name:"set_domain_type" + ~lifecycle:[Published, rel_kolkata, ""] + ~params:[ + Ref _vm, "self", "The VM"; + domain_type, "value", "The new domain type" + ] + ~doc:"Set the VM.domain_type field of the given VM, which will take effect when it is next started" + ~allowed_roles:_R_VM_ADMIN + () let set_HVM_boot_policy = call ~flags:[`Session] - ~name:"set_HVM_boot_policy" - ~lifecycle:[Published, rel_rio, ""; Deprecated, rel_kolkata, "Replaced by VM.set_domain_type"] - ~params:[ - Ref _vm, "self", "The VM"; - String, "value", "The new HVM boot policy" - ] - ~doc:"Set the VM.HVM_boot_policy field of the given VM, which will take effect when it is next started" - ~allowed_roles:_R_VM_ADMIN - () - - (** VM (or 'guest') configuration: *) - let t = - create_obj ~in_db:true ~in_product_since:rel_rio ~in_oss_since:oss_since_303 ~internal_deprecated_since:None ~persist:PersistEverything ~gen_constructor_destructor:true ~name:_vm ~descr:"A virtual machine (or 'guest')." - ~gen_events:true - ~doccomments:[ "destroy", "Destroy the specified VM. The VM is completely removed from the system. This function can only be called when the VM is in the Halted State."; - "create", "NOT RECOMMENDED! VM.clone or VM.copy (or VM.import) is a better choice in almost all situations. The standard way to obtain a new VM is to call VM.clone on a template VM, then call VM.provision on the new clone. Caution: if VM.create is used and then the new VM is attached to a virtual disc that has an operating system already installed, then there is no guarantee that the operating system will boot and run. Any software that calls VM.create on a future version of this API may fail or give unexpected results. For example this could happen if an additional parameter were added to VM.create. VM.create is intended only for use in the automatic creation of the system VM templates. It creates a new VM instance, and returns its handle."; - ] - ~lifecycle:[ - Published, rel_rio, ""; - ] - ~messages_default_allowed_roles:_R_VM_ADMIN - ~messages:[ snapshot; snapshot_with_quiesce; clone; copy; revert; checkpoint; - provision; start; start_on; pause; unpause; cleanShutdown;shutdown; - cleanReboot; hardShutdown; stateReset; hardReboot; suspend; csvm; resume; - set_is_default_template; - hardReboot_internal; - resume_on; - pool_migrate; pool_migrate_complete; - set_vcpus_number_live; - add_to_VCPUs_params_live; - set_ha_restart_priority; (* updates the allowed-operations of the VM *) - set_ha_always_run; (* updates the allowed-operations of the VM *) - compute_memory_overhead; - set_memory_dynamic_max; - set_memory_dynamic_min; - set_memory_dynamic_range; - set_memory_static_max; - set_memory_static_min; - set_memory_static_range; - set_memory_limits; - set_memory; - set_memory_target_live; - wait_memory_target_live; - get_cooperative; - set_HVM_shadow_multiplier; - set_shadow_multiplier_live; - set_VCPUs_max; - set_VCPUs_at_startup; - send_sysrq; send_trigger; - maximise_memory; - migrate_send; - assert_can_migrate; - assert_can_migrate_sender; - get_boot_record; - get_data_sources; record_data_source; query_data_source; forget_data_source_archives; - assert_operation_valid; - update_allowed_operations; - get_allowed_VBD_devices; - get_allowed_VIF_devices; - get_possible_hosts; - assert_can_boot_here; - atomic_set_resident_on; - create_new_blob; - s3_suspend; - s3_resume; - assert_agile; - update_snapshot_metadata; - retrieve_wlb_recommendations; - set_bios_strings; - copy_bios_strings; - set_protection_policy; - set_snapshot_schedule; - set_start_delay; - set_shutdown_delay; - set_order; - set_suspend_VDI; - assert_can_be_recovered; - get_SRs_required_for_recovery; - recover; - import_convert; - set_appliance; - query_services; - call_plugin; - set_has_vendor_device; - import; - set_actions_after_crash; - set_domain_type; - set_HVM_boot_policy; - ] - ~contents: - ([ uid _vm; - ] @ (allowed_and_current_operations operations) @ [ - field ~writer_roles:_R_VM_OP ~qualifier:DynamicRO ~ty:power_state "power_state" "Current power state of the machine"; - namespace ~name:"name" ~contents:(names oss_since_303 RW) (); - - field ~ty:Int "user_version" "Creators of VMs and templates may store version information here."; - field ~effect:true ~ty:Bool "is_a_template" "true if this is a template. Template VMs can never be started, they are used only for cloning other VMs"; - field ~ty:Bool ~default_value:(Some (VBool false)) ~qualifier:DynamicRO ~writer_roles:_R_POOL_ADMIN ~lifecycle:[Published, rel_falcon, "Identifies XenServer default templates"] "is_default_template" "true if this is a default template. Default template VMs can never be started or migrated, they are used only for cloning other VMs"; - field ~qualifier:DynamicRO ~ty:(Ref _vdi) "suspend_VDI" "The VDI that a suspend image is stored on. (Only has meaning if VM is currently suspended)"; - - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~ty:(Ref _host) "resident_on" "the host the VM is currently resident on"; - field ~writer_roles:_R_VM_POWER_ADMIN ~in_oss_since:None ~internal_only:true ~qualifier:DynamicRO ~ty:(Ref _host) "scheduled_to_be_resident_on" "the host on which the VM is due to be started/resumed/migrated. This acts as a memory reservation indicator"; - field ~writer_roles:_R_VM_POWER_ADMIN ~in_oss_since:None ~ty:(Ref _host) "affinity" "A host which the VM has some affinity for (or NULL). This is used as a hint to the start call when it decides where to run the VM. Resource constraints may cause the VM to be started elsewhere."; - - namespace ~name:"memory" ~contents:guest_memory (); - namespace ~name:"VCPUs" ~contents:vcpus (); - namespace ~name:"actions" ~contents:actions (); - - field ~writer_roles:_R_POOL_ADMIN ~qualifier:DynamicRO ~ty:(Set (Ref _console)) "consoles" "virtual console devices"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _vif)) ~doc_tags:[Networking] "VIFs" "virtual network interfaces"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _vbd)) "VBDs" "virtual block devices"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _vusb)) "VUSBs" "vitual usb devices"; - field ~writer_roles:_R_POOL_ADMIN ~qualifier:DynamicRO ~ty:(Set (Ref _crashdump)) "crash_dumps" "crash dumps associated with this VM"; - field ~qualifier:DynamicRO ~ty:(Set (Ref _vtpm)) "VTPMs" "virtual TPMs"; - - namespace ~name:"PV" ~contents:pv (); - namespace ~name:"HVM" ~contents:hvm (); - field ~ty:(Map(String, String)) "platform" "platform-specific configuration"; - - field ~lifecycle:[ - Published, rel_rio, "PCI bus path for pass-through devices"; - Deprecated, rel_boston, "Field was never used"] - "PCI_bus" "PCI bus path for pass-through devices"; - field ~ty:(Map(String, String)) "other_config" "additional configuration" ~map_keys_roles:["pci", _R_POOL_ADMIN; ("folder",(_R_VM_OP));("XenCenter.CustomFields.*",(_R_VM_OP))]; - field ~qualifier:DynamicRO ~ty:Int "domid" "domain ID (if available, -1 otherwise)"; - field ~qualifier:DynamicRO ~in_oss_since:None ~ty:String "domarch" "Domain architecture (if available, null string otherwise)"; - field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Map(String, String)) "last_boot_CPU_flags" "describes the CPU flags on which the VM was last booted"; - field ~qualifier:DynamicRO ~ty:Bool "is_control_domain" "true if this is a control domain (domain 0 or a driver domain)"; - field ~qualifier:DynamicRO ~ty:(Ref _vm_metrics) "metrics" "metrics associated with this VM"; - field ~qualifier:DynamicRO ~ty:(Ref _vm_guest_metrics) "guest_metrics" "metrics associated with the running guest"; - (* This was an internal field in Rio, Miami beta1, Miami beta2 but is now exposed so that - it will be included automatically in Miami GA exports and can be restored, important if - the VM is in a suspended state *) - field ~in_oss_since:None ~internal_only:false ~in_product_since:rel_miami ~qualifier:DynamicRO ~ty:String "last_booted_record" "marshalled value containing VM record at time of last boot, updated dynamically to reflect the runtime state of the domain" ~default_value:(Some (VString "")); - field ~in_oss_since:None ~ty:String "recommendations" "An XML specification of recommended values and ranges for properties of this VM"; - field ~effect:true ~in_oss_since:None ~ty:(Map(String, String)) ~in_product_since:rel_miami ~qualifier:RW "xenstore_data" "data to be inserted into the xenstore tree (/local/domain//vm-data) after the VM is created." ~default_value:(Some (VMap [])); - field ~writer_roles:_R_POOL_OP ~in_oss_since:None ~ty:Bool ~in_product_since:rel_orlando ~internal_deprecated_since:rel_boston ~qualifier:StaticRO "ha_always_run" "if true then the system will attempt to keep the VM running as much as possible." ~default_value:(Some (VBool false)); - field ~writer_roles:_R_POOL_OP ~in_oss_since:None ~ty:String ~in_product_since:rel_orlando ~qualifier:StaticRO "ha_restart_priority" "has possible values: \"best-effort\" meaning \"try to restart this VM if possible but don't consider the Pool to be overcommitted if this is not possible\"; \"restart\" meaning \"this VM should be restarted\"; \"\" meaning \"do not try to restart this VM\"" ~default_value:(Some (VString "")); - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VBool false)) ~ty:Bool "is_a_snapshot" "true if this is a snapshot. Snapshotted VMs can never be started, they are used only for cloning other VMs"; - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VRef "")) ~ty:(Ref _vm) "snapshot_of" "Ref pointing to the VM this snapshot is of."; - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Set (Ref _vm)) "snapshots" "List pointing to all the VM snapshots."; - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VDateTime Date.never)) ~ty:DateTime "snapshot_time" "Date/time when this snapshot was created."; - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VString "")) ~ty:String "transportable_snapshot_id" "Transportable ID of the snapshot VM"; - field ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Map(String, Ref _blob)) ~default_value:(Some (VMap [])) "blobs" "Binary blobs associated with this VM"; - field ~writer_roles:_R_VM_OP ~in_product_since:rel_orlando ~default_value:(Some (VSet [])) ~ty:(Set String) "tags" "user-specified tags for categorization purposes"; - field ~in_product_since:rel_orlando ~default_value:(Some (VMap [])) ~qualifier:RW ~ty:(Map(operations, String)) "blocked_operations" "List of operations which have been explicitly blocked and an error code"; - - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map (String, String)) "snapshot_info" "Human-readable information concerning this snapshot"; - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VString "")) ~ty:String "snapshot_metadata" "Encoded information about the VM's metadata this is a snapshot of"; - - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VRef "")) ~ty:(Ref _vm) "parent" "Ref pointing to the parent of this VM"; - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~ty:(Set (Ref _vm)) "children" "List pointing to all the children of this VM"; - - field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map (String,String)) "bios_strings" "BIOS strings"; - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:StaticRO ~lifecycle:[Published, rel_cowley, ""; Deprecated, rel_clearwater, "The VMPR feature was removed"] ~default_value:(Some (VRef null_ref)) ~ty:(Ref _vmpp) "protection_policy" "Ref pointing to a protection policy for this VM"; - field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~lifecycle:[Published, rel_cowley, ""; Deprecated, rel_clearwater, "The VMPR feature was removed"] ~default_value:(Some (VBool false)) ~ty:Bool "is_snapshot_from_vmpp" "true if this snapshot was created by the protection policy"; - - field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:StaticRO ~in_product_since:rel_falcon ~default_value:(Some (VRef (null_ref))) ~ty:(Ref _vmss) "snapshot_schedule" "Ref pointing to a snapshot schedule for this VM"; - field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_falcon ~default_value:(Some (VBool false)) ~ty:Bool "is_vmss_snapshot" "true if this snapshot was created by the snapshot schedule"; - - field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~ty:(Ref _vm_appliance) ~default_value:(Some (VRef null_ref)) "appliance" "the appliance to which this VM belongs"; - field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "start_delay" "The delay to wait before proceeding to the next order in the startup sequence (seconds)"; - field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "shutdown_delay" "The delay to wait before proceeding to the next order in the shutdown sequence (seconds)"; - field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "order" "The point in the startup or shutdown sequence at which this VM will be started"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _vgpu)) "VGPUs" "Virtual GPUs"; - field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _pci)) "attached_PCIs" "Currently passed-through PCI devices"; - field ~writer_roles:_R_VM_ADMIN ~qualifier:RW ~in_product_since:rel_boston ~default_value:(Some (VRef null_ref)) ~ty:(Ref _sr) "suspend_SR" "The SR on which a suspend image is stored"; - field ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "version" "The number of times this VM has been recovered"; - field ~qualifier:StaticRO ~in_product_since:rel_clearwater ~default_value:(Some (VString "0:0")) ~ty:(String) "generation_id" "Generation ID of the VM"; - field ~writer_roles:_R_VM_ADMIN ~qualifier:RW ~in_product_since:rel_cream ~default_value:(Some (VInt 0L)) ~ty:Int "hardware_platform_version" "The host virtual hardware platform version the VM can run on"; - field ~qualifier:StaticRO ~lifecycle:[Published, rel_dundee, ""] ~doc_tags:[Windows] ~default_value:(Some (VCustom (String.concat "\n" [ - "(try Rpc.Bool ("; - "let pool = List.hd (Db_actions.DB_Action.Pool.get_all ~__context) in"; - "let restrictions = Db_actions.DB_Action.Pool.get_restrictions ~__context ~self:pool in "; - "let vendor_device_allowed = try List.assoc \"restrict_pci_device_for_auto_update\" restrictions = \"false\" with _ -> false in"; - "let policy_says_its_ok = not (Db_actions.DB_Action.Pool.get_policy_no_vendor_device ~__context ~self:pool) in"; - "vendor_device_allowed && policy_says_its_ok) with e -> D.error \"Failure when defaulting has_vendor_device field: %s\" (Printexc.to_string e); Rpc.Bool false)"], VBool false))) - ~ty:Bool "has_vendor_device" "When an HVM guest starts, this controls the presence of the emulated C000 PCI device which triggers Windows Update to fetch or update PV drivers."; - field ~qualifier:DynamicRO ~ty:Bool ~lifecycle:[Published, rel_ely, ""] ~default_value:(Some (VBool false)) - "requires_reboot" "Indicates whether a VM requires a reboot in order to update its configuration, e.g. its memory allocation."; - field ~qualifier:StaticRO ~ty:String ~in_product_since:rel_ely ~default_value:(Some (VString "")) "reference_label" "Textual reference to the template used to create a VM. This can be used by clients in need of an immutable reference to the template since the latter's uuid and name_label may change, for example, after a package installation or upgrade."; - field ~qualifier:StaticRO ~ty:domain_type ~lifecycle:[Published, rel_jura, ""] ~default_value:(Some (VEnum "unspecified")) "domain_type" "The type of domain that will be created when the VM is started"; - ]) - () + ~name:"set_HVM_boot_policy" + ~lifecycle:[Published, rel_rio, ""; Deprecated, rel_kolkata, "Replaced by VM.set_domain_type"] + ~params:[ + Ref _vm, "self", "The VM"; + String, "value", "The new HVM boot policy" + ] + ~doc:"Set the VM.HVM_boot_policy field of the given VM, which will take effect when it is next started" + ~allowed_roles:_R_VM_ADMIN + () + +(** VM (or 'guest') configuration: *) +let t = + create_obj ~in_db:true ~in_product_since:rel_rio ~in_oss_since:oss_since_303 ~internal_deprecated_since:None ~persist:PersistEverything ~gen_constructor_destructor:true ~name:_vm ~descr:"A virtual machine (or 'guest')." + ~gen_events:true + ~doccomments:[ "destroy", "Destroy the specified VM. The VM is completely removed from the system. This function can only be called when the VM is in the Halted State."; + "create", "NOT RECOMMENDED! VM.clone or VM.copy (or VM.import) is a better choice in almost all situations. The standard way to obtain a new VM is to call VM.clone on a template VM, then call VM.provision on the new clone. Caution: if VM.create is used and then the new VM is attached to a virtual disc that has an operating system already installed, then there is no guarantee that the operating system will boot and run. Any software that calls VM.create on a future version of this API may fail or give unexpected results. For example this could happen if an additional parameter were added to VM.create. VM.create is intended only for use in the automatic creation of the system VM templates. It creates a new VM instance, and returns its handle."; + ] + ~lifecycle:[ + Published, rel_rio, ""; + ] + ~messages_default_allowed_roles:_R_VM_ADMIN + ~messages:[ snapshot; snapshot_with_quiesce; clone; copy; revert; checkpoint; + provision; start; start_on; pause; unpause; cleanShutdown;shutdown; + cleanReboot; hardShutdown; stateReset; hardReboot; suspend; csvm; resume; + set_is_default_template; + hardReboot_internal; + resume_on; + pool_migrate; pool_migrate_complete; + set_vcpus_number_live; + add_to_VCPUs_params_live; + set_ha_restart_priority; (* updates the allowed-operations of the VM *) + set_ha_always_run; (* updates the allowed-operations of the VM *) + compute_memory_overhead; + set_memory_dynamic_max; + set_memory_dynamic_min; + set_memory_dynamic_range; + set_memory_static_max; + set_memory_static_min; + set_memory_static_range; + set_memory_limits; + set_memory; + set_memory_target_live; + wait_memory_target_live; + get_cooperative; + set_HVM_shadow_multiplier; + set_shadow_multiplier_live; + set_VCPUs_max; + set_VCPUs_at_startup; + send_sysrq; send_trigger; + maximise_memory; + migrate_send; + assert_can_migrate; + assert_can_migrate_sender; + get_boot_record; + get_data_sources; record_data_source; query_data_source; forget_data_source_archives; + assert_operation_valid; + update_allowed_operations; + get_allowed_VBD_devices; + get_allowed_VIF_devices; + get_possible_hosts; + assert_can_boot_here; + atomic_set_resident_on; + create_new_blob; + s3_suspend; + s3_resume; + assert_agile; + update_snapshot_metadata; + retrieve_wlb_recommendations; + set_bios_strings; + copy_bios_strings; + set_protection_policy; + set_snapshot_schedule; + set_start_delay; + set_shutdown_delay; + set_order; + set_suspend_VDI; + assert_can_be_recovered; + get_SRs_required_for_recovery; + recover; + import_convert; + set_appliance; + query_services; + call_plugin; + set_has_vendor_device; + import; + set_actions_after_crash; + set_domain_type; + set_HVM_boot_policy; + ] + ~contents: + ([ uid _vm; + ] @ (allowed_and_current_operations operations) @ [ + field ~writer_roles:_R_VM_OP ~qualifier:DynamicRO ~ty:power_state "power_state" "Current power state of the machine"; + namespace ~name:"name" ~contents:(names oss_since_303 RW) (); + + field ~ty:Int "user_version" "Creators of VMs and templates may store version information here."; + field ~effect:true ~ty:Bool "is_a_template" "true if this is a template. Template VMs can never be started, they are used only for cloning other VMs"; + field ~ty:Bool ~default_value:(Some (VBool false)) ~qualifier:DynamicRO ~writer_roles:_R_POOL_ADMIN ~lifecycle:[Published, rel_falcon, "Identifies XenServer default templates"] "is_default_template" "true if this is a default template. Default template VMs can never be started or migrated, they are used only for cloning other VMs"; + field ~qualifier:DynamicRO ~ty:(Ref _vdi) "suspend_VDI" "The VDI that a suspend image is stored on. (Only has meaning if VM is currently suspended)"; + + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~ty:(Ref _host) "resident_on" "the host the VM is currently resident on"; + field ~writer_roles:_R_VM_POWER_ADMIN ~in_oss_since:None ~internal_only:true ~qualifier:DynamicRO ~ty:(Ref _host) "scheduled_to_be_resident_on" "the host on which the VM is due to be started/resumed/migrated. This acts as a memory reservation indicator"; + field ~writer_roles:_R_VM_POWER_ADMIN ~in_oss_since:None ~ty:(Ref _host) "affinity" "A host which the VM has some affinity for (or NULL). This is used as a hint to the start call when it decides where to run the VM. Resource constraints may cause the VM to be started elsewhere."; + + namespace ~name:"memory" ~contents:guest_memory (); + namespace ~name:"VCPUs" ~contents:vcpus (); + namespace ~name:"actions" ~contents:actions (); + + field ~writer_roles:_R_POOL_ADMIN ~qualifier:DynamicRO ~ty:(Set (Ref _console)) "consoles" "virtual console devices"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _vif)) ~doc_tags:[Networking] "VIFs" "virtual network interfaces"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _vbd)) "VBDs" "virtual block devices"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _vusb)) "VUSBs" "vitual usb devices"; + field ~writer_roles:_R_POOL_ADMIN ~qualifier:DynamicRO ~ty:(Set (Ref _crashdump)) "crash_dumps" "crash dumps associated with this VM"; + field ~qualifier:DynamicRO ~ty:(Set (Ref _vtpm)) "VTPMs" "virtual TPMs"; + + namespace ~name:"PV" ~contents:pv (); + namespace ~name:"HVM" ~contents:hvm (); + field ~ty:(Map(String, String)) "platform" "platform-specific configuration"; + + field ~lifecycle:[ + Published, rel_rio, "PCI bus path for pass-through devices"; + Deprecated, rel_boston, "Field was never used"] + "PCI_bus" "PCI bus path for pass-through devices"; + field ~ty:(Map(String, String)) "other_config" "additional configuration" ~map_keys_roles:["pci", _R_POOL_ADMIN; ("folder",(_R_VM_OP));("XenCenter.CustomFields.*",(_R_VM_OP))]; + field ~qualifier:DynamicRO ~ty:Int "domid" "domain ID (if available, -1 otherwise)"; + field ~qualifier:DynamicRO ~in_oss_since:None ~ty:String "domarch" "Domain architecture (if available, null string otherwise)"; + field ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Map(String, String)) "last_boot_CPU_flags" "describes the CPU flags on which the VM was last booted"; + field ~qualifier:DynamicRO ~ty:Bool "is_control_domain" "true if this is a control domain (domain 0 or a driver domain)"; + field ~qualifier:DynamicRO ~ty:(Ref _vm_metrics) "metrics" "metrics associated with this VM"; + field ~qualifier:DynamicRO ~ty:(Ref _vm_guest_metrics) "guest_metrics" "metrics associated with the running guest"; + (* This was an internal field in Rio, Miami beta1, Miami beta2 but is now exposed so that + it will be included automatically in Miami GA exports and can be restored, important if + the VM is in a suspended state *) + field ~in_oss_since:None ~internal_only:false ~in_product_since:rel_miami ~qualifier:DynamicRO ~ty:String "last_booted_record" "marshalled value containing VM record at time of last boot, updated dynamically to reflect the runtime state of the domain" ~default_value:(Some (VString "")); + field ~in_oss_since:None ~ty:String "recommendations" "An XML specification of recommended values and ranges for properties of this VM"; + field ~effect:true ~in_oss_since:None ~ty:(Map(String, String)) ~in_product_since:rel_miami ~qualifier:RW "xenstore_data" "data to be inserted into the xenstore tree (/local/domain//vm-data) after the VM is created." ~default_value:(Some (VMap [])); + field ~writer_roles:_R_POOL_OP ~in_oss_since:None ~ty:Bool ~in_product_since:rel_orlando ~internal_deprecated_since:rel_boston ~qualifier:StaticRO "ha_always_run" "if true then the system will attempt to keep the VM running as much as possible." ~default_value:(Some (VBool false)); + field ~writer_roles:_R_POOL_OP ~in_oss_since:None ~ty:String ~in_product_since:rel_orlando ~qualifier:StaticRO "ha_restart_priority" "has possible values: \"best-effort\" meaning \"try to restart this VM if possible but don't consider the Pool to be overcommitted if this is not possible\"; \"restart\" meaning \"this VM should be restarted\"; \"\" meaning \"do not try to restart this VM\"" ~default_value:(Some (VString "")); + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VBool false)) ~ty:Bool "is_a_snapshot" "true if this is a snapshot. Snapshotted VMs can never be started, they are used only for cloning other VMs"; + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VRef "")) ~ty:(Ref _vm) "snapshot_of" "Ref pointing to the VM this snapshot is of."; + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Set (Ref _vm)) "snapshots" "List pointing to all the VM snapshots."; + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VDateTime Date.never)) ~ty:DateTime "snapshot_time" "Date/time when this snapshot was created."; + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_orlando ~default_value:(Some (VString "")) ~ty:String "transportable_snapshot_id" "Transportable ID of the snapshot VM"; + field ~qualifier:DynamicRO ~in_product_since:rel_orlando ~ty:(Map(String, Ref _blob)) ~default_value:(Some (VMap [])) "blobs" "Binary blobs associated with this VM"; + field ~writer_roles:_R_VM_OP ~in_product_since:rel_orlando ~default_value:(Some (VSet [])) ~ty:(Set String) "tags" "user-specified tags for categorization purposes"; + field ~in_product_since:rel_orlando ~default_value:(Some (VMap [])) ~qualifier:RW ~ty:(Map(operations, String)) "blocked_operations" "List of operations which have been explicitly blocked and an error code"; + + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map (String, String)) "snapshot_info" "Human-readable information concerning this snapshot"; + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VString "")) ~ty:String "snapshot_metadata" "Encoded information about the VM's metadata this is a snapshot of"; + + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VRef "")) ~ty:(Ref _vm) "parent" "Ref pointing to the parent of this VM"; + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~ty:(Set (Ref _vm)) "children" "List pointing to all the children of this VM"; + + field ~qualifier:DynamicRO ~in_product_since:rel_midnight_ride ~default_value:(Some (VMap [])) ~ty:(Map (String,String)) "bios_strings" "BIOS strings"; + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:StaticRO ~lifecycle:[Published, rel_cowley, ""; Deprecated, rel_clearwater, "The VMPR feature was removed"] ~default_value:(Some (VRef null_ref)) ~ty:(Ref _vmpp) "protection_policy" "Ref pointing to a protection policy for this VM"; + field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~lifecycle:[Published, rel_cowley, ""; Deprecated, rel_clearwater, "The VMPR feature was removed"] ~default_value:(Some (VBool false)) ~ty:Bool "is_snapshot_from_vmpp" "true if this snapshot was created by the protection policy"; + + field ~writer_roles:_R_VM_POWER_ADMIN ~qualifier:StaticRO ~in_product_since:rel_falcon ~default_value:(Some (VRef (null_ref))) ~ty:(Ref _vmss) "snapshot_schedule" "Ref pointing to a snapshot schedule for this VM"; + field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_falcon ~default_value:(Some (VBool false)) ~ty:Bool "is_vmss_snapshot" "true if this snapshot was created by the snapshot schedule"; + + field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~ty:(Ref _vm_appliance) ~default_value:(Some (VRef null_ref)) "appliance" "the appliance to which this VM belongs"; + field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "start_delay" "The delay to wait before proceeding to the next order in the startup sequence (seconds)"; + field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "shutdown_delay" "The delay to wait before proceeding to the next order in the shutdown sequence (seconds)"; + field ~writer_roles:_R_POOL_OP ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "order" "The point in the startup or shutdown sequence at which this VM will be started"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _vgpu)) "VGPUs" "Virtual GPUs"; + field ~qualifier:DynamicRO ~lifecycle:[Published, rel_boston, ""] ~ty:(Set (Ref _pci)) "attached_PCIs" "Currently passed-through PCI devices"; + field ~writer_roles:_R_VM_ADMIN ~qualifier:RW ~in_product_since:rel_boston ~default_value:(Some (VRef null_ref)) ~ty:(Ref _sr) "suspend_SR" "The SR on which a suspend image is stored"; + field ~qualifier:StaticRO ~in_product_since:rel_boston ~default_value:(Some (VInt 0L)) ~ty:Int "version" "The number of times this VM has been recovered"; + field ~qualifier:StaticRO ~in_product_since:rel_clearwater ~default_value:(Some (VString "0:0")) ~ty:(String) "generation_id" "Generation ID of the VM"; + field ~writer_roles:_R_VM_ADMIN ~qualifier:RW ~in_product_since:rel_cream ~default_value:(Some (VInt 0L)) ~ty:Int "hardware_platform_version" "The host virtual hardware platform version the VM can run on"; + field ~qualifier:StaticRO ~lifecycle:[Published, rel_dundee, ""] ~doc_tags:[Windows] ~default_value:(Some (VCustom (String.concat "\n" [ + "(try Rpc.Bool ("; + "let pool = List.hd (Db_actions.DB_Action.Pool.get_all ~__context) in"; + "let restrictions = Db_actions.DB_Action.Pool.get_restrictions ~__context ~self:pool in "; + "let vendor_device_allowed = try List.assoc \"restrict_pci_device_for_auto_update\" restrictions = \"false\" with _ -> false in"; + "let policy_says_its_ok = not (Db_actions.DB_Action.Pool.get_policy_no_vendor_device ~__context ~self:pool) in"; + "vendor_device_allowed && policy_says_its_ok) with e -> D.error \"Failure when defaulting has_vendor_device field: %s\" (Printexc.to_string e); Rpc.Bool false)"], VBool false))) + ~ty:Bool "has_vendor_device" "When an HVM guest starts, this controls the presence of the emulated C000 PCI device which triggers Windows Update to fetch or update PV drivers."; + field ~qualifier:DynamicRO ~ty:Bool ~lifecycle:[Published, rel_ely, ""] ~default_value:(Some (VBool false)) + "requires_reboot" "Indicates whether a VM requires a reboot in order to update its configuration, e.g. its memory allocation."; + field ~qualifier:StaticRO ~ty:String ~in_product_since:rel_ely ~default_value:(Some (VString "")) "reference_label" "Textual reference to the template used to create a VM. This can be used by clients in need of an immutable reference to the template since the latter's uuid and name_label may change, for example, after a package installation or upgrade."; + field ~qualifier:StaticRO ~ty:domain_type ~lifecycle:[Published, rel_jura, ""] ~default_value:(Some (VEnum "unspecified")) "domain_type" "The type of domain that will be created when the VM is started"; + ]) + () diff --git a/ocaml/idl/markdown_backend.ml b/ocaml/idl/markdown_backend.ml index 73794a10d0d..bf21f5a4cbd 100644 --- a/ocaml/idl/markdown_backend.ml +++ b/ocaml/idl/markdown_backend.ml @@ -120,15 +120,15 @@ let markdown_section_of_message printer ~is_class_deprecated ~is_class_removed x printer (sprintf "#### RPC name: %s" (escape x.msg_name)); printer ""; if List.exists is_removal_marker x.msg_lifecycle || is_class_removed then - begin - printer "**This message is removed.**"; - printer "" - end + begin + printer "**This message is removed.**"; + printer "" + end else if List.exists is_deprecation_marker x.msg_lifecycle || is_class_deprecated then - begin - printer "**This message is deprecated.**"; - printer "" - end; + begin + printer "**This message is deprecated.**"; + printer "" + end; printer "_Overview:_"; printer ""; printer (escape x.msg_doc); @@ -137,11 +137,11 @@ let markdown_section_of_message printer ~is_class_deprecated ~is_class_removed x printer ""; printer "```"; printer (sprintf "%s %s (%s)" - (of_ty_opt_verbatim x.msg_result) x.msg_name - (String.concat ", " - ((if x.msg_session then ["session ref session_id"] else []) @ - (List.map (fun p -> of_ty_verbatim p.param_type ^ " " ^ p.param_name) x.msg_params))) - ); + (of_ty_opt_verbatim x.msg_result) x.msg_name + (String.concat ", " + ((if x.msg_session then ["session ref session_id"] else []) @ + (List.map (fun p -> of_ty_verbatim p.param_type ^ " " ^ p.param_name) x.msg_params))) + ); printer "```"; if x.msg_params <> [] then begin @@ -150,12 +150,12 @@ let markdown_section_of_message printer ~is_class_deprecated ~is_class_removed x printer "|type |name |description |"; printer "|:-----------------------------|:-----------------------------|:---------------------------------------|"; if x.msg_session then - printer "|session ref |session_id |Reference to a valid session |"; + printer "|session ref |session_id |Reference to a valid session |"; let get_param_row p = sprintf "|`%s`|%s|%s|" - (pad_right (of_ty_verbatim p.param_type) (col_width_30 - 2)) - (pad_right (escape p.param_name) col_width_30) - (pad_right (escape p.param_doc) col_width_40) + (pad_right (of_ty_verbatim p.param_type) (col_width_30 - 2)) + (pad_right (escape p.param_name) col_width_30) + (pad_right (escape p.param_doc) col_width_40) in List.iter (fun p -> printer (get_param_row p)) x.msg_params; printer ""; @@ -165,13 +165,13 @@ let markdown_section_of_message printer ~is_class_deprecated ~is_class_removed x let descr= desc_of_ty_opt x.msg_result in if descr <> "" then (printer (escape descr); - printer "") + printer "") end; if x.msg_errors <> [] then begin let error_codes = List.map (fun err -> sprintf "`%s`" err.err_name) x.msg_errors in printer (sprintf "_Possible Error Codes:_ %s" - (String.concat ", " error_codes)); + (String.concat ", " error_codes)); printer ""; end @@ -188,14 +188,14 @@ let print_field_table_of_obj printer ~is_class_deprecated ~is_class_removed x = let wired_name = Datamodel_utils.wire_name_of_field y in let descr = (if List.exists is_removal_marker y.lifecycle || is_class_removed then "**Removed**. " - else if List.exists is_deprecation_marker y.lifecycle || is_class_deprecated then "**Deprecated**. " - else "") ^ (escape description) + else if List.exists is_deprecation_marker y.lifecycle || is_class_deprecated then "**Deprecated**. " + else "") ^ (escape description) in printer (sprintf "|%s|`%s`|%s|%s|" - (pad_right (escape wired_name) col_width_20) - (pad_right (of_ty_verbatim ty) (col_width_20 - 2)) - (pad_right (string_of_qualifier qualifier) col_width_15) - (pad_right descr col_width_40)) + (pad_right (escape wired_name) col_width_20) + (pad_right (of_ty_verbatim ty) (col_width_20 - 2)) + (pad_right (string_of_qualifier qualifier) col_width_15) + (pad_right descr col_width_40)) in x |> Datamodel_utils.fields_of_obj @@ -209,15 +209,15 @@ let of_obj printer x = let is_class_removed = List.exists is_removal_marker x.obj_lifecycle in let is_class_deprecated = List.exists is_deprecation_marker x.obj_lifecycle in if is_class_removed then - begin - printer "**This class is removed.**"; - printer "" - end + begin + printer "**This class is removed.**"; + printer "" + end else if is_class_deprecated then - begin - printer "**This class is deprecated.**"; - printer "" - end; + begin + printer "**This class is deprecated.**"; + printer "" + end; printer (escape x.description); printer ""; print_field_table_of_obj printer ~is_class_deprecated ~is_class_removed x; @@ -225,10 +225,10 @@ let of_obj printer x = printer (sprintf "### RPCs associated with class: "^(escape x.name)); printer ""; if x.messages=[] then - begin - printer (sprintf "Class %s has no additional RPCs associated with it." (escape x.name)); - printer "" - end + begin + printer (sprintf "Class %s has no additional RPCs associated with it." (escape x.name)); + printer "" + end else x.messages |> List.sort (fun x y -> compare_case_ins x.msg_name y.msg_name) @@ -237,11 +237,11 @@ let of_obj printer x = let print_enum printer = function | Enum (name, options) -> printer (sprintf "|`enum %s`| |" - (pad_right name (col_width_40 - 7))); + (pad_right name (col_width_40 - 7))); printer "|:---------------------------------------|:---------------------------------------|"; let print_option (opt, description) = printer (sprintf "|`%s`|%s|" - (pad_right opt (col_width_40 - 2)) (pad_right (escape description) col_width_40)) in + (pad_right opt (col_width_40 - 2)) (pad_right (escape description) col_width_40)) in options |> List.sort (fun (x,_) (y,_) -> compare_case_ins x y) |> List.iter print_option; printer ""; @@ -281,11 +281,11 @@ The following classes are defined: let get_descr obj = (if List.exists is_removal_marker obj.obj_lifecycle then "**Removed**. " - else if List.exists is_deprecation_marker obj.obj_lifecycle then "**Deprecated**. " - else "") ^ (escape obj.description) + else if List.exists is_deprecation_marker obj.obj_lifecycle then "**Deprecated**. " + else "") ^ (escape obj.description) in List.iter (fun obj -> printer (sprintf "|`%s`|%s|" - (pad_right obj.name (col_width_20 - 2)) (pad_right (get_descr obj) col_width_70))) + (pad_right obj.name (col_width_20 - 2)) (pad_right (get_descr obj) col_width_70))) system; printer " @@ -300,8 +300,8 @@ Fields that are bound together are shown in the following table: let afield = a^"."^a_field in let bfield = b^"."^b_field in printer (sprintf "|`%s`|`%s`|%s|" - (pad_right afield (col_width_40 - 2)) (pad_right bfield (col_width_40 - 2)) - (pad_right (Relations.string_of_classification c) col_width_15)) + (pad_right afield (col_width_40 - 2)) (pad_right bfield (col_width_40 - 2)) + (pad_right (Relations.string_of_classification c) col_width_15)) ) relations; printer " @@ -345,7 +345,7 @@ The following enumeration types are used: Types.of_objects system |> List.sort type_comparer |> List.iter (print_enum printer); List.iter (fun x -> of_obj printer x) system; - printer " + printer " ## Error Handling When a low-level transport error occurs, or a request is malformed at the HTTP @@ -476,30 +476,30 @@ let json_current_version = let open Xapi_stdext_std.Xstringext in let time = Unix.gettimeofday () in let month, year = - match String.split ' ' (Date.rfc822_to_string (Date.rfc822_of_float time)) with - | [ _; _; m; y; _; _ ] -> m,y - | _ -> failwith "Invalid datetime string" + match String.split ' ' (Date.rfc822_to_string (Date.rfc822_of_float time)) with + | [ _; _; m; y; _; _ ] -> m,y + | _ -> failwith "Invalid datetime string" in `O [ - "api_version_major", `Float (Int64.to_float api_version_major); - "api_version_minor", `Float (Int64.to_float api_version_minor); - "current_year", `String year; - "current_month", `String month; - ] + "api_version_major", `Float (Int64.to_float api_version_major); + "api_version_minor", `Float (Int64.to_float api_version_minor); + "current_year", `String year; + "current_month", `String month; + ] let render_template template_file json output_file = let templ = Xapi_stdext_unix.Unixext.string_of_file template_file |> Mustache.of_string in let rendered = Mustache.render templ json in let out_chan = open_out output_file in finally (fun () -> output_string out_chan rendered) - (fun () -> close_out out_chan) + (fun () -> close_out out_chan) let all api templdir destdir = Xapi_stdext_unix.Unixext.mkdir_rec destdir 0o755; ["cover.mustache", "cover.yaml"; "docbook.mustache", "template.db"] |> List.iter (fun (x,y) -> render_template - (Filename.concat templdir x) json_current_version (Filename.concat destdir y)); + (Filename.concat templdir x) json_current_version (Filename.concat destdir y)); let out_chan = open_out (Filename.concat destdir "api-ref-autogen.md") in let printer text = @@ -507,4 +507,4 @@ let all api templdir destdir = fprintf out_chan "\n" in finally (fun () -> print_all printer api) - (fun () -> close_out out_chan) + (fun () -> close_out out_chan) diff --git a/ocaml/idl/ocaml_backend/gen_api.ml b/ocaml/idl/ocaml_backend/gen_api.ml index 9e679aefcd4..167d942bc2e 100644 --- a/ocaml/idl/ocaml_backend/gen_api.ml +++ b/ocaml/idl/ocaml_backend/gen_api.ml @@ -11,17 +11,17 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. *) - open Printf - - module DT = Datamodel_types - module DU = Datamodel_utils - module OU = Ocaml_utils - - module O = Ocaml_syntax - - let oc = ref stdout - let print s = output_string !oc (s^"\n") - let between = Xapi_stdext_std.Listext.List.between +open Printf + +module DT = Datamodel_types +module DU = Datamodel_utils +module OU = Ocaml_utils + +module O = Ocaml_syntax + +let oc = ref stdout +let print s = output_string !oc (s^"\n") +let between = Xapi_stdext_std.Listext.List.between let overrides = [ "vm_operations_to_string_map",( diff --git a/ocaml/idl/ocaml_backend/ocaml_utils.ml b/ocaml/idl/ocaml_backend/ocaml_utils.ml index 4530049abf2..221d6a3c2c2 100644 --- a/ocaml/idl/ocaml_backend/ocaml_utils.ml +++ b/ocaml/idl/ocaml_backend/ocaml_utils.ml @@ -28,11 +28,11 @@ let escape x = constructors. *) let constructor_of string = let remove_non_alphanum = function - 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> String.make 1 c - | _ -> "" in + 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> String.make 1 c + | _ -> "" in let string = if List.mem string keywords then "_" ^ string else string in let list = match Xapi_stdext_std.Xstringext.String.explode string with - '0'..'9' :: _ as list -> "`_" :: List.map remove_non_alphanum list + '0'..'9' :: _ as list -> "`_" :: List.map remove_non_alphanum list | list -> "`" :: List.map remove_non_alphanum list in String.concat "" list diff --git a/ocaml/pci/examples/lspci.ml b/ocaml/pci/examples/lspci.ml index 61ba3480f9f..56688f79f81 100644 --- a/ocaml/pci/examples/lspci.ml +++ b/ocaml/pci/examples/lspci.ml @@ -5,39 +5,39 @@ let lspci_nnnDv pci_access = let default v = match v with Some v -> v | None -> "" in let devs = get_devices pci_access in List.iter (fun d -> - let open Pci_dev in - Printf.printf "Device: %04x:%02x:%02x.%d\n" - d.domain d.bus d.dev d.func; - Printf.printf "Class: %s [%04x]\n" - (lookup_class_name pci_access d.device_class |> default) d.device_class; - Printf.printf "Vendor: %s [%04x]\n" - (lookup_vendor_name pci_access d.vendor_id |> default) d.vendor_id; - Printf.printf "Device: %s [%04x]\n" - (lookup_device_name pci_access d.vendor_id d.device_id |> default) d.device_id; - begin match d.subsystem_id with - | Some (sv_id, sd_id) -> - Printf.printf "SVendor:\t%s [%04x]\n" - (lookup_subsystem_vendor_name pci_access sv_id |> default) sv_id; - Printf.printf "SDevice:\t%s [%04x]\n" - (lookup_subsystem_device_name pci_access d.vendor_id d.device_id sv_id sd_id |> default) sd_id - | None -> () - end; - begin match d.phy_slot with - | Some slot -> Printf.printf "PhySlot:\t%s\n" slot - | None -> () - end; - print_endline "" - ) devs; + let open Pci_dev in + Printf.printf "Device: %04x:%02x:%02x.%d\n" + d.domain d.bus d.dev d.func; + Printf.printf "Class: %s [%04x]\n" + (lookup_class_name pci_access d.device_class |> default) d.device_class; + Printf.printf "Vendor: %s [%04x]\n" + (lookup_vendor_name pci_access d.vendor_id |> default) d.vendor_id; + Printf.printf "Device: %s [%04x]\n" + (lookup_device_name pci_access d.vendor_id d.device_id |> default) d.device_id; + begin match d.subsystem_id with + | Some (sv_id, sd_id) -> + Printf.printf "SVendor:\t%s [%04x]\n" + (lookup_subsystem_vendor_name pci_access sv_id |> default) sv_id; + Printf.printf "SDevice:\t%s [%04x]\n" + (lookup_subsystem_device_name pci_access d.vendor_id d.device_id sv_id sd_id |> default) sd_id + | None -> () + end; + begin match d.phy_slot with + | Some slot -> Printf.printf "PhySlot:\t%s\n" slot + | None -> () + end; + print_endline "" + ) devs; begin match devs with - | [] -> () - | d::ds -> - let open Pci_dev in - Printf.printf "Getting region sizes for device %04x:%02x:%02x.%d\n" - d.domain d.bus d.dev d.func; - List.iteri (fun i size -> - Printf.printf "\tRegion %d has size %nd\n" i size - ) d.size + | [] -> () + | d::ds -> + let open Pci_dev in + Printf.printf "Getting region sizes for device %04x:%02x:%02x.%d\n" + d.domain d.bus d.dev d.func; + List.iteri (fun i size -> + Printf.printf "\tRegion %d has size %nd\n" i size + ) d.size end; Printf.printf "Looking up name of NVIDIA GRID K160Q..."; diff --git a/ocaml/pci/lib/pci.ml b/ocaml/pci/lib/pci.ml index 4638f6e0c8d..2159f00fccb 100644 --- a/ocaml/pci/lib/pci.ml +++ b/ocaml/pci/lib/pci.ml @@ -57,8 +57,8 @@ module Pci_access = struct let devices t = let rec list_of_linked_list acc = function - | None -> acc - | Some d -> list_of_linked_list (d::acc) (getf !@d B.Pci_dev.next) in + | None -> acc + | Some d -> list_of_linked_list (d::acc) (getf !@d B.Pci_dev.next) in list_of_linked_list [] (getf !@t B.Pci_access.devices) end @@ -87,42 +87,42 @@ let with_string ?(size=1024) f = let lookup_class_name pci_access class_id = with_string (fun buf size -> - B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_class - class_id) + B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_class + class_id) let lookup_progif_name pci_access class_id progif_id = with_string (fun buf size -> - B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_progif - class_id progif_id) + B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_progif + class_id progif_id) let lookup_vendor_name pci_access vendor_id = with_string (fun buf size -> - B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_vendor - vendor_id) + B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_vendor + vendor_id) let lookup_device_name pci_access vendor_id device_id = with_string (fun buf size -> - B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_device - vendor_id device_id) + B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_device + vendor_id device_id) let lookup_subsystem_vendor_name pci_access subv_id = with_string (fun buf size -> - let lookup_flags = T.Lookup_mode.([ lookup_subsystem; lookup_vendor ]) in - B.pci_lookup_name_1_ary pci_access buf size (crush_flags id lookup_flags) - subv_id) + let lookup_flags = T.Lookup_mode.([ lookup_subsystem; lookup_vendor ]) in + B.pci_lookup_name_1_ary pci_access buf size (crush_flags id lookup_flags) + subv_id) let lookup_subsystem_device_name pci_access vendor_id device_id subv_id subd_id = with_string (fun buf size -> - let lookup_flags = T.Lookup_mode.([ lookup_subsystem; lookup_device ]) in - B.pci_lookup_name_4_ary pci_access buf size (crush_flags id lookup_flags) - vendor_id device_id subv_id subd_id) + let lookup_flags = T.Lookup_mode.([ lookup_subsystem; lookup_device ]) in + B.pci_lookup_name_4_ary pci_access buf size (crush_flags id lookup_flags) + vendor_id device_id subv_id subd_id) let with_access ?(cleanup=true) ?from_dump f = let pci_access = B.pci_alloc () in maybe (fun path -> - setf !@pci_access B.Pci_access.method_ T.Access_type.dump; - ignore @@ B.pci_set_param pci_access "dump.name" path; - ) from_dump; + setf !@pci_access B.Pci_access.method_ T.Access_type.dump; + ignore @@ B.pci_set_param pci_access "dump.name" path; + ) from_dump; B.pci_init pci_access; if not cleanup then f pci_access else @@ -140,7 +140,7 @@ let get_devices pci_access = let devs = Pci_access.devices pci_access in (* Be sure to fill all the fields that can be accessed from a Pci_dev.t *) let fill_flags = T.Fill_flag.([ - fill_ident; fill_irq; fill_bases; fill_rom_base; fill_sizes; fill_class; - fill_caps; fill_ext_caps; fill_phys_slot; fill_module_alias; ]) in + fill_ident; fill_irq; fill_bases; fill_rom_base; fill_sizes; fill_class; + fill_caps; fill_ext_caps; fill_phys_slot; fill_module_alias; ]) in let flags = crush_flags id fill_flags in List.map (fun d -> let (_: int) = B.pci_fill_info d flags in Pci_dev.make d) devs diff --git a/ocaml/pci/lib_test/test_pci.ml b/ocaml/pci/lib_test/test_pci.ml index 8df47d0fd2a..0498e61d09c 100644 --- a/ocaml/pci/lib_test/test_pci.ml +++ b/ocaml/pci/lib_test/test_pci.ml @@ -39,33 +39,33 @@ let test_with_access_cleanup () = for i = 1 to 1000 do with_dump ~cleanup:false (fun _ -> ()) done; let mem''' = Gc.compact (); resident_pages () in assert_raises (OUnitTest.OUnit_failure "not equal") (fun () -> - assert_equal mem'' mem''') + assert_equal mem'' mem''') let test_lookup_functions () = (* Subset of `lspci -mnnv` on my system - Class: Bridge [0680] - Vendor: Intel Corporation [8086] - Device: 82371AB/EB/MB PIIX4 ACPI [7113] - SVendor: Red Hat, Inc [1af4] - SDevice: Qemu virtual machine [1100] *) + Class: Bridge [0680] + Vendor: Intel Corporation [8086] + Device: 82371AB/EB/MB PIIX4 ACPI [7113] + SVendor: Red Hat, Inc [1af4] + SDevice: Qemu virtual machine [1100] *) let test_lookup = assert_equal ~printer:(fun x -> x) in let default v = match v with Some v -> v | None -> "" in with_dump (fun acc -> - test_lookup "Bridge" @@ (lookup_class_name acc 0x0680 |> default); - test_lookup "Intel Corporation" @@ (lookup_vendor_name acc 0x8086 |> default); - test_lookup "82371AB/EB/MB PIIX4 ACPI" @@ (lookup_device_name acc 0x8086 0x7113 |> default); - test_lookup "Red Hat, Inc" @@ (lookup_subsystem_vendor_name acc 0x1af4 |> default); - test_lookup "Qemu virtual machine" @@ (lookup_subsystem_device_name acc 0x8086 0x7113 0x1af4 0x1100 |> default); - test_lookup "VGA compatible controller" @@ (lookup_class_name acc 0x0300 |> default); - test_lookup "VGA controller" @@ (lookup_progif_name acc 0x0300 0x00 |> default); - ) + test_lookup "Bridge" @@ (lookup_class_name acc 0x0680 |> default); + test_lookup "Intel Corporation" @@ (lookup_vendor_name acc 0x8086 |> default); + test_lookup "82371AB/EB/MB PIIX4 ACPI" @@ (lookup_device_name acc 0x8086 0x7113 |> default); + test_lookup "Red Hat, Inc" @@ (lookup_subsystem_vendor_name acc 0x1af4 |> default); + test_lookup "Qemu virtual machine" @@ (lookup_subsystem_device_name acc 0x8086 0x7113 0x1af4 0x1100 |> default); + test_lookup "VGA compatible controller" @@ (lookup_class_name acc 0x0300 |> default); + test_lookup "VGA controller" @@ (lookup_progif_name acc 0x0300 0x00 |> default); + ) let _ = let suite = "pci" >::: - [ - "smoke_test" >:: smoke_test; - "test_with_access_cleanup" >:: test_with_access_cleanup; - "test_lookup_functions" >:: test_lookup_functions; - ] + [ + "smoke_test" >:: smoke_test; + "test_with_access_cleanup" >:: test_with_access_cleanup; + "test_lookup_functions" >:: test_lookup_functions; + ] in OUnit2.run_test_tt_main @@ ounit2_of_ounit1 suite diff --git a/ocaml/pci/stubgen/ffi_stubgen.ml b/ocaml/pci/stubgen/ffi_stubgen.ml index 14a1ee86c33..00cb739ac5b 100644 --- a/ocaml/pci/stubgen/ffi_stubgen.ml +++ b/ocaml/pci/stubgen/ffi_stubgen.ml @@ -2,7 +2,7 @@ let _ = let prefix = "libpci_stub" in let generate_ml, generate_c = ref false, ref false in Arg.(parse [ ("-ml", Set generate_ml, "Generate ML"); - ("-c", Set generate_c, "Generate C") ]) + ("-c", Set generate_c, "Generate C") ]) (fun _ -> failwith "unexpected anonymous argument") "stubgen [-ml|-c]"; match !generate_ml, !generate_c with diff --git a/ocaml/pci/stubgen/ffi_types_stubgen.ml b/ocaml/pci/stubgen/ffi_types_stubgen.ml index 708a1b799cc..04b2e026730 100644 --- a/ocaml/pci/stubgen/ffi_types_stubgen.ml +++ b/ocaml/pci/stubgen/ffi_types_stubgen.ml @@ -1,3 +1,3 @@ let () = - print_endline "#include "; + print_endline "#include "; Cstubs.Types.write_c Format.std_formatter (module Ffi_bindings.Types) diff --git a/ocaml/quicktest/quicktest_cbt.ml b/ocaml/quicktest/quicktest_cbt.ml index 6517b67a001..5fd1b1816b3 100644 --- a/ocaml/quicktest/quicktest_cbt.ml +++ b/ocaml/quicktest/quicktest_cbt.ml @@ -123,9 +123,9 @@ let vdi_data_destroy_test ~session_id ~vDI = ~msg:"VDI.data_destroy failed to update VDI.type"; assert_cbt_status true ~session_id ~test ~vDI:snapshot ~msg:"VDI snapshot cbt_enabled field erroneously set to false"; - (* test_vdi_update ~session_id ~test snapshot; - temporarily comment this out as it is blocked on CA-273981 - VDI.update doesn't currently work on cbt-metadata VDIs *) + (* test_vdi_update ~session_id ~test snapshot; + temporarily comment this out as it is blocked on CA-273981 + VDI.update doesn't currently work on cbt-metadata VDIs *) let content_id_str = "/No content: this is a cbt_metadata VDI/" in test_compare ~test diff --git a/ocaml/quicktest/quicktest_cluster.ml b/ocaml/quicktest/quicktest_cluster.ml index 0b8948686ce..12dd07376f0 100644 --- a/ocaml/quicktest/quicktest_cluster.ml +++ b/ocaml/quicktest/quicktest_cluster.ml @@ -54,8 +54,8 @@ let test_reconfigure_ip ~ipv6 ~session_id ~(self : API.ref_PIF) = failed test "PIF.reconfigure_ip should raise clustering_enabled_on_network." with | Api_errors.(Server_error(code,_)) when code=Api_errors.clustering_enabled_on_network - -> debug test (Printf.sprintf "%s raised as expected." Api_errors.clustering_enabled_on_network); - success test + -> debug test (Printf.sprintf "%s raised as expected." Api_errors.clustering_enabled_on_network); + success test | Api_errors.(Server_error(_,_)) -> () (* Don't fail on other API errors, only test clustering *) | Abort_test s -> failed test s | e -> failed test (ExnHelper.string_of_exn e) @@ -71,22 +71,22 @@ let test session_id = List.iter (fun self -> - let clustering = - let network = C.PIF.get_network ~session_id ~rpc:!rpc ~self in - C.Cluster.get_all ~session_id ~rpc:!rpc - |> List.filter - (fun cluster -> (C.Cluster.get_network ~session_id ~rpc:!rpc ~self:cluster) = network) - |> (fun lst -> not (is_empty lst)) - in - if clustering - then begin - test_reconfigure_ip ~ipv6:false ~session_id ~self - (* IPv6 clusters not yet supported, can run this test once that changes *) - (* test_reconfigure_ip ~ipv6:true ~session_id ~self *) - end - else - debug test_all_pifs "No cluster objects on this PIF, skipping tests." + let clustering = + let network = C.PIF.get_network ~session_id ~rpc:!rpc ~self in + C.Cluster.get_all ~session_id ~rpc:!rpc + |> List.filter + (fun cluster -> (C.Cluster.get_network ~session_id ~rpc:!rpc ~self:cluster) = network) + |> (fun lst -> not (is_empty lst)) + in + if clustering + then begin + test_reconfigure_ip ~ipv6:false ~session_id ~self + (* IPv6 clusters not yet supported, can run this test once that changes *) + (* test_reconfigure_ip ~ipv6:true ~session_id ~self *) + end + else + debug test_all_pifs "No cluster objects on this PIF, skipping tests." ) pifs; - success test_all_pifs + success test_all_pifs with e -> failed test_all_pifs (ExnHelper.string_of_exn e) diff --git a/ocaml/quicktest/quicktest_import_raw_vdi.ml b/ocaml/quicktest/quicktest_import_raw_vdi.ml old mode 100755 new mode 100644 diff --git a/ocaml/quicktest/quicktest_storage.ml b/ocaml/quicktest/quicktest_storage.ml index 051a90d2475..e608e8f732d 100644 --- a/ocaml/quicktest/quicktest_storage.ml +++ b/ocaml/quicktest/quicktest_storage.ml @@ -44,9 +44,9 @@ let list_srs session_id = (List.map (fun pbd -> Client.PBD.get_currently_attached !rpc session_id pbd) pbds)) all (* Filter SR with specific type from CLI *) |> List.filter (fun sr -> - match !only_sr_name with - | None -> true - | Some t -> Client.SR.get_name_label !rpc session_id sr = t) + match !only_sr_name with + | None -> true + | Some t -> Client.SR.get_name_label !rpc session_id sr = t) let name_of_sr session_id sr = let name_label = Client.SR.get_name_label !rpc session_id sr in @@ -307,34 +307,34 @@ let vdi_snapshot_destroy ?(indent=2) caps session_id sr vdi = let vdi_snapshot_in_pool caps session_id sr vdi = if (List.mem vdi_snapshot caps) && (List.mem vdi_attach caps) then begin - let hosts = Client.Host.get_all !rpc session_id in - let do_test () = - vdi_snapshot_destroy ~indent:4 caps session_id sr vdi in - let test_snapshot_on host = - let name = Client.Host.get_name_label !rpc session_id host in - let test = make_test (Printf.sprintf "Checking VDI.snapshot when plugged in to %s" name) 2 in - start test; - let dom0 = dom0_of_host session_id host in - let vbd = vbd_create_helper ~session_id ~vM:dom0 ~vDI:vdi () in - - debug test (Printf.sprintf "Plugging in to host %s" name); - Client.VBD.plug !rpc session_id vbd; - finally do_test - (fun () -> - debug test (Printf.sprintf "Unplugging from host %s" name); - Client.VBD.unplug !rpc session_id vbd; - debug test "Destroying VBD"; - Client.VBD.destroy !rpc session_id vbd - ); - success test - in - List.iter test_snapshot_on hosts; - - let test = make_test (Printf.sprintf "Checking VDI.snapshot when it is not plugged anywhere") 2 in + let hosts = Client.Host.get_all !rpc session_id in + let do_test () = + vdi_snapshot_destroy ~indent:4 caps session_id sr vdi in + let test_snapshot_on host = + let name = Client.Host.get_name_label !rpc session_id host in + let test = make_test (Printf.sprintf "Checking VDI.snapshot when plugged in to %s" name) 2 in start test; - do_test (); + let dom0 = dom0_of_host session_id host in + let vbd = vbd_create_helper ~session_id ~vM:dom0 ~vDI:vdi () in + + debug test (Printf.sprintf "Plugging in to host %s" name); + Client.VBD.plug !rpc session_id vbd; + finally do_test + (fun () -> + debug test (Printf.sprintf "Unplugging from host %s" name); + Client.VBD.unplug !rpc session_id vbd; + debug test "Destroying VBD"; + Client.VBD.destroy !rpc session_id vbd + ); success test - end + in + List.iter test_snapshot_on hosts; + + let test = make_test (Printf.sprintf "Checking VDI.snapshot when it is not plugged anywhere") 2 in + start test; + do_test (); + success test + end (** If VDI_RESIZE is present then try it out *) @@ -623,5 +623,5 @@ let go s = debug test (Printf.sprintf "Found %d SRs" (List.length srs)); success test; if !only_sr_name = None then - packages_iso_test s; + packages_iso_test s; List.iter (foreach_sr s) srs diff --git a/ocaml/tests/test_ca121350.ml b/ocaml/tests/test_ca121350.ml index a576c819f55..41e1ca71b63 100644 --- a/ocaml/tests/test_ca121350.ml +++ b/ocaml/tests/test_ca121350.ml @@ -16,11 +16,11 @@ let test_invalid_edition () = let module M = struct include V6_client ;; let apply_edition _ edition _ = V6_interface.{ - edition = edition; - xapi_params = []; - additional_params = []; - experimental_features = []; - } ;; + edition = edition; + xapi_params = []; + additional_params = []; + experimental_features = []; + } ;; let get_editions _ = [ "free", ("", "", 0); "per-socket", ("", "", 1); diff --git a/ocaml/tests/test_cluster.ml b/ocaml/tests/test_cluster.ml index ce11339d0ae..89ff643549c 100644 --- a/ocaml/tests/test_cluster.ml +++ b/ocaml/tests/test_cluster.ml @@ -18,24 +18,24 @@ let test_clusterd_rpc ~__context call = let token = "test_token" in match call.Rpc.name, call.Rpc.params with | "create", _ -> - Rpc.{success = true; contents = Rpc.String token } + Rpc.{success = true; contents = Rpc.String token } | ("enable" | "disable" | "destroy"), _ -> - Rpc.{success = true; contents = Rpc.Null } + Rpc.{success = true; contents = Rpc.Null } | name, params -> - failwith (Printf.sprintf "Unexpected RPC: %s(%s)" name (String.concat " " (List.map Rpc.to_string params))) + failwith (Printf.sprintf "Unexpected RPC: %s(%s)" name (String.concat " " (List.map Rpc.to_string params))) let test_rpc ~__context call = match call.Rpc.name, call.Rpc.params with | "Cluster_host.destroy", [self] -> - let open API in - Xapi_cluster_host.destroy ~__context ~self:(ref_Cluster_host_of_rpc self); - Rpc.{success = true; contents = Rpc.String "" } + let open API in + Xapi_cluster_host.destroy ~__context ~self:(ref_Cluster_host_of_rpc self); + Rpc.{success = true; contents = Rpc.String "" } | "Cluster.destroy", [_session; self] -> - let open API in - Xapi_cluster.destroy ~__context ~self:(ref_Cluster_of_rpc self); - Rpc.{success = true; contents = Rpc.String "" } + let open API in + Xapi_cluster.destroy ~__context ~self:(ref_Cluster_of_rpc self); + Rpc.{success = true; contents = Rpc.String "" } | name, params -> - failwith (Printf.sprintf "Unexpected RPC: %s(%s)" name (String.concat " " (List.map Rpc.to_string params))) + failwith (Printf.sprintf "Unexpected RPC: %s(%s)" name (String.concat " " (List.map Rpc.to_string params))) let create_cluster ~__context = Context.set_test_rpc __context (test_rpc ~__context); diff --git a/ocaml/tests/test_cluster_host.ml b/ocaml/tests/test_cluster_host.ml index ae7bc1bea22..3b4c597f819 100644 --- a/ocaml/tests/test_cluster_host.ml +++ b/ocaml/tests/test_cluster_host.ml @@ -70,10 +70,10 @@ let test_fix_prereq () = Alcotest.check_raises "Should fail when checking PIF prequisites" (Failure exn) (fun () -> - try - Xapi_cluster_host.fix_pif_prerequisites __context pif - with _ -> - failwith exn); + try + Xapi_cluster_host.fix_pif_prerequisites __context pif + with _ -> + failwith exn); Db.PIF.set_IP ~__context ~self:pifref ~value:"1.1.1.1"; let pif = Xapi_clustering.pif_of_host ~__context network localhost in Xapi_cluster_host.fix_pif_prerequisites ~__context pif; diff --git a/ocaml/tests/test_clustering.ml b/ocaml/tests/test_clustering.ml index 2e6dbe3e19e..231d2f7baae 100644 --- a/ocaml/tests/test_clustering.ml +++ b/ocaml/tests/test_clustering.ml @@ -229,11 +229,11 @@ let nest_with_clustering_lock_if_needed ~__context ~timeout ~type1 ~type2 ~on_de ~otherwise: on_deadlock (fun () -> Xapi_clustering.with_clustering_lock_if_needed ~__context ~sr_sm_type:type1 - (fun () -> - Xapi_clustering.with_clustering_lock_if_needed ~__context ~sr_sm_type:type2 - (fun () -> on_no_deadlock () - ) - ) + (fun () -> + Xapi_clustering.with_clustering_lock_if_needed ~__context ~sr_sm_type:type2 + (fun () -> on_no_deadlock () + ) + ) ) let test_clustering_lock_only_taken_if_needed_nested_calls () = @@ -279,10 +279,10 @@ let test_assert_pif_prerequisites () = "test_assert_pif_prerequisites should fail at first" (Failure exn) (fun () -> - try - Xapi_clustering.assert_pif_prerequisites pif - with _ -> - failwith exn); + try + Xapi_clustering.assert_pif_prerequisites pif + with _ -> + failwith exn); (* Put in IPv4 info *) Db.PIF.set_IP ~__context ~self:pifref ~value:"1.1.1.1"; let pif = Xapi_clustering.pif_of_host ~__context network localhost in @@ -290,20 +290,20 @@ let test_assert_pif_prerequisites () = "test_assert_pif_prerequisites should fail after setting IPv4 info" (Failure exn) (fun () -> - try - Xapi_clustering.assert_pif_prerequisites pif - with _ -> - failwith exn); + try + Xapi_clustering.assert_pif_prerequisites pif + with _ -> + failwith exn); Db.PIF.set_currently_attached ~__context ~self:pifref ~value:true; let pif = Xapi_clustering.pif_of_host ~__context network localhost in Alcotest.check_raises "test_assert_pif_prerequisites should fail after setting attached:true" (Failure exn) (fun () -> - try - Xapi_clustering.assert_pif_prerequisites pif - with _ -> - failwith exn); + try + Xapi_clustering.assert_pif_prerequisites pif + with _ -> + failwith exn); Db.PIF.set_disallow_unplug ~__context ~self:pifref ~value:true; let pif = Xapi_clustering.pif_of_host ~__context network localhost in Alcotest.(check unit) @@ -376,10 +376,10 @@ let test_disallow_unplug_ro_with_clustering_enabled = let test = ( test_get_required_cluster_stacks - @ test_find_cluster_host - @ test_assert_cluster_host_enabled - @ test_assert_cluster_host_is_enabled_for_matching_sms - @ test_clustering_lock_only_taken_if_needed - @ test_assert_pif_prerequisites - @ test_disallow_unplug_ro_with_clustering_enabled + @ test_find_cluster_host + @ test_assert_cluster_host_enabled + @ test_assert_cluster_host_is_enabled_for_matching_sms + @ test_clustering_lock_only_taken_if_needed + @ test_assert_pif_prerequisites + @ test_disallow_unplug_ro_with_clustering_enabled ) diff --git a/ocaml/tests/test_common.ml b/ocaml/tests/test_common.ml index 3311f007904..5af4394d1f6 100644 --- a/ocaml/tests/test_common.ml +++ b/ocaml/tests/test_common.ml @@ -333,7 +333,7 @@ let make_vgpu ~__context ~ref ~uuid ~vM ~gPU_group ~device ~currently_attached ~other_config ~_type ~resident_on ~scheduled_to_be_resident_on ~compatibility_metadata - ; + ; ref let make_vgpu_type ~__context ?(ref=Ref.make ()) ?(uuid=make_uuid ()) @@ -384,16 +384,16 @@ let make_pool_update ~__context ?(other_config=[]) ?(vdi=Ref.null) () = let update_info = Xapi_pool_update. - { uuid - ; name_label - ; name_description - ; version - ; key - ; installation_size - ; after_apply_guidance - ; other_config - ; enforce_homogeneity - } in + { uuid + ; name_label + ; name_description + ; version + ; key + ; installation_size + ; after_apply_guidance + ; other_config + ; enforce_homogeneity + } in Xapi_pool_update.create_update_record ~__context ~update:ref ~update_info ~vdi; ref diff --git a/ocaml/tests/test_cpuid_helpers.ml b/ocaml/tests/test_cpuid_helpers.ml index d9fcce164c4..008fdf378f7 100644 --- a/ocaml/tests/test_cpuid_helpers.ml +++ b/ocaml/tests/test_cpuid_helpers.ml @@ -264,7 +264,7 @@ module Comparisons = Generic.Make (struct (* Below are the more common cases *) (features_of_string "07cbfbff-04082201-20100800-00000001-00000000-00000000-00000000-00000000-00000000", features_of_string "07c9cbf5-80082201-20100800-00000001-00000000-00000000-00000000-00000000-00000000"), - (false, false); + (false, false); ([| 0b00000000L |], [| 0b11111111L |]), (true, true); ([| 0b11111111L |], [| 0b11111111L |]), (true, false); @@ -428,7 +428,7 @@ module ResetCPUFlags = Generic.Make(Generic.EncapsulateState(struct (["a", `pv], [features_pv]); (["a", `pv_in_pvh], [features_hvm]); (["a", `hvm; "b", `pv; "c", `pv_in_pvh], - [features_hvm; features_pv; features_hvm]); + [features_hvm; features_pv; features_hvm]); ] end)) diff --git a/ocaml/tests/test_db_lowlevel.ml b/ocaml/tests/test_db_lowlevel.ml index 3b9f47c6416..591ef50c7f6 100644 --- a/ocaml/tests/test_db_lowlevel.ml +++ b/ocaml/tests/test_db_lowlevel.ml @@ -93,7 +93,7 @@ let test_empty_key_in_map () = (Db_exn.Empty_key_in_map) (fun () -> Db.VM.set_other_config ~__context ~self:vm_ref ~value:["","value"]) - + let test = [ diff --git a/ocaml/tests/test_event.ml b/ocaml/tests/test_event.ml index 0d03cee93ae..bc620f58b1f 100644 --- a/ocaml/tests/test_event.ml +++ b/ocaml/tests/test_event.ml @@ -19,7 +19,7 @@ open Stdext open Threadext let event_setup_common = Test_event_common.event_setup_common - + let test_event_from_ev () = (* Test that creating an object generates an event for that object *) let __context, session_id = event_setup_common () in @@ -227,10 +227,10 @@ let object_level_event_test session_id = Thread.delay 1.0; Mutex.execute m (fun () -> - if not !finished then begin - Printf.printf "FAILURE: Didn't get expected change in event thread\n%!"; - failure := true; - end); + if not !finished then begin + Printf.printf "FAILURE: Didn't get expected change in event thread\n%!"; + failure := true; + end); Mutex.execute m (fun () -> if (!failure) then begin diff --git a/ocaml/tests/test_guest_agent.ml b/ocaml/tests/test_guest_agent.ml index 0d17a6452b8..0601698b4a6 100644 --- a/ocaml/tests/test_guest_agent.ml +++ b/ocaml/tests/test_guest_agent.ml @@ -63,73 +63,73 @@ module Networks = Generic.Make (struct (* basic cases *) [ "attr/vif/0/ipv6/0"; ], [ "attr/vif/0/ipv6/0", "0/ipv6/0"; - ]; + ]; [ "attr/vif/0/ipv4/0"; ], [ "attr/vif/0/ipv4/0", "0/ip"; "attr/vif/0/ipv4/0", "0/ipv4/0"; - ]; + ]; [ "attr/eth0/ip"; ], [ "attr/eth0/ip", "0/ip"; "attr/eth0/ip", "0/ipv4/0"; - ]; + ]; [ "attr/eth0/ipv6/0/addr"; ], [ "attr/eth0/ip", "0/ip"; "attr/eth0/ip", "0/ipv4/0"; "attr/eth0/ipv6/0/addr", "0/ipv6/0"; - ]; + ]; (* index *) [ "attr/vif/1/ipv6/2"; ], [ "attr/vif/1/ipv6/2", "1/ipv6/2"; - ]; + ]; [ "attr/vif/1/ipv4/2"; ], [ "attr/vif/1/ipv4/2", "1/ip"; "attr/vif/1/ipv4/2", "1/ipv4/2"; - ]; + ]; [ "attr/eth1/ip"; ], [ "attr/eth1/ip", "1/ip"; "attr/eth1/ip", "1/ipv4/0"; - ]; + ]; [ "attr/eth1/ipv6/2/addr"; ], [ "attr/eth1/ip", "1/ip"; "attr/eth1/ip", "1/ipv4/0"; "attr/eth1/ipv6/2/addr", "1/ipv6/2"; - ]; + ]; (* multiple ip addrs *) [ "attr/vif/0/ipv6/0"; "attr/vif/0/ipv6/1"; ], [ "attr/vif/0/ipv6/1", "0/ipv6/1"; "attr/vif/0/ipv6/0", "0/ipv6/0"; - ]; + ]; [ "attr/vif/0/ipv4/0"; "attr/vif/0/ipv4/1"; ], [ "attr/vif/0/ipv4/1", "0/ipv4/1"; "attr/vif/0/ipv4/0", "0/ip"; "attr/vif/0/ipv4/0", "0/ipv4/0"; - ]; + ]; [ "attr/eth0/ip"; "attr/eth0/ipv6/0/addr"; ], [ "attr/eth0/ip", "0/ip"; "attr/eth0/ip", "0/ipv4/0"; "attr/eth0/ipv6/0/addr", "0/ipv6/0"; - ]; + ]; [ "attr/vif/0/ipv4/0"; "attr/vif/0/ipv6/0"; ], [ "attr/vif/0/ipv4/0", "0/ip"; "attr/vif/0/ipv4/0", "0/ipv4/0"; "attr/vif/0/ipv6/0", "0/ipv6/0"; - ]; + ]; [ "attr/eth0/ip"; "attr/vif/0/ipv4/0"; @@ -138,7 +138,7 @@ module Networks = Generic.Make (struct ], [ "attr/vif/0/ipv4/0", "0/ip"; "attr/vif/0/ipv4/0", "0/ipv4/0"; "attr/vif/0/ipv6/0", "0/ipv6/0"; - ]; + ]; (* multiple vifs and multiple ip addrs *) [ "attr/vif/0/ipv6/0"; @@ -149,7 +149,7 @@ module Networks = Generic.Make (struct "attr/vif/0/ipv6/0", "0/ipv6/0"; "attr/vif/1/ipv6/1", "1/ipv6/1"; "attr/vif/1/ipv6/0", "1/ipv6/0"; - ]; + ]; [ "attr/vif/0/ipv4/0"; "attr/vif/0/ipv4/1"; @@ -161,7 +161,7 @@ module Networks = Generic.Make (struct "attr/vif/1/ipv4/1", "1/ipv4/1"; "attr/vif/1/ipv4/0", "1/ip"; "attr/vif/1/ipv4/0", "1/ipv4/0"; - ]; + ]; (* exceptions *) [ "attr/vif/0/ipv4/a"; @@ -246,9 +246,9 @@ module Initial_guest_metrics = Generic.Make (struct with Not_found -> None) let lookup mtree path = - let open Stdext.Xstringext in - let paths = String.split_f (fun s -> s = '/') path in - lookup_helper mtree paths + let open Stdext.Xstringext in + let paths = String.split_f (fun s -> s = '/') path in + lookup_helper mtree paths let transform input = @@ -261,68 +261,68 @@ module Initial_guest_metrics = Generic.Make (struct (* basic cases *) [ "attr/vif/0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; ], [ "0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; [ "attr/vif/0/ipv4/0", "192.168.0.1"; ], [ "0/ip", "192.168.0.1"; "0/ipv4/0", "192.168.0.1"; - ]; + ]; [ "attr/eth0/ip", "192.168.0.1"; ], [ "0/ip", "192.168.0.1"; "0/ipv4/0", "192.168.0.1"; - ]; + ]; [ "attr/eth0/ipv6/0/addr", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; ], [ "0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; (* index *) [ "attr/vif/1/ipv6/2", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; ], [ "1/ipv6/2", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; [ "attr/vif/1/ipv4/2", "192.168.0.1"; ], [ "1/ip", "192.168.0.1"; "1/ipv4/2", "192.168.0.1"; - ]; + ]; [ "attr/eth1/ip", "192.168.0.1"; ], [ "1/ip", "192.168.0.1"; "1/ipv4/0", "192.168.0.1"; - ]; + ]; [ "attr/eth1/ipv6/2/addr", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; ], [ "1/ipv6/2", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; (* multiple ip addrs *) [ "attr/vif/0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; "attr/vif/0/ipv6/1", "fe80:0000:0000:0000:7870:94ff:fe52:dd07"; ], [ "0/ipv6/1", "fe80:0000:0000:0000:7870:94ff:fe52:dd07"; "0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; [ "attr/vif/0/ipv4/0", "192.168.0.1"; "attr/vif/0/ipv4/1", "192.168.1.1"; ], [ "0/ipv4/1", "192.168.1.1"; "0/ip", "192.168.0.1"; "0/ipv4/0", "192.168.0.1"; - ]; + ]; [ "attr/eth0/ip", "192.168.0.1"; "attr/eth0/ipv6/0/addr", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; ], [ "0/ip", "192.168.0.1"; "0/ipv4/0", "192.168.0.1"; "0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; [ "attr/vif/0/ipv4/0", "192.168.0.1"; "attr/vif/0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; ], [ "0/ip", "192.168.0.1"; "0/ipv4/0", "192.168.0.1"; "0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; [ "attr/eth0/ip", "192.168.0.1"; "attr/vif/0/ipv4/0", "192.168.0.1"; @@ -331,7 +331,7 @@ module Initial_guest_metrics = Generic.Make (struct ], [ "0/ip", "192.168.0.1"; "0/ipv4/0", "192.168.0.1"; "0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; - ]; + ]; (* multiple vifs and multiple ip addrs *) [ "attr/vif/0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; @@ -342,7 +342,7 @@ module Initial_guest_metrics = Generic.Make (struct "0/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd06"; "1/ipv6/1", "fe80:0000:0000:0000:7870:94ff:fe52:dd17"; "1/ipv6/0", "fe80:0000:0000:0000:7870:94ff:fe52:dd16"; - ]; + ]; [ "attr/vif/0/ipv4/0", "192.168.0.1"; "attr/vif/0/ipv4/1", "192.168.0.2"; @@ -354,7 +354,7 @@ module Initial_guest_metrics = Generic.Make (struct "1/ipv4/1", "192.168.1.2"; "1/ip", "192.168.1.1"; "1/ipv4/0", "192.168.1.1"; - ]; + ]; (* exceptions *) [ "attr/vif/0/ipv4/a", "192.168.0.1"; diff --git a/ocaml/tests/test_host.ml b/ocaml/tests/test_host.ml index f2ad9c25587..ddcdfd5ac3b 100644 --- a/ocaml/tests/test_host.ml +++ b/ocaml/tests/test_host.ml @@ -20,10 +20,10 @@ open D let add_host __context name = ignore(Xapi_host.create ~__context - ~uuid:(Uuid.to_string (Uuid.make_uuid())) - ~name_label:name ~name_description:"" ~hostname:"host2" ~address:"127.0.0.1" - ~external_auth_type:"" ~external_auth_service_name:"" ~external_auth_configuration:[] - ~license_params:[] ~edition:"" ~license_server:[] ~local_cache_sr:(Ref.null) ~chipset_info:[] ~ssl_legacy:false) + ~uuid:(Uuid.to_string (Uuid.make_uuid())) + ~name_label:name ~name_description:"" ~hostname:"host2" ~address:"127.0.0.1" + ~external_auth_type:"" ~external_auth_service_name:"" ~external_auth_configuration:[] + ~license_params:[] ~edition:"" ~license_server:[] ~local_cache_sr:(Ref.null) ~chipset_info:[] ~ssl_legacy:false) (* Creates an unlicensed pool with the maximum number of hosts *) let setup_test () = diff --git a/ocaml/tests/test_map_check.ml b/ocaml/tests/test_map_check.ml index ddffe571287..1a28977b20e 100644 --- a/ocaml/tests/test_map_check.ml +++ b/ocaml/tests/test_map_check.ml @@ -124,81 +124,81 @@ let string_of_ty = function let string_of_ks ks = let field,kss = ks in List.map (fun (a, b) -> - let inner_string = List.map (fun (c, d) -> let e, f = d in - c ^ "," ^ (string_of_ty e) ^ f ) b |> String.concat ";" in - "[" ^ a ^ "," ^ "[" ^ inner_string ^ "]]" - ) kss + let inner_string = List.map (fun (c, d) -> let e, f = d in + c ^ "," ^ (string_of_ty e) ^ f ) b |> String.concat ";" in + "[" ^ a ^ "," ^ "[" ^ inner_string ^ "]]" + ) kss |> String.concat ";" module AssertAllKeys = Generic.Make(struct - module Io = struct - type input_t = string * - (string * (string * (string * (Map_check.key_type * string))list)list) * - ((string * string) list) * - ((string * string) list) - type output_t = (string * string) list - - let string_of_input_t (ty, ks, value, db) = Printf.sprintf "frequency=%s, keys=%s, input_value=%s, db_value=%s" - ty - (string_of_ks ks) - (Test_printers.(assoc_list string string) value) - (Test_printers.(assoc_list string string) db) - let string_of_output_t = Test_printers.(assoc_list string string) - end - - let transform (ty, ks, value, db) = assert_all_keys ty ks value db - - let tests = [ - (* Tests for hourly snapshots *) - ("hourly", ("", ["hourly", ["min",(String,"")]]), ["min","30"], ["min", "0"]), ["min","30"]; - ("hourly", ("", ["hourly", ["min",(String,"")]]), ["hour","1";"min","0"], ["min", "0"]), ["min","0"]; - ("hourly", ("", ["hourly", ["min",(String,"")]]), ["day","Monday";"hour","1";"min","0"], ["min", "0"]), ["min","0"]; - - (* Change hourly snapshots to daily and weekly *) - ("daily", ("", ["daily", ["hour",(String,"");"min",(String,"")]]), ["hour","10";"min","30"], ["min", "0"]), ["hour","10";"min","30"]; - ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Monday";"hour","10";"min","30"], ["min","0"]), ["day","Monday";"hour","10";"min","30"]; - - (* Tests for daily snapshots *) - ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["hour","10";"min","30"], ["hour","0";"min","0"]), ["hour","10";"min","30"]; - ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["day","Monday";"hour","0";"min","0"], ["hour","0";"min","0"]), ["hour","0";"min","0"]; - ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["min","30"], ["hour","0";"min","0"]), ["hour","0";"min","30"]; - ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["hour","10"], ["hour","0";"min","0"]), ["hour","10";"min","0"]; - - (* Change daily snapshots to hourly and weekly *) - ("hourly", ("", ["hourly", ["min",(String,"")]]), ["min","30"], ["hour","0";"min", "0"]), ["min","30"]; - ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Monday";"hour","10";"min","30"], ["hour","0";"min","0"]), ["day","Monday";"hour","10";"min","30"]; - - (* Tests for weekly snapshots *) - ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Monday";"hour","10";"min","30"], ["day","Wednesday";"hour","0";"min","0"]), ["day","Monday";"hour","10";"min","30"]; - ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Wednesday"], ["day","Monday";"hour","0";"min","0"]), ["day","Wednesday";"hour","0";"min","0"]; - ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["hour","10"], ["day","Monday";"hour","0";"min","0"]), ["day","Monday";"hour","10";"min","0"]; - ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["min","30"], ["day","Monday";"hour","0";"min","0"]), ["day","Monday";"hour","0";"min","30"]; - - (* Change weekly snapshots to hourly and daily *) - ("hourly", ("", ["hourly", ["min",(String,"")]]), ["min","30"], ["day","Monday";"hour","0";"min","0"]), ["min","30"]; - ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["hour","10";"min","30"], ["day","Monday";"hour","0";"min","0"]), ["hour","10";"min","30"]; - ] -end) + module Io = struct + type input_t = string * + (string * (string * (string * (Map_check.key_type * string))list)list) * + ((string * string) list) * + ((string * string) list) + type output_t = (string * string) list + + let string_of_input_t (ty, ks, value, db) = Printf.sprintf "frequency=%s, keys=%s, input_value=%s, db_value=%s" + ty + (string_of_ks ks) + (Test_printers.(assoc_list string string) value) + (Test_printers.(assoc_list string string) db) + let string_of_output_t = Test_printers.(assoc_list string string) + end + + let transform (ty, ks, value, db) = assert_all_keys ty ks value db + + let tests = [ + (* Tests for hourly snapshots *) + ("hourly", ("", ["hourly", ["min",(String,"")]]), ["min","30"], ["min", "0"]), ["min","30"]; + ("hourly", ("", ["hourly", ["min",(String,"")]]), ["hour","1";"min","0"], ["min", "0"]), ["min","0"]; + ("hourly", ("", ["hourly", ["min",(String,"")]]), ["day","Monday";"hour","1";"min","0"], ["min", "0"]), ["min","0"]; + + (* Change hourly snapshots to daily and weekly *) + ("daily", ("", ["daily", ["hour",(String,"");"min",(String,"")]]), ["hour","10";"min","30"], ["min", "0"]), ["hour","10";"min","30"]; + ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Monday";"hour","10";"min","30"], ["min","0"]), ["day","Monday";"hour","10";"min","30"]; + + (* Tests for daily snapshots *) + ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["hour","10";"min","30"], ["hour","0";"min","0"]), ["hour","10";"min","30"]; + ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["day","Monday";"hour","0";"min","0"], ["hour","0";"min","0"]), ["hour","0";"min","0"]; + ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["min","30"], ["hour","0";"min","0"]), ["hour","0";"min","30"]; + ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["hour","10"], ["hour","0";"min","0"]), ["hour","10";"min","0"]; + + (* Change daily snapshots to hourly and weekly *) + ("hourly", ("", ["hourly", ["min",(String,"")]]), ["min","30"], ["hour","0";"min", "0"]), ["min","30"]; + ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Monday";"hour","10";"min","30"], ["hour","0";"min","0"]), ["day","Monday";"hour","10";"min","30"]; + + (* Tests for weekly snapshots *) + ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Monday";"hour","10";"min","30"], ["day","Wednesday";"hour","0";"min","0"]), ["day","Monday";"hour","10";"min","30"]; + ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["day","Wednesday"], ["day","Monday";"hour","0";"min","0"]), ["day","Wednesday";"hour","0";"min","0"]; + ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["hour","10"], ["day","Monday";"hour","0";"min","0"]), ["day","Monday";"hour","10";"min","0"]; + ("weekly", ("", ["weekly", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["min","30"], ["day","Monday";"hour","0";"min","0"]), ["day","Monday";"hour","0";"min","30"]; + + (* Change weekly snapshots to hourly and daily *) + ("hourly", ("", ["hourly", ["min",(String,"")]]), ["min","30"], ["day","Monday";"hour","0";"min","0"]), ["min","30"]; + ("daily", ("", ["daily", ["hour",(String,""); "min",(String,"")]]), ["hour","10";"min","30"], ["day","Monday";"hour","0";"min","0"]), ["hour","10";"min","30"]; + ] + end) module AssertKeys = Generic.Make(struct - module Io = struct - type input_t = string * - (string * (string * (string * (Map_check.key_type * string))list)list) * - ((string * string) list) * - ((string * string) list) - type output_t = (exn, (string * string) list) Either.t - - let string_of_input_t (ty, ks, value, db) = Printf.sprintf "keys=%s, input_value=%s, db_value=%s" - (string_of_ks ks) - (Test_printers.(assoc_list string string) value) - (Test_printers.(assoc_list string string) db) - let string_of_output_t = Test_printers.(either exn (assoc_list string string)) - end - - let transform (ty, ks, value, db) = - try Either.Right (assert_keys ty ks value db) - with e -> Either.Left e - + module Io = struct + type input_t = string * + (string * (string * (string * (Map_check.key_type * string))list)list) * + ((string * string) list) * + ((string * string) list) + type output_t = (exn, (string * string) list) Either.t + + let string_of_input_t (ty, ks, value, db) = Printf.sprintf "keys=%s, input_value=%s, db_value=%s" + (string_of_ks ks) + (Test_printers.(assoc_list string string) value) + (Test_printers.(assoc_list string string) db) + let string_of_output_t = Test_printers.(either exn (assoc_list string string)) + end + + let transform (ty, ks, value, db) = + try Either.Right (assert_keys ty ks value db) + with e -> Either.Left e + let tests = [ (* Tests hourly keys *) ("", ("", ["", ["min",(String,"")]]), ["min","30"], ["min", "0"]), Either.Right (["min","30"]); @@ -218,7 +218,7 @@ module AssertKeys = Generic.Make(struct ("", ("", ["", ["day",(String,"");"hour",(String,"");"min",(String,"")]]), ["min","30"], ["day","Monday";"hour","0";"min","0"]), Either.Right (["day","Monday";"hour","0";"min","30"]); ] -end) + end) let test = "test_map_check" >::: diff --git a/ocaml/tests/test_platformdata.ml b/ocaml/tests/test_platformdata.ml index 04171a1c3d3..11cbb9f9b56 100644 --- a/ocaml/tests/test_platformdata.ml +++ b/ocaml/tests/test_platformdata.ml @@ -32,7 +32,7 @@ module SanityCheck = Generic.Make(struct let transform (platformdata, filter_out_unknowns, vcpu_max, vcpu_at_startup, domain_type) = try Either.Right (Vm_platform.sanity_check ~platformdata ~vcpu_max - ~vcpu_at_startup ~domain_type ~filter_out_unknowns) + ~vcpu_at_startup ~domain_type ~filter_out_unknowns) with e -> Either.Left e let tests = diff --git a/ocaml/tests/test_pusb.ml b/ocaml/tests/test_pusb.ml index b53782d0a55..47f36247ce7 100644 --- a/ocaml/tests/test_pusb.ml +++ b/ocaml/tests/test_pusb.ml @@ -45,9 +45,9 @@ let test_scan_with_usb_add_and_remove () = Thread.delay 1.0; (* delete PUSB from DB*) List.iter (fun (self, _) -> - let usb_group = Db.PUSB.get_USB_group ~__context ~self in - Db.PUSB.destroy ~__context ~self; - Db.USB_group.destroy ~__context ~self:usb_group) (Db.PUSB.get_all_records ~__context); + let usb_group = Db.PUSB.get_USB_group ~__context ~self in + Db.PUSB.destroy ~__context ~self; + Db.USB_group.destroy ~__context ~self:usb_group) (Db.PUSB.get_all_records ~__context); Xapi_pusb.scan ~__context ~host; Thread.delay 1.0; @@ -56,5 +56,5 @@ let test_scan_with_usb_add_and_remove () = let test = "test_pusb" >::: [ - "test_scan_with_usb_add_and_remove" >:: test_scan_with_usb_add_and_remove; + "test_scan_with_usb_add_and_remove" >:: test_scan_with_usb_add_and_remove; ] diff --git a/ocaml/tests/test_sr_update_vdis.ml b/ocaml/tests/test_sr_update_vdis.ml index 0eb887e288b..7ffd8f87bc8 100644 --- a/ocaml/tests/test_sr_update_vdis.ml +++ b/ocaml/tests/test_sr_update_vdis.ml @@ -38,15 +38,15 @@ let test_update_existing_snapshot () = let vdi = make_vdi ~__context ~uuid:vdi_uuid ~location:vdi_uuid ~sR:sr () in let vdi_snapshot_uuid = make_uuid () in let vdi_snapshot = make_vdi ~__context ~uuid:vdi_snapshot_uuid ~sR:sr - ~location:vdi_snapshot_uuid ~snapshot_of:vdi ~is_a_snapshot:true () in + ~location:vdi_snapshot_uuid ~snapshot_of:vdi ~is_a_snapshot:true () in (* create mock snapshot record which we would get from an SR scan *) let vdi_snapshot_sr_record = Storage_interface.({ default_vdi_info with - vdi = vdi_snapshot_uuid; - uuid = Some vdi_snapshot_uuid; - is_a_snapshot = true; - snapshot_of = vdi_uuid; - }) in + vdi = vdi_snapshot_uuid; + uuid = Some vdi_snapshot_uuid; + is_a_snapshot = true; + snapshot_of = vdi_uuid; + }) in (* attempt to reproduce the issue by updating the snapshot *) let vdi_snapshot_record = Db.VDI.get_record ~__context ~self:vdi_snapshot in @@ -77,15 +77,15 @@ let test_update_new_vdi_and_snapshot () = (* create mock VDI/snapshot records which we would get from an SR scan *) let vdi_sr_record = Storage_interface.({ default_vdi_info with - vdi = vdi_uuid; - uuid = Some vdi_uuid; - }) in + vdi = vdi_uuid; + uuid = Some vdi_uuid; + }) in let vdi_snapshot_sr_record = Storage_interface.({ default_vdi_info with - vdi = vdi_snapshot_uuid; - uuid = Some vdi_snapshot_uuid; - snapshot_of = vdi_uuid; - is_a_snapshot = true; - }) in + vdi = vdi_snapshot_uuid; + uuid = Some vdi_snapshot_uuid; + snapshot_of = vdi_uuid; + is_a_snapshot = true; + }) in (* attempt to reproduce the issue by creating the snapshot before the VDI *) Xapi_sr.update_vdis ~__context ~sr [] [vdi_sr_record; vdi_snapshot_sr_record]; @@ -108,10 +108,10 @@ let test_sharable_field_correctly_set = (* SR.scan returned the correct vdi_info with the up-to-date sharable field *) let vdi_sr_record = Storage_interface.({ default_vdi_info with - vdi = vdi_uuid; - uuid = Some vdi_uuid; - sharable = true; - }) in + vdi = vdi_uuid; + uuid = Some vdi_uuid; + sharable = true; + }) in (* When we call this function from our SR.scan XenAPI call for example, it should update the VDI's sharable field to the correct value returned by the @@ -128,10 +128,10 @@ let test_sharable_field_correctly_set = (* We do not have this VDI in xapi's database. SR.scan returned it with the correct vdi_info containing the up-to-date sharable field. *) let vdi_sr_record = Storage_interface.({ default_vdi_info with - vdi = vdi_uuid; - uuid = Some vdi_uuid; - sharable = true; - }) in + vdi = vdi_uuid; + uuid = Some vdi_uuid; + sharable = true; + }) in (* When we call this function from our SR.scan XenAPI call for example, it should add the VDI to xapi's database with the correct sharable field returned diff --git a/ocaml/tests/test_valid_ref_list.ml b/ocaml/tests/test_valid_ref_list.ml index 1835b3c5a4c..46bb963f3c9 100644 --- a/ocaml/tests/test_valid_ref_list.ml +++ b/ocaml/tests/test_valid_ref_list.ml @@ -106,10 +106,10 @@ let test_iter = exceptions when we use the Client module *) let test_client = with_vm_list (fun __context l -> - let (rpc, session_id) = Test_common.make_client_params ~__context in - let f vm = Client.Client.VM.get_name_label ~rpc ~session_id ~self:vm in - assert_equal ["a"; "d"] (Valid_ref_list.map f l) - ) + let (rpc, session_id) = Test_common.make_client_params ~__context in + let f vm = Client.Client.VM.get_name_label ~rpc ~session_id ~self:vm in + assert_equal ["a"; "d"] (Valid_ref_list.map f l) + ) let test = [ "test_map", `Quick, test_map diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index e87de26f3c3..3c9b9550261 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -65,7 +65,7 @@ let test_cbt_enable_disable () = sr_uuid; Xapi_vdi.enable_cbt ~__context ~self:vdi_ref; - check_params "The parameters should be correctly passed to SMAPIv2 from VDI.enable_cbt" (Some (sr_uuid, vdi_location)) !enable_cbt_params; + check_params "The parameters should be correctly passed to SMAPIv2 from VDI.enable_cbt" (Some (sr_uuid, vdi_location)) !enable_cbt_params; assert_vdi_cbt_enabled_is true "cbt_enabled should be true when VDI.enable_cbt returns successfully"; Xapi_vdi.enable_cbt ~__context ~self:vdi_ref; @@ -342,10 +342,10 @@ let test_data_destroy = let __context, sR, vdi = setup_test_for_data_destroy ~vdi_data_destroy:(fun _ ~dbg ~sr ~vdi -> raise (Failure "error")) () in let original_type = Db.VDI.get_type ~__context ~self:vdi in try Xapi_vdi.data_destroy ~__context ~self:vdi with _ -> (); - Alcotest.check (Alcotest_comparators.vdi_type) - "data_destroy should not change the VDI's type to cbt_metadata when it did not succeed, it should preserve the original type" - original_type - (Db.VDI.get_type ~__context ~self:vdi) + Alcotest.check (Alcotest_comparators.vdi_type) + "data_destroy should not change the VDI's type to cbt_metadata when it did not succeed, it should preserve the original type" + original_type + (Db.VDI.get_type ~__context ~self:vdi) in let test_data_destroy_timing = @@ -371,7 +371,7 @@ let test_data_destroy = ~timeout:timebox_timeout ~otherwise:(fun () -> Alcotest.fail (Printf.sprintf "data_destroy did not return in %f seconds" timebox_timeout)) (fun () -> Xapi_vdi._data_destroy ~__context ~self:vDI ~timeout) - in + in (vDI, start_vbd_unplug, finish_vbd_unplug, destroy_vbd, data_destroy) in diff --git a/ocaml/tests/test_vgpu_type.ml b/ocaml/tests/test_vgpu_type.ml index eb88a5dbf10..6fe27fef038 100644 --- a/ocaml/tests/test_vgpu_type.ml +++ b/ocaml/tests/test_vgpu_type.ml @@ -181,7 +181,7 @@ module NvidiaTest = struct file_path = "test_data/nvidia-whitelist.xml"; }) ]; - + ] end) @@ -415,7 +415,7 @@ module AMDTest = struct pdev_id = 0x1234; framebufferbytes = mib 128L; }); - experimental = false; + experimental = false; model_name = "Small AMD MxGPU on 1234"; vgpus_per_pgpu = 4L; }); diff --git a/ocaml/tests/test_vlan.ml b/ocaml/tests/test_vlan.ml index 45d18f19ef6..ad058038aa1 100644 --- a/ocaml/tests/test_vlan.ml +++ b/ocaml/tests/test_vlan.ml @@ -23,7 +23,7 @@ let test_pool_introduce () = let vlan_network = make_network ~__context ~bridge:"xapi0" () in let untagged_PIF = make_pif ~__context ~network:vlan_network ~host ~vLAN:tag () in let vlan = Xapi_vlan.pool_introduce ~__context - ~tagged_PIF ~untagged_PIF ~tag ~other_config:[] + ~tagged_PIF ~untagged_PIF ~tag ~other_config:[] in Alcotest.check (Alcotest_comparators.ref ()) "VLAN master of untagged PIF" vlan (Db.PIF.get_VLAN_master_of ~__context ~self:untagged_PIF); Alcotest.check (Alcotest_comparators.ref ()) "VLAN's tagged PIF" tagged_PIF (Db.VLAN.get_tagged_PIF ~__context ~self:vlan); @@ -38,7 +38,7 @@ let test_create_internal () = let network = make_network ~__context ~bridge:"xapi0" () in let tagged_PIF = make_pif ~__context ~network ~host () in let vlan, untagged_PIF = Xapi_vlan.create_internal ~__context - ~host ~tagged_PIF ~tag ~network ~device + ~host ~tagged_PIF ~tag ~network ~device in Alcotest.check (Alcotest_comparators.ref ()) "VLAN master of untagged PIF" vlan (Db.PIF.get_VLAN_master_of ~__context ~self:untagged_PIF); Alcotest.check (Alcotest_comparators.ref ()) "VLAN's tagged PIF" tagged_PIF (Db.VLAN.get_tagged_PIF ~__context ~self:vlan); @@ -124,7 +124,7 @@ let test_create_vlan_already_exists () = let vlan_network = make_network ~__context ~bridge:"xapi0" () in let tagged_PIF = make_pif ~__context ~network ~host () in let _ = Xapi_vlan.create_internal ~__context - ~host ~tagged_PIF ~tag ~network:vlan_network ~device in + ~host ~tagged_PIF ~tag ~network:vlan_network ~device in let new_vlan_network = make_network ~__context ~bridge:"xapi1" () in assert_raises_api_error Api_errors.pif_vlan_exists @@ -154,7 +154,7 @@ let test_gc_vlan () = let vlan_network = make_network ~__context ~bridge:"xapi0" () in let untagged_PIF = make_pif ~__context ~network:vlan_network ~host ~vLAN:tag () in let vlan = Xapi_vlan.pool_introduce ~__context - ~tagged_PIF ~untagged_PIF ~tag ~other_config:[] + ~tagged_PIF ~untagged_PIF ~tag ~other_config:[] in Alcotest.check (Alcotest_comparators.ref ()) "VLAN master of untagged PIF" vlan (Db.PIF.get_VLAN_master_of ~__context ~self:untagged_PIF); Db.PIF.set_host ~__context ~self:untagged_PIF ~value:Ref.null; diff --git a/ocaml/tests/test_vm.ml b/ocaml/tests/test_vm.ml index 20a58f13d4e..cc5dc01ca82 100644 --- a/ocaml/tests/test_vm.ml +++ b/ocaml/tests/test_vm.ml @@ -17,158 +17,158 @@ open OUnit open Test_highlevel module VMSetBiosStrings = Generic.Make (Generic.EncapsulateState (struct - module Io = struct - type input_t = (string * string) list - type output_t = (exn, (string * string) list) Either.t - let string_of_input_t = fun x -> Printf.sprintf "%s" - (String.concat "; " (List.map (fun (k,v) -> k ^ "=" ^ v) x)) - let string_of_output_t = Test_printers.(either exn (assoc_list string string)) - end - module State = Test_state.XapiDb - - let name_label = "a" - - let load_input __context _ = - ignore (Test_common.make_vm ~__context ~name_label ()) - - let extract_output __context value = - let self = List.hd (Db.VM.get_by_name_label ~__context ~label:name_label) in - try - Xapi_vm.set_bios_strings ~__context ~self ~value; - Either.Right (Db.VM.get_bios_strings ~__context ~self) - with e -> Either.Left e - - let big_str = String.make (Xapi_globs.bios_string_limit_size + 1) 'x' - let non_printable_str1 = Printf.sprintf "xyz%c" (Char.chr 31) - let non_printable_str2 = Printf.sprintf "xyz%c" (Char.chr 127) - let bios_str1 = ["bios-vendor", "Test"; "bios-version", "Test Inc. A08"] - let bios_str2 = ["system-manufacturer", "Test Inc."; "system-product-name", "Test bios strings"; "system-version", "8.1.1 SP1 build 8901"; "system-serial-number", "test-test-test-test"] - let bios_str3 = ["enclosure-asset-tag", "testassettag12345"] - - let tests = [ - (* Invalid BIOS string key *) - ["xxxx", "test"], - Either.Left Api_errors.(Server_error - (invalid_value, - ["xxxx"; "Unknown key"])); - - (* Empty value *) - ["enclosure-asset-tag", ""], - Either.Left Api_errors.(Server_error - (invalid_value, - ["enclosure-asset-tag"; "Value provided is empty"])); - - (* Value having more than 512 charactors *) - ["enclosure-asset-tag", big_str], - Either.Left Api_errors.(Server_error - (invalid_value, - ["enclosure-asset-tag"; (Printf.sprintf "%s has length more than %d characters" big_str Xapi_globs.bios_string_limit_size)])); - - (* Value having non printable ascii characters *) - ["enclosure-asset-tag", non_printable_str1], - Either.Left Api_errors.(Server_error - (invalid_value, - ["enclosure-asset-tag"; non_printable_str1 ^ " has non-printable ASCII characters"])); - - ["enclosure-asset-tag", non_printable_str2], - Either.Left Api_errors.(Server_error - (invalid_value, - ["enclosure-asset-tag"; non_printable_str2 ^ " has non-printable ASCII characters"])); - - (* Correct value *) - bios_str1, - Either.Right [ - "bios-vendor", "Test"; - "bios-version", "Test Inc. A08"; - "system-manufacturer", "Xen"; - "system-product-name", "HVM domU"; - "system-version", ""; - "system-serial-number", ""; - "enclosure-asset-tag", ""; - "hp-rombios", ""; - "oem-1", "Xen"; - "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; - - bios_str2, - Either.Right [ - "bios-vendor", "Xen"; - "bios-version", ""; - "system-manufacturer", "Test Inc."; - "system-product-name", "Test bios strings"; - "system-version", "8.1.1 SP1 build 8901"; - "system-serial-number", "test-test-test-test"; - "enclosure-asset-tag", ""; - "hp-rombios", ""; - "oem-1", "Xen"; - "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; - - bios_str3, - Either.Right [ - "bios-vendor", "Xen"; - "bios-version", ""; - "system-manufacturer", "Xen"; - "system-product-name", "HVM domU"; - "system-version", ""; - "system-serial-number", ""; - "enclosure-asset-tag", "testassettag12345"; - "hp-rombios", ""; - "oem-1", "Xen"; - "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; - - (bios_str1 @ bios_str2), - Either.Right [ - "bios-vendor", "Test"; - "bios-version", "Test Inc. A08"; - "system-manufacturer", "Test Inc."; - "system-product-name", "Test bios strings"; - "system-version", "8.1.1 SP1 build 8901"; - "system-serial-number", "test-test-test-test"; - "enclosure-asset-tag", ""; - "hp-rombios", ""; - "oem-1", "Xen"; - "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; - - (bios_str1 @ bios_str3), - Either.Right [ - "bios-vendor", "Test"; - "bios-version", "Test Inc. A08"; - "system-manufacturer", "Xen"; - "system-product-name", "HVM domU"; - "system-version", ""; - "system-serial-number", ""; - "enclosure-asset-tag", "testassettag12345"; - "hp-rombios", ""; - "oem-1", "Xen"; - "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; - - (bios_str2 @ bios_str3), - Either.Right [ - "bios-vendor", "Xen"; - "bios-version", ""; - "system-manufacturer", "Test Inc."; - "system-product-name", "Test bios strings"; - "system-version", "8.1.1 SP1 build 8901"; - "system-serial-number", "test-test-test-test"; - "enclosure-asset-tag", "testassettag12345"; - "hp-rombios", ""; - "oem-1", "Xen"; - "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; - - (bios_str1 @ bios_str2 @ bios_str3), - Either.Right [ - "bios-vendor", "Test"; - "bios-version", "Test Inc. A08"; - "system-manufacturer", "Test Inc."; - "system-product-name", "Test bios strings"; - "system-version", "8.1.1 SP1 build 8901"; - "system-serial-number", "test-test-test-test"; - "enclosure-asset-tag", "testassettag12345"; - "hp-rombios", ""; - "oem-1", "Xen"; - "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; - - ] -end)) + module Io = struct + type input_t = (string * string) list + type output_t = (exn, (string * string) list) Either.t + let string_of_input_t = fun x -> Printf.sprintf "%s" + (String.concat "; " (List.map (fun (k,v) -> k ^ "=" ^ v) x)) + let string_of_output_t = Test_printers.(either exn (assoc_list string string)) + end + module State = Test_state.XapiDb + + let name_label = "a" + + let load_input __context _ = + ignore (Test_common.make_vm ~__context ~name_label ()) + + let extract_output __context value = + let self = List.hd (Db.VM.get_by_name_label ~__context ~label:name_label) in + try + Xapi_vm.set_bios_strings ~__context ~self ~value; + Either.Right (Db.VM.get_bios_strings ~__context ~self) + with e -> Either.Left e + + let big_str = String.make (Xapi_globs.bios_string_limit_size + 1) 'x' + let non_printable_str1 = Printf.sprintf "xyz%c" (Char.chr 31) + let non_printable_str2 = Printf.sprintf "xyz%c" (Char.chr 127) + let bios_str1 = ["bios-vendor", "Test"; "bios-version", "Test Inc. A08"] + let bios_str2 = ["system-manufacturer", "Test Inc."; "system-product-name", "Test bios strings"; "system-version", "8.1.1 SP1 build 8901"; "system-serial-number", "test-test-test-test"] + let bios_str3 = ["enclosure-asset-tag", "testassettag12345"] + + let tests = [ + (* Invalid BIOS string key *) + ["xxxx", "test"], + Either.Left Api_errors.(Server_error + (invalid_value, + ["xxxx"; "Unknown key"])); + + (* Empty value *) + ["enclosure-asset-tag", ""], + Either.Left Api_errors.(Server_error + (invalid_value, + ["enclosure-asset-tag"; "Value provided is empty"])); + + (* Value having more than 512 charactors *) + ["enclosure-asset-tag", big_str], + Either.Left Api_errors.(Server_error + (invalid_value, + ["enclosure-asset-tag"; (Printf.sprintf "%s has length more than %d characters" big_str Xapi_globs.bios_string_limit_size)])); + + (* Value having non printable ascii characters *) + ["enclosure-asset-tag", non_printable_str1], + Either.Left Api_errors.(Server_error + (invalid_value, + ["enclosure-asset-tag"; non_printable_str1 ^ " has non-printable ASCII characters"])); + + ["enclosure-asset-tag", non_printable_str2], + Either.Left Api_errors.(Server_error + (invalid_value, + ["enclosure-asset-tag"; non_printable_str2 ^ " has non-printable ASCII characters"])); + + (* Correct value *) + bios_str1, + Either.Right [ + "bios-vendor", "Test"; + "bios-version", "Test Inc. A08"; + "system-manufacturer", "Xen"; + "system-product-name", "HVM domU"; + "system-version", ""; + "system-serial-number", ""; + "enclosure-asset-tag", ""; + "hp-rombios", ""; + "oem-1", "Xen"; + "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; + + bios_str2, + Either.Right [ + "bios-vendor", "Xen"; + "bios-version", ""; + "system-manufacturer", "Test Inc."; + "system-product-name", "Test bios strings"; + "system-version", "8.1.1 SP1 build 8901"; + "system-serial-number", "test-test-test-test"; + "enclosure-asset-tag", ""; + "hp-rombios", ""; + "oem-1", "Xen"; + "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; + + bios_str3, + Either.Right [ + "bios-vendor", "Xen"; + "bios-version", ""; + "system-manufacturer", "Xen"; + "system-product-name", "HVM domU"; + "system-version", ""; + "system-serial-number", ""; + "enclosure-asset-tag", "testassettag12345"; + "hp-rombios", ""; + "oem-1", "Xen"; + "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; + + (bios_str1 @ bios_str2), + Either.Right [ + "bios-vendor", "Test"; + "bios-version", "Test Inc. A08"; + "system-manufacturer", "Test Inc."; + "system-product-name", "Test bios strings"; + "system-version", "8.1.1 SP1 build 8901"; + "system-serial-number", "test-test-test-test"; + "enclosure-asset-tag", ""; + "hp-rombios", ""; + "oem-1", "Xen"; + "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; + + (bios_str1 @ bios_str3), + Either.Right [ + "bios-vendor", "Test"; + "bios-version", "Test Inc. A08"; + "system-manufacturer", "Xen"; + "system-product-name", "HVM domU"; + "system-version", ""; + "system-serial-number", ""; + "enclosure-asset-tag", "testassettag12345"; + "hp-rombios", ""; + "oem-1", "Xen"; + "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; + + (bios_str2 @ bios_str3), + Either.Right [ + "bios-vendor", "Xen"; + "bios-version", ""; + "system-manufacturer", "Test Inc."; + "system-product-name", "Test bios strings"; + "system-version", "8.1.1 SP1 build 8901"; + "system-serial-number", "test-test-test-test"; + "enclosure-asset-tag", "testassettag12345"; + "hp-rombios", ""; + "oem-1", "Xen"; + "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; + + (bios_str1 @ bios_str2 @ bios_str3), + Either.Right [ + "bios-vendor", "Test"; + "bios-version", "Test Inc. A08"; + "system-manufacturer", "Test Inc."; + "system-product-name", "Test bios strings"; + "system-version", "8.1.1 SP1 build 8901"; + "system-serial-number", "test-test-test-test"; + "enclosure-asset-tag", "testassettag12345"; + "hp-rombios", ""; + "oem-1", "Xen"; + "oem-2", "MS_VM_CERT/SHA1/bdbeb6e0a816d43fa6d3fe8aaef04c2bad9d3e3d"]; + + ] + end)) let test = "test_vm" >::: diff --git a/ocaml/tests/test_vm_check_operation_error.ml b/ocaml/tests/test_vm_check_operation_error.ml index 6a838787b6f..185221f5b2d 100644 --- a/ocaml/tests/test_vm_check_operation_error.ml +++ b/ocaml/tests/test_vm_check_operation_error.ml @@ -76,9 +76,9 @@ let test_operation_checks_allowed () = [`assert_operation_valid; `update_allowed_operations] |> List.iter (fun op -> - compare_errors - None - (Xapi_vm_lifecycle.check_operation_error ~__context ~ref:vm_ref ~op ~strict:true)) + compare_errors + None + (Xapi_vm_lifecycle.check_operation_error ~__context ~ref:vm_ref ~op ~strict:true)) ) (* The check_operation_error function, which is called from the message @@ -98,17 +98,17 @@ let test_migration_allowed_when_cbt_enabled_vdis_are_not_moved () = let test_sxm_disallowed_when_rum () = with_test_vm (fun __context vm_ref -> - let master = Test_common.make_host __context () in - let pool = Test_common.make_pool ~__context ~master () in - Db.Pool.add_to_other_config ~__context ~self:pool ~key:Xapi_globs.rolling_upgrade_in_progress ~value:"x"; - compare_errors - (Some(Api_errors.not_supported_during_upgrade, [ ])) - (Xapi_vm_lifecycle.check_operation_error ~__context ~ref:vm_ref ~op:`migrate_send ~strict:false); - Db.Pool.remove_from_other_config ~__context ~self:pool ~key:Xapi_globs.rolling_upgrade_in_progress; - compare_errors - None - (Xapi_vm_lifecycle.check_operation_error ~__context ~ref:vm_ref ~op:`migrate_send ~strict:false) - ) + let master = Test_common.make_host __context () in + let pool = Test_common.make_pool ~__context ~master () in + Db.Pool.add_to_other_config ~__context ~self:pool ~key:Xapi_globs.rolling_upgrade_in_progress ~value:"x"; + compare_errors + (Some(Api_errors.not_supported_during_upgrade, [ ])) + (Xapi_vm_lifecycle.check_operation_error ~__context ~ref:vm_ref ~op:`migrate_send ~strict:false); + Db.Pool.remove_from_other_config ~__context ~self:pool ~key:Xapi_globs.rolling_upgrade_in_progress; + compare_errors + None + (Xapi_vm_lifecycle.check_operation_error ~__context ~ref:vm_ref ~op:`migrate_send ~strict:false) + ) let test = [ "test_null_vdi", `Quick, test_null_vdi diff --git a/ocaml/util/xapi_version.ml b/ocaml/util/xapi_version.ml index 01029fd78c7..c9f6e99bc89 100644 --- a/ocaml/util/xapi_version.ml +++ b/ocaml/util/xapi_version.ml @@ -1,10 +1,10 @@ - let product_version () = Inventory.lookup ~default:"" "PRODUCT_VERSION" - let product_version_text () = Inventory.lookup ~default:"" "PRODUCT_VERSION_TEXT" - let product_version_text_short () = Inventory.lookup ~default:"" "PRODUCT_VERSION_TEXT_SHORT" - let platform_name () = Inventory.lookup ~default:"" "PLATFORM_NAME" - let platform_version () = Inventory.lookup ~default:"0.0.0" "PLATFORM_VERSION" - let product_brand () = Inventory.lookup ~default:"" "PRODUCT_BRAND" - let build_number () = Inventory.lookup ~default:"" "BUILD_NUMBER" +let product_version () = Inventory.lookup ~default:"" "PRODUCT_VERSION" +let product_version_text () = Inventory.lookup ~default:"" "PRODUCT_VERSION_TEXT" +let product_version_text_short () = Inventory.lookup ~default:"" "PRODUCT_VERSION_TEXT_SHORT" +let platform_name () = Inventory.lookup ~default:"" "PLATFORM_NAME" +let platform_version () = Inventory.lookup ~default:"0.0.0" "PLATFORM_VERSION" +let product_brand () = Inventory.lookup ~default:"" "PRODUCT_BRAND" +let build_number () = Inventory.lookup ~default:"" "BUILD_NUMBER" let git_id = "" let hostname = "localhost" diff --git a/ocaml/xapi-types/features.ml b/ocaml/xapi-types/features.ml index d1082913231..568cb36af49 100644 --- a/ocaml/xapi-types/features.ml +++ b/ocaml/xapi-types/features.ml @@ -173,6 +173,6 @@ let of_assoc_list l = * and the implementation looks readable and fairly self-contained. * Do not use this pattern for lists that can be long. *) List.fold_right (fun f acc -> - match get_feature f with - | Some v -> v :: acc - | None -> acc) all_features [] + match get_feature f with + | Some v -> v :: acc + | None -> acc) all_features [] diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index 6d4f23512fa..97929bf400c 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -130,8 +130,8 @@ let is_himn_req req = | None -> false (* The API does not use the error.code and only retains it for compliance with - the JSON-RPC v2.0 specs. We set this always to a non-zero value because - some JsonRpc clients consider error.code 0 as no error*) + the JSON-RPC v2.0 specs. We set this always to a non-zero value because + some JsonRpc clients consider error.code 0 as no error*) let error_code_lit = 1L let json_of_error_object ?(data=None) code message = diff --git a/ocaml/xapi/create_networks.ml b/ocaml/xapi/create_networks.ml index 5a5ee7b0050..92392e7895e 100644 --- a/ocaml/xapi/create_networks.ml +++ b/ocaml/xapi/create_networks.ml @@ -40,7 +40,7 @@ let create_guest_installer_network ~__context = let h' = Xapi_network.create ~__context ~name_label:internal_management_network_name ~name_description:internal_management_network_desc ~mTU:1500L ~other_config:internal_management_network_oc ~bridge:"" ~managed:true ~tags:[] - in + in Db.Network.set_bridge ~__context ~self:h' ~value:internal_management_bridge; debug "Created new host internal management network: %s" (Ref.string_of h') diff --git a/ocaml/xapi/create_storage.ml b/ocaml/xapi/create_storage.ml index ab1ebf14f2c..819c6831e66 100644 --- a/ocaml/xapi/create_storage.ml +++ b/ocaml/xapi/create_storage.ml @@ -42,7 +42,7 @@ let maybe_reenable_cluster_host __context = let host = Helpers.get_localhost __context in match Xapi_clustering.find_cluster_host ~__context ~host with | Some self -> - Xapi_cluster_host.enable ~__context ~self + Xapi_cluster_host.enable ~__context ~self | None -> () let plug_unplugged_pbds __context = diff --git a/ocaml/xapi/daemon_manager.ml b/ocaml/xapi/daemon_manager.ml index 4ba56ffe690..df594631acb 100644 --- a/ocaml/xapi/daemon_manager.ml +++ b/ocaml/xapi/daemon_manager.ml @@ -27,8 +27,8 @@ type daemon_state = [ (** Daemon should be started when the last thread exits with_daemon_stopped. *) `should_not_start - (** Daemon should not be started when the last thread exits - with_daemon_stopped. *) + (** Daemon should not be started when the last thread exits + with_daemon_stopped. *) ] (** Tristate value for representing the state of a daemon we want to manage. *) diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index 6d99e8c7356..49b4091a348 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -76,7 +76,7 @@ let gc_PIFs ~__context = List.iter (fun tunnel -> (try Db.Tunnel.destroy ~__context ~self:tunnel with _ -> ())) tunnels_to_gc; List.iter (fun bond -> (try Db.Bond.destroy ~__context ~self:bond with _ -> ())) bonds_to_gc; Db.PIF.destroy ~__context ~self) - + let gc_VBDs ~__context = gc_connector ~__context Db.VBD.get_all Db.VBD.get_record (fun x->valid_ref __context x.vBD_VM) (fun x->valid_ref __context x.vBD_VDI || x.vBD_empty) (fun ~__context ~self -> @@ -93,7 +93,7 @@ let gc_VBDs ~__context = (try Db.VBD_metrics.destroy ~__context ~self:metrics with _ -> ()); Db.VBD.destroy ~__context ~self; end) - + let gc_crashdumps ~__context = gc_connector ~__context Db.Crashdump.get_all Db.Crashdump.get_record (fun x->valid_ref __context x.crashdump_VM) (fun x->valid_ref __context x.crashdump_VDI) Db.Crashdump.destroy @@ -104,7 +104,7 @@ let gc_VIFs ~__context = let metrics = Db.VIF.get_metrics ~__context ~self in (try Db.VIF_metrics.destroy ~__context ~self:metrics with _ -> ()); Db.VIF.destroy ~__context ~self) - + let gc_PBDs ~__context = gc_connector ~__context Db.PBD.get_all Db.PBD.get_record (fun x->valid_ref __context x.pBD_host) (fun x->valid_ref __context x.pBD_SR) Db.PBD.destroy @@ -163,7 +163,7 @@ let gc_host_cpus ~__context = (fun hcpu -> if not (valid_ref __context (Db.Host_cpu.get_host ~__context ~self:hcpu)) then Db.Host_cpu.destroy ~__context ~self:hcpu) host_cpus - + let gc_host_metrics ~__context = let all_host_metrics = Db.Host_metrics.get_all ~__context in let metrics = List.map (fun host-> Db.Host.get_metrics ~__context ~self:host) in @@ -256,8 +256,8 @@ let timeout_tasks ~__context = ) (old @ unlucky); if List.length lucky > Xapi_globs.max_tasks then warn "There are more pending tasks than the maximum allowed: %d > %d" (List.length lucky) Xapi_globs.max_tasks - - + + let timeout_sessions_common ~__context sessions limit session_group = let unused_sessions = List.filter (fun (x, _) -> @@ -342,10 +342,10 @@ let timeout_sessions ~__context = timeout_sessions_common ~__context anon_sessions Xapi_globs.max_sessions "external"; timeout_sessions_common ~__context pool_sessions Xapi_globs.max_sessions "internal"; end - + let gc_messages ~__context = Xapi_message.gc ~__context - + let gc_consoles ~__context = List.iter (fun console -> if not (valid_ref __context (Db.Console.get_VM ~__context ~self:console)) @@ -354,7 +354,7 @@ let gc_consoles ~__context = debug "GCed console %s" (Ref.string_of console); end ) (Db.Console.get_all ~__context) - + let gc_PVS_proxies ~__context = gc_connector ~__context Db.PVS_proxy.get_all @@ -362,7 +362,7 @@ let gc_PVS_proxies ~__context = (fun x -> valid_ref __context x.pVS_proxy_VIF) (fun x -> valid_ref __context x.pVS_proxy_site) Db.PVS_proxy.destroy - + (* A PVS server refers to a PVS site. We delete it, if the reference * becomes invalid. At creation, the server is connected to a site and * hence we never GC a server right after it was created. *) @@ -373,7 +373,7 @@ let gc_PVS_servers ~__context = (fun x -> true) (fun x -> valid_ref __context x.pVS_server_site) Db.PVS_server.destroy - + let gc_PVS_cache_storage ~__context = gc_connector ~__context Db.PVS_cache_storage.get_all @@ -396,26 +396,26 @@ let timeout_alerts ~__context = (* do VDIs first because this will cause some VBDs to be affected *) let gc_subtask_list = [ - "VDIs", gc_VDIs; - "PIFs", gc_PIFs; - "VBDs", gc_VBDs; - "crashdumps", gc_crashdumps; - "VIFs", gc_VIFs; - "PBDs", gc_PBDs; - "VGPUs", gc_VGPUs; - "PGPUs", gc_PGPUs; - "VGPU_types", gc_VGPU_types; - "Host patches", gc_Host_patches; - "Host CPUs", gc_host_cpus; - "Host metrics", gc_host_metrics; - "Tasks", timeout_tasks; - "Sessions", timeout_sessions; - "Messages", gc_messages; - "Consoles", gc_consoles; - "PVS proxies", gc_PVS_proxies; - "PVS servers", gc_PVS_servers; - "PVS cache storage", gc_PVS_cache_storage; - (* timeout_alerts; *) - (* CA-29253: wake up all blocked clients *) - "Heartbeat", Xapi_event.heartbeat; - ] + "VDIs", gc_VDIs; + "PIFs", gc_PIFs; + "VBDs", gc_VBDs; + "crashdumps", gc_crashdumps; + "VIFs", gc_VIFs; + "PBDs", gc_PBDs; + "VGPUs", gc_VGPUs; + "PGPUs", gc_PGPUs; + "VGPU_types", gc_VGPU_types; + "Host patches", gc_Host_patches; + "Host CPUs", gc_host_cpus; + "Host metrics", gc_host_metrics; + "Tasks", timeout_tasks; + "Sessions", timeout_sessions; + "Messages", gc_messages; + "Consoles", gc_consoles; + "PVS proxies", gc_PVS_proxies; + "PVS servers", gc_PVS_servers; + "PVS cache storage", gc_PVS_cache_storage; + (* timeout_alerts; *) + (* CA-29253: wake up all blocked clients *) + "Heartbeat", Xapi_event.heartbeat; +] diff --git a/ocaml/xapi/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml index 01a2502da0d..1528920c9ee 100644 --- a/ocaml/xapi/dbsync_slave.ml +++ b/ocaml/xapi/dbsync_slave.ml @@ -146,7 +146,7 @@ let record_host_memory_properties ~__context = Some (Memory_client.Client.get_host_initial_free_memory dbg) with e -> warn "Failed to get host free memory from ballooning service. This may \ - prevent VMs from being started on this host. (%s)" (Printexc.to_string e); + prevent VMs from being started on this host. (%s)" (Printexc.to_string e); None in maybe (fun boot_memory_bytes -> diff --git a/ocaml/xapi/debug_populate.ml b/ocaml/xapi/debug_populate.ml index 64eea4183d5..fbdd3014b9c 100644 --- a/ocaml/xapi/debug_populate.ml +++ b/ocaml/xapi/debug_populate.ml @@ -34,7 +34,7 @@ let rec make_networks __context i = else begin let nw_ref = Xapi_network.create ~__context ~name_label:("Network-"^(string_of_int i)) ~name_description:"dummy" - ~mTU:1500L ~other_config:[] ~bridge:"" ~managed:true ~tags:[] in + ~mTU:1500L ~other_config:[] ~bridge:"" ~managed:true ~tags:[] in nws := nw_ref :: !nws; make_networks __context (i-1) end diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 50f6fbaebd7..9285dd889fd 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -538,7 +538,7 @@ let metadata_handler (req: Request.t) s _ = (vm.API.vM_is_a_template && (List.mem_assoc Xapi_globs.default_template_key vm.API.vM_other_config) && ((List.assoc Xapi_globs.default_template_key vm.API.vM_other_config) = "true")) - in + in let all_vms = Db.VM.get_all_records ~__context in let interesting_vms = List.filter (fun (vm, vmr) -> not (is_default_template vmr) diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 7a2d3e87dd9..916b1f1ebc4 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -1023,16 +1023,16 @@ let i_am_srmaster ~__context ~sr = let get_all_plugged_srs ~__context = let pbds_plugged_in = Db.PBD.get_refs_where ~__context ~expr:( - Eq (Field "currently_attached", Literal "true")) in + Eq (Field "currently_attached", Literal "true")) in List.setify (List.map (fun self -> Db.PBD.get_SR ~__context ~self) pbds_plugged_in) let get_local_plugged_srs ~__context = let localhost = get_localhost __context in let localhost = Ref.string_of localhost in let my_pbds_plugged_in = Db.PBD.get_refs_where ~__context ~expr:(And ( - Eq (Field "host", Literal localhost), - Eq (Field "currently_attached", Literal "true") - )) + Eq (Field "host", Literal localhost), + Eq (Field "currently_attached", Literal "true") + )) in List.setify (List.map (fun self -> Db.PBD.get_SR ~__context ~self) my_pbds_plugged_in) @@ -1288,13 +1288,13 @@ let get_first_pusb ~__context usb_group = List.hd (Db.USB_group.get_PUSBs ~__context ~self:usb_group) with _ -> raise Api_errors.(Server_error(internal_error, - [Printf.sprintf "there is no PUSB associated with the USB_group: %s" - (Ref.string_of usb_group)])) + [Printf.sprintf "there is no PUSB associated with the USB_group: %s" + (Ref.string_of usb_group)])) let get_first_vusb ~__context usb_group = try List.hd (Db.USB_group.get_VUSBs ~__context ~self:usb_group) with _ -> raise Api_errors.(Server_error(internal_error, - [Printf.sprintf "there is no VUSB associated with the USB_group: %s" - (Ref.string_of usb_group)])) + [Printf.sprintf "there is no VUSB associated with the USB_group: %s" + (Ref.string_of usb_group)])) diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index 1b6cb69db1a..4f3b088a4dd 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -239,15 +239,15 @@ let assert_can_live_import __context rpc session_id vm_record = let assert_can_live_import_vgpu ~__context vgpu_record = let host = Helpers.get_localhost ~__context in let local_pgpus = Db.PGPU.get_refs_where ~__context ~expr:Db_filter_types.(And - (Eq (Field "GPU_group", Literal (Ref.string_of vgpu_record.API.vGPU_GPU_group)), - Eq (Field "host", Literal (Ref.string_of host)) - ) - ) in + (Eq (Field "GPU_group", Literal (Ref.string_of vgpu_record.API.vGPU_GPU_group)), + Eq (Field "host", Literal (Ref.string_of host)) + ) + ) in let capacity_exists = List.exists (fun pgpu -> - try Xapi_pgpu_helpers.assert_capacity_exists_for_VGPU_type ~__context ~self:pgpu ~vgpu_type:vgpu_record.API.vGPU_type; true - with _ -> false - ) local_pgpus + try Xapi_pgpu_helpers.assert_capacity_exists_for_VGPU_type ~__context ~self:pgpu ~vgpu_type:vgpu_record.API.vGPU_type; true + with _ -> false + ) local_pgpus in if not capacity_exists then raise Api_errors.(Server_error (vm_requires_gpu, [ @@ -394,7 +394,7 @@ module VM : HandlerTools = struct let vm_record = if vm_record.API.vM_domain_type = `unspecified then {vm_record with API.vM_domain_type = - Xapi_vm_helpers.derive_domain_type ~hVM_boot_policy:vm_record.API.vM_HVM_boot_policy} + Xapi_vm_helpers.derive_domain_type ~hVM_boot_policy:vm_record.API.vM_HVM_boot_policy} else vm_record in @@ -445,8 +445,8 @@ module VM : HandlerTools = struct {vm_record with API.vM_has_vendor_device = false;} ) in let vm_record = {vm_record with - API.vM_memory_overhead = - Memory_check.vm_compute_memory_overhead ~vm_record + API.vM_memory_overhead = + Memory_check.vm_compute_memory_overhead ~vm_record } in let vm_record = {vm_record with API.vM_protection_policy = Ref.null} in (* Full restore preserves UUIDs, so if we are replacing an existing VM the version number should be incremented *) @@ -530,7 +530,7 @@ module VM : HandlerTools = struct (* VM might have suspend_SR that does not exist on this pool *) if None = (Helpers.check_sr_exists ~__context - ~self:vm_record.API.vM_suspend_SR) + ~self:vm_record.API.vM_suspend_SR) then Db.VM.set_suspend_SR ~__context ~self:vm ~value:Ref.null ; Db.VM.set_parent ~__context ~self:vm ~value:vm_record.API.vM_parent; @@ -1232,8 +1232,8 @@ module VGPU : HandlerTools = struct else (* ...otherwise fall back to looking up the vgpu from the state table. *) log_reraise - ("Failed to find VGPU's GPU group: " ^ (Ref.string_of vgpu_record.API.vGPU_GPU_group)) - (lookup vgpu_record.API.vGPU_GPU_group) state.table in + ("Failed to find VGPU's GPU group: " ^ (Ref.string_of vgpu_record.API.vGPU_GPU_group)) + (lookup vgpu_record.API.vGPU_GPU_group) state.table in let _type = log_reraise ("Failed to find VGPU's type: " ^ (Ref.string_of vgpu_record.API.vGPU_type)) (lookup vgpu_record.API.vGPU_type) state.table in diff --git a/ocaml/xapi/import_raw_vdi.ml b/ocaml/xapi/import_raw_vdi.ml old mode 100755 new mode 100644 diff --git a/ocaml/xapi/import_xva.ml b/ocaml/xapi/import_xva.ml index aa7bcc55beb..247a63ad851 100644 --- a/ocaml/xapi/import_xva.ml +++ b/ocaml/xapi/import_xva.ml @@ -44,99 +44,99 @@ let make __context rpc session_id srid (vms, vdis) = vdi) vdis in debug("Now creating all the VMs"); let ref_from_vm = fun vm -> - let user_version = 0L in - let memory_b = vm.memory in - - let w2k_platform = ["acpi","false"; "apic","false"; "nx","false"; "pae","true"] in - let other_platform = ["acpi","true"; "apic","true"; "nx","false"; "pae","true"] in - - let platform = - match (vm.distrib,vm.distrib_version) with - Some d, Some d_v -> - if d="windows" && d_v="win2k" - then w2k_platform - else other_platform - | _ -> - other_platform - in - - let hVM_boot_policy = if vm.is_hvm then "BIOS order" else "" in - let hVM_boot_params = if vm.is_hvm then [("order","cd")] else [] in - let domain_type = Xapi_vm_helpers.derive_domain_type ~hVM_boot_policy in - - let vm_ref = Client.VM.create ~rpc ~session_id ~name_label:(vm.vm_name ^ " import") - ~blocked_operations:[] - ~name_description:vm.description ~user_version ~is_a_template:false - ~affinity:Ref.null - ~memory_static_max:memory_b - ~memory_dynamic_max:memory_b - ~memory_target:memory_b - ~memory_dynamic_min:memory_b - ~memory_static_min:(Int64.mul 16L (Int64.mul 1024L 1024L)) - ~vCPUs_max:1L ~vCPUs_at_startup:1L - ~vCPUs_params:[] - ~actions_after_shutdown:`destroy ~actions_after_reboot:`restart - ~actions_after_crash:`destroy - ~hVM_boot_policy - ~domain_type - ~hVM_boot_params - ~hVM_shadow_multiplier:1. - ~platform - ~pV_kernel:"" ~pV_ramdisk:"" ~pV_bootloader:"pygrub" - ~pV_legacy_args:vm.kernel_boot_cmdline - ~pV_bootloader_args:"" - ~pV_args:"" - ~pCI_bus:"" ~other_config:[] ~xenstore_data:[] ~recommendations:"" - ~ha_always_run:false ~ha_restart_priority:"" ~tags:[] - ~protection_policy:Ref.null ~is_snapshot_from_vmpp:false - ~snapshot_schedule:Ref.null ~is_vmss_snapshot:false - ~appliance:Ref.null - ~start_delay:0L - ~shutdown_delay:0L - ~order:0L - ~suspend_SR:Ref.null - ~version:0L - ~generation_id:"" - ~hardware_platform_version:0L - ~has_vendor_device:false ~reference_label:"" - in - - TaskHelper.operate_on_db_task ~__context - (fun task -> Client.VM.add_to_other_config ~rpc ~session_id - ~self:vm_ref ~key:Xapi_globs.import_task ~value:(Ref.string_of task)); - - clean_up_stack := - (fun __context rpc session_id -> - Helpers.log_exn_continue - (Printf.sprintf "Attempting to remove import from current_operations of VM: %s" (Ref.string_of vm_ref)) - (fun () -> Db.VM.remove_from_current_operations ~__context ~self:vm_ref ~key:task_id) (); - Client.VM.destroy rpc session_id vm_ref) :: !clean_up_stack; - - (* Although someone could sneak in here and attempt to power on the VM, it - doesn't really matter since no VBDs have been created yet... *) - Db.VM.add_to_current_operations ~__context ~self:vm_ref ~key:task_id ~value:`import; - Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm_ref; - - (* make VBDs *) - List.iter (fun vbd -> - let vdi = List.assoc vbd.vdi (List.combine vdis vdi_refs) in - let vbd_ref = Client.VBD.create ~rpc ~session_id ~vM:vm_ref ~vDI:vdi ~other_config:[Xapi_globs.owner_key,""] - ~userdevice:vbd.device ~bootable:(vbd.funct = Root) ~mode:vbd.mode - ~_type:`Disk - ~empty:false - ~unpluggable:(vbd.vdi.variety <> `system) - ~qos_algorithm_type:"" ~qos_algorithm_params:[] in - clean_up_stack := - (fun __context rpc session_id -> - Client.VBD.destroy rpc session_id vbd_ref) :: !clean_up_stack) vm.vbds; - (* attempt to make CD drive *) - begin - try - ignore (Client.VBD.create ~rpc ~session_id ~vM:vm_ref ~vDI:Ref.null ~other_config:[] ~userdevice:"autodetect" - ~bootable:false ~mode:`RO ~_type:`CD ~unpluggable:true ~empty:true ~qos_algorithm_type:"" ~qos_algorithm_params:[]) - with e -> warn "could not create CD drive on imported XVA: %s" (Printexc.to_string e) - end; - (vm,vm_ref) + let user_version = 0L in + let memory_b = vm.memory in + + let w2k_platform = ["acpi","false"; "apic","false"; "nx","false"; "pae","true"] in + let other_platform = ["acpi","true"; "apic","true"; "nx","false"; "pae","true"] in + + let platform = + match (vm.distrib,vm.distrib_version) with + Some d, Some d_v -> + if d="windows" && d_v="win2k" + then w2k_platform + else other_platform + | _ -> + other_platform + in + + let hVM_boot_policy = if vm.is_hvm then "BIOS order" else "" in + let hVM_boot_params = if vm.is_hvm then [("order","cd")] else [] in + let domain_type = Xapi_vm_helpers.derive_domain_type ~hVM_boot_policy in + + let vm_ref = Client.VM.create ~rpc ~session_id ~name_label:(vm.vm_name ^ " import") + ~blocked_operations:[] + ~name_description:vm.description ~user_version ~is_a_template:false + ~affinity:Ref.null + ~memory_static_max:memory_b + ~memory_dynamic_max:memory_b + ~memory_target:memory_b + ~memory_dynamic_min:memory_b + ~memory_static_min:(Int64.mul 16L (Int64.mul 1024L 1024L)) + ~vCPUs_max:1L ~vCPUs_at_startup:1L + ~vCPUs_params:[] + ~actions_after_shutdown:`destroy ~actions_after_reboot:`restart + ~actions_after_crash:`destroy + ~hVM_boot_policy + ~domain_type + ~hVM_boot_params + ~hVM_shadow_multiplier:1. + ~platform + ~pV_kernel:"" ~pV_ramdisk:"" ~pV_bootloader:"pygrub" + ~pV_legacy_args:vm.kernel_boot_cmdline + ~pV_bootloader_args:"" + ~pV_args:"" + ~pCI_bus:"" ~other_config:[] ~xenstore_data:[] ~recommendations:"" + ~ha_always_run:false ~ha_restart_priority:"" ~tags:[] + ~protection_policy:Ref.null ~is_snapshot_from_vmpp:false + ~snapshot_schedule:Ref.null ~is_vmss_snapshot:false + ~appliance:Ref.null + ~start_delay:0L + ~shutdown_delay:0L + ~order:0L + ~suspend_SR:Ref.null + ~version:0L + ~generation_id:"" + ~hardware_platform_version:0L + ~has_vendor_device:false ~reference_label:"" + in + + TaskHelper.operate_on_db_task ~__context + (fun task -> Client.VM.add_to_other_config ~rpc ~session_id + ~self:vm_ref ~key:Xapi_globs.import_task ~value:(Ref.string_of task)); + + clean_up_stack := + (fun __context rpc session_id -> + Helpers.log_exn_continue + (Printf.sprintf "Attempting to remove import from current_operations of VM: %s" (Ref.string_of vm_ref)) + (fun () -> Db.VM.remove_from_current_operations ~__context ~self:vm_ref ~key:task_id) (); + Client.VM.destroy rpc session_id vm_ref) :: !clean_up_stack; + + (* Although someone could sneak in here and attempt to power on the VM, it + doesn't really matter since no VBDs have been created yet... *) + Db.VM.add_to_current_operations ~__context ~self:vm_ref ~key:task_id ~value:`import; + Xapi_vm_lifecycle.update_allowed_operations ~__context ~self:vm_ref; + + (* make VBDs *) + List.iter (fun vbd -> + let vdi = List.assoc vbd.vdi (List.combine vdis vdi_refs) in + let vbd_ref = Client.VBD.create ~rpc ~session_id ~vM:vm_ref ~vDI:vdi ~other_config:[Xapi_globs.owner_key,""] + ~userdevice:vbd.device ~bootable:(vbd.funct = Root) ~mode:vbd.mode + ~_type:`Disk + ~empty:false + ~unpluggable:(vbd.vdi.variety <> `system) + ~qos_algorithm_type:"" ~qos_algorithm_params:[] in + clean_up_stack := + (fun __context rpc session_id -> + Client.VBD.destroy rpc session_id vbd_ref) :: !clean_up_stack) vm.vbds; + (* attempt to make CD drive *) + begin + try + ignore (Client.VBD.create ~rpc ~session_id ~vM:vm_ref ~vDI:Ref.null ~other_config:[] ~userdevice:"autodetect" + ~bootable:false ~mode:`RO ~_type:`CD ~unpluggable:true ~empty:true ~qos_algorithm_type:"" ~qos_algorithm_params:[]) + with e -> warn "could not create CD drive on imported XVA: %s" (Printexc.to_string e) + end; + (vm,vm_ref) in let vm_refs = List.map ref_from_vm vms in (vm_refs, List.combine vdis vdi_refs, !clean_up_stack) diff --git a/ocaml/xapi/importexport.ml b/ocaml/xapi/importexport.ml index 1ff21c27791..9b4f8349129 100644 --- a/ocaml/xapi/importexport.ml +++ b/ocaml/xapi/importexport.ml @@ -260,24 +260,24 @@ let remote_metadata_export_import ~__context ~rpc ~session_id ~remote_address ~r begin try with_transport (Unix Xapi_globs.unix_domain_socket) (with_http get - (fun (r, ifd) -> - debug "Content-length: %s" (Stdext.Opt.default "None" (Stdext.Opt.map Int64.to_string r.Http.Response.content_length)); - let put = { put with Http.Request.content_length = r.Http.Response.content_length } in - debug "Connecting to %s:%d" remote_address !Xapi_globs.https_port; - (* Spawn a cached stunnel instance. Otherwise, once metadata tranmission completes, the connection - between local xapi and stunnel will be closed immediately, and the new spawned stunnel instance - will be revoked, this might cause the remote stunnel gets partial metadata xml file, and the - ripple effect is that remote xapi fails to parse metadata xml file. Using a cached stunnel can - not always avoid the problem since any cached stunnel entry might be evicted. However, it is - unlikely to happen in practice because the cache size is large enough.*) - with_transport (SSL (SSL.make ~use_stunnel_cache:true (), remote_address, !Xapi_globs.https_port)) - (with_http put - (fun (_, ofd) -> - let (n: int64) = Stdext.Unixext.copy_file ?limit:r.Http.Response.content_length ifd ofd in - debug "Written %Ld bytes" n + (fun (r, ifd) -> + debug "Content-length: %s" (Stdext.Opt.default "None" (Stdext.Opt.map Int64.to_string r.Http.Response.content_length)); + let put = { put with Http.Request.content_length = r.Http.Response.content_length } in + debug "Connecting to %s:%d" remote_address !Xapi_globs.https_port; + (* Spawn a cached stunnel instance. Otherwise, once metadata tranmission completes, the connection + between local xapi and stunnel will be closed immediately, and the new spawned stunnel instance + will be revoked, this might cause the remote stunnel gets partial metadata xml file, and the + ripple effect is that remote xapi fails to parse metadata xml file. Using a cached stunnel can + not always avoid the problem since any cached stunnel entry might be evicted. However, it is + unlikely to happen in practice because the cache size is large enough.*) + with_transport (SSL (SSL.make ~use_stunnel_cache:true (), remote_address, !Xapi_globs.https_port)) + (with_http put + (fun (_, ofd) -> + let (n: int64) = Stdext.Unixext.copy_file ?limit:r.Http.Response.content_length ifd ofd in + debug "Written %Ld bytes" n + ) ) - ) - ) + ) ) with Xmlrpc_client.Stunnel_connection_failed -> raise (Api_errors.Server_error(Api_errors.tls_connection_failed, [remote_address; (string_of_int !Xapi_globs.https_port)])) @@ -307,10 +307,10 @@ let remote_metadata_export_import ~__context ~rpc ~session_id ~remote_address ~r let vdi_of_req ~__context (req: Http.Request.t) = let all = req.Http.Request.query @ req.Http.Request.cookie in - if List.mem_assoc "vdi" all + if List.mem_assoc "vdi" all then let vdi = List.assoc "vdi" all in - if Db.is_valid_ref __context (Ref.of_string vdi) + if Db.is_valid_ref __context (Ref.of_string vdi) then Some (Ref.of_string vdi) else Some (Db.VDI.get_by_uuid ~__context ~uuid:vdi) else diff --git a/ocaml/xapi/map_check.ml b/ocaml/xapi/map_check.ml index 49f10a59e51..f90bdb32ee8 100644 --- a/ocaml/xapi/map_check.ml +++ b/ocaml/xapi/map_check.ml @@ -76,96 +76,96 @@ let setf : 'a field -> 'a -> assoc_list -> assoc_list = type key_type = Enum of string list | EnumSet of string list | IntRange of int*int | String | ReqValue of string let err field key value = - let msg = if key="" then field else field^":"^key in - raise (Api_errors.Server_error (Api_errors.invalid_value, [msg;value])) + let msg = if key="" then field else field^":"^key in + raise (Api_errors.Server_error (Api_errors.invalid_value, [msg;value])) let mem value range = - try Some - (List.find (fun r->(String.lowercase_ascii value)=(String.lowercase_ascii r)) range) - with Not_found -> None + try Some + (List.find (fun r->(String.lowercase_ascii value)=(String.lowercase_ascii r)) range) + with Not_found -> None let assert_value ~field ~key ~attr ~value = - let err v = err field key v in - let (ty,default) = attr in - match ty with - | Enum range -> (match (mem value range) with None->err value|Some v->v) - | EnumSet range -> (* enumset is a comma-separated string *) - let vs = Stdext.Xstringext.String.split ',' value in - List.fold_right - (fun v acc->match (mem v range) with - |None->err v - |Some v-> - if acc="" then v - else begin - if (Stdext.Xstringext.String.has_substr acc v) then err value - else (v^","^acc) - end; - ) - vs "" - | IntRange (min,max) -> - let v=try int_of_string value with _->err value in - if (vmax) then err value else value - | ReqValue required_value -> if value <> required_value then err value else value - | String -> value + let err v = err field key v in + let (ty,default) = attr in + match ty with + | Enum range -> (match (mem value range) with None->err value|Some v->v) + | EnumSet range -> (* enumset is a comma-separated string *) + let vs = Stdext.Xstringext.String.split ',' value in + List.fold_right + (fun v acc->match (mem v range) with + |None->err v + |Some v-> + if acc="" then v + else begin + if (Stdext.Xstringext.String.has_substr acc v) then err value + else (v^","^acc) + end; + ) + vs "" + | IntRange (min,max) -> + let v=try int_of_string value with _->err value in + if (vmax) then err value else value + | ReqValue required_value -> if value <> required_value then err value else value + | String -> value let with_ks ~kss ~fn = - let field,kss=kss in - let corrected_values = List.filter (fun cv->cv<>None) (List.map (fun ks-> fn field ks) kss) in - if List.length corrected_values < 1 then [] - else (match List.hd corrected_values with None->[]|Some cv->cv) + let field,kss=kss in + let corrected_values = List.filter (fun cv->cv<>None) (List.map (fun ks-> fn field ks) kss) in + if List.length corrected_values < 1 then [] + else (match List.hd corrected_values with None->[]|Some cv->cv) let assert_req_values ~field ~ks ~vs = - (* each required values in this ks must match the one in the vs map this key/value belongs to *) - let req_values = List.fold_right - (fun (k,attr) acc->match attr with(ReqValue rv),_->(k,rv)::acc|_->acc) ks [] - in - (if vs<>[] then - List.iter (fun (k,rv)-> - if (List.mem_assoc k vs) then (if rv<>(List.assoc k vs) then err field k rv) - ) req_values - ) + (* each required values in this ks must match the one in the vs map this key/value belongs to *) + let req_values = List.fold_right + (fun (k,attr) acc->match attr with(ReqValue rv),_->(k,rv)::acc|_->acc) ks [] + in + (if vs<>[] then + List.iter (fun (k,rv)-> + if (List.mem_assoc k vs) then (if rv<>(List.assoc k vs) then err field k rv) + ) req_values + ) (* uses xs elements to overwrite ys elements *) let merge xs ys = - let nys = List.map (fun (ky,vy)->if List.mem_assoc ky xs then (ky,(List.assoc ky xs)) else (ky,vy)) ys in - let nxs = List.filter (fun (kx,_)->not(List.mem_assoc kx nys)) xs in - nxs@nys + let nys = List.map (fun (ky,vy)->if List.mem_assoc ky xs then (ky,(List.assoc ky xs)) else (ky,vy)) ys in + let nxs = List.filter (fun (kx,_)->not(List.mem_assoc kx nys)) xs in + nxs@nys let assert_key ~field ~ks ~key ~value = - (* check if the key and value conform to this ks *) - (if not (List.mem_assoc key ks) - then err field key value - else - assert_value ~field ~key ~attr:(List.assoc key ks) ~value - ) + (* check if the key and value conform to this ks *) + (if not (List.mem_assoc key ks) + then err field key value + else + assert_value ~field ~key ~attr:(List.assoc key ks) ~value + ) let assert_keys ~ty ~ks ~value ~db = - let value = merge value db in - with_ks ~kss:ks ~fn: - (fun field (xt,ks) -> - if (xt=ty) then Some - ( - assert_req_values ~field ~ks ~vs:value; - (* for this ks, each key value must be valid *) - List.map (fun (k,v)-> k,(assert_key ~field ~ks ~key:k ~value:v)) value - ) - else None - ) + let value = merge value db in + with_ks ~kss:ks ~fn: + (fun field (xt,ks) -> + if (xt=ty) then Some + ( + assert_req_values ~field ~ks ~vs:value; + (* for this ks, each key value must be valid *) + List.map (fun (k,v)-> k,(assert_key ~field ~ks ~key:k ~value:v)) value + ) + else None + ) let assert_all_keys ~ty ~ks ~value ~db = - let value = merge value db in - with_ks ~kss:ks ~fn: - (fun field (xt,ks)-> - if (xt=ty) then Some - ( - assert_req_values ~field ~ks ~vs:value; - (* add missing keys with default values *) - let value = List.map (fun (k,(kt,default))->if List.mem_assoc k value then (k,(List.assoc k value)) else (k,default)) ks in - (* remove extra unexpected keys *) - let value = List.fold_right (fun (k,v) acc->if List.mem_assoc k ks then (k,v)::acc else acc) value [] in - (* for this ks, each key value must be valid *) - List.map (fun (k,v)-> k,(assert_key ~field ~ks ~key:k ~value:v)) value - ) - else None - ) + let value = merge value db in + with_ks ~kss:ks ~fn: + (fun field (xt,ks)-> + if (xt=ty) then Some + ( + assert_req_values ~field ~ks ~vs:value; + (* add missing keys with default values *) + let value = List.map (fun (k,(kt,default))->if List.mem_assoc k value then (k,(List.assoc k value)) else (k,default)) ks in + (* remove extra unexpected keys *) + let value = List.fold_right (fun (k,v) acc->if List.mem_assoc k ks then (k,v)::acc else acc) value [] in + (* for this ks, each key value must be valid *) + List.map (fun (k,v)-> k,(assert_key ~field ~ks ~key:k ~value:v)) value + ) + else None + ) diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 97533baf9cf..e7a6ff52b57 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -1650,11 +1650,11 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct let source_host = Db.VM.get_resident_on ~__context ~self:vm in let to_equal_or_greater_version = Helpers.host_versions_not_decreasing ~__context - ~host_from:(Helpers.LocalObject source_host) - ~host_to:(Helpers.LocalObject host) in + ~host_from:(Helpers.LocalObject source_host) + ~host_to:(Helpers.LocalObject host) in if (Helpers.rolling_upgrade_in_progress ~__context) && (not to_equal_or_greater_version) then - raise (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])); + raise (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])); (* Make sure the target has enough memory to receive the VM *) let snapshot = Db.VM.get_record ~__context ~self:vm in @@ -1690,8 +1690,8 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct * forward the call to the source. *) let snapshot = Db.VM.get_record ~__context ~self:vm in (fun ~local_fn ~__context ~vm op -> - allocate_vm_to_host ~__context ~vm ~host ~snapshot ~host_op:`vm_migrate (); - forward_vm_op ~local_fn ~__context ~vm op) + allocate_vm_to_host ~__context ~vm ~host ~snapshot ~host_op:`vm_migrate (); + forward_vm_op ~local_fn ~__context ~vm op) else (* Cross pool: just forward to the source host. Resources on the * destination will be reserved separately. *) @@ -1703,8 +1703,8 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct with_vm_operation ~__context ~self:vm ~doc:"VM.migrate_send" ~op:`migrate_send (fun () -> Server_helpers.exec_with_subtask ~__context "VM.assert_can_migrate" (fun ~__context -> - assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map ~vif_map ~vgpu_map ~options - ); + assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map ~vif_map ~vgpu_map ~options + ); forwarder ~local_fn ~__context ~vm (fun session_id rpc -> Client.VM.migrate_send rpc session_id vm dest live vdi_map vif_map options vgpu_map) ) @@ -1980,7 +1980,7 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct let local_fn = Local.VM.s3_resume ~vm in forward_vm_op ~local_fn ~__context ~vm (fun session_id rpc -> Client.VM.s3_resume rpc session_id vm) - let set_bios_strings ~__context ~self ~value = + let set_bios_strings ~__context ~self ~value = info "VM.set_bios_strings: self = '%s'; value = '%s'" (vm_uuid ~__context self) (String.concat "; " (List.map (fun (k,v) -> k ^ "=" ^ v) value)); Local.VM.set_bios_strings ~__context ~self ~value @@ -2666,14 +2666,14 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct let local_fn = Local.Host.set_iscsi_iqn ~host ~value in do_op_on ~local_fn ~__context ~host (fun session_id rpc -> - Client.Host.set_iscsi_iqn rpc session_id host value) + Client.Host.set_iscsi_iqn rpc session_id host value) let set_multipathing ~__context ~host ~value = info "Host.set_multipathing: host='%s' value='%s'" (host_uuid ~__context host) (string_of_bool value); let local_fn = Local.Host.set_multipathing ~host ~value in do_op_on ~local_fn ~__context ~host (fun session_id rpc -> - Client.Host.set_multipathing rpc session_id host value) + Client.Host.set_multipathing rpc session_id host value) end module Host_crashdump = struct @@ -4064,7 +4064,7 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct let update_vdi = Db.Pool_update.get_vdi ~__context ~self in if Db.is_valid_ref __context update_vdi then VDI.forward_vdi_op ~local_fn ~__context ~self:update_vdi - (fun session_id rpc -> Client.Pool_update.pool_clean rpc session_id self) + (fun session_id rpc -> Client.Pool_update.pool_clean rpc session_id self) else info "Pool_update.pool_clean: pool update '%s' has already been cleaned." (pool_update_uuid ~__context self) @@ -4078,7 +4078,7 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct let update_vdi = Db.Pool_update.get_vdi ~__context ~self in if Db.is_valid_ref __context update_vdi then VDI.forward_vdi_op ~local_fn ~__context ~self:update_vdi - (fun session_id rpc -> Client.Pool_update.attach rpc session_id self) + (fun session_id rpc -> Client.Pool_update.attach rpc session_id self) else raise (Api_errors.Server_error(Api_errors.cannot_find_update, [(pool_update_uuid ~__context self)])) @@ -4088,7 +4088,7 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct let update_vdi = Db.Pool_update.get_vdi ~__context ~self in if Db.is_valid_ref __context update_vdi then VDI.forward_vdi_op ~local_fn ~__context ~self:update_vdi - (fun session_id rpc -> Client.Pool_update.detach rpc session_id self) + (fun session_id rpc -> Client.Pool_update.detach rpc session_id self) else raise (Api_errors.Server_error(Api_errors.cannot_find_update, [(pool_update_uuid ~__context self)])) @@ -4198,7 +4198,7 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct end module VUSB = struct - let update_vusb_operations ~__context ~vusb = + let update_vusb_operations ~__context ~vusb = Helpers.with_global_lock (fun () -> Xapi_vusb_helpers.update_allowed_operations ~__context ~self:vusb) @@ -4298,7 +4298,7 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct Xapi_cluster_helpers.with_cluster_operation ~__context ~self:cluster ~doc:"Cluster.add" ~op:`add (fun () -> let cluster_host = do_op_on ~__context ~local_fn ~host - (fun session_id rpc -> Client.Cluster_host.create rpc session_id cluster host) in + (fun session_id rpc -> Client.Cluster_host.create rpc session_id cluster host) in Xapi_cluster_host_helpers.update_allowed_operations ~__context ~self:cluster_host; cluster_host ) diff --git a/ocaml/xapi/monitor_dbcalls.ml b/ocaml/xapi/monitor_dbcalls.ml index a6cba7bbdd5..0a6846b0649 100644 --- a/ocaml/xapi/monitor_dbcalls.ml +++ b/ocaml/xapi/monitor_dbcalls.ml @@ -83,12 +83,12 @@ let get_pif_and_bond_changes () = Hashtbl.add pifs_tmp pif.pif_name pif; ) ) stats; - (* Check if any of the PIFs have changed since our last reading. *) - let pif_changes = get_updates_values ~before:pifs_cached ~after:pifs_tmp in - (* Check if any of the bonds have changed since our last reading. *) - let bond_changes = get_updates_map ~before:bonds_links_up_cached ~after:bonds_links_up_tmp in - (* Return lists of changes. *) - (pif_changes, bond_changes) + (* Check if any of the PIFs have changed since our last reading. *) + let pif_changes = get_updates_values ~before:pifs_cached ~after:pifs_tmp in + (* Check if any of the bonds have changed since our last reading. *) + let bond_changes = get_updates_map ~before:bonds_links_up_cached ~after:bonds_links_up_tmp in + (* Return lists of changes. *) + (pif_changes, bond_changes) let set_pif_changes ?except () = Mutex.execute pifs_cached_m (fun _ -> diff --git a/ocaml/xapi/monitor_pvs_proxy.ml b/ocaml/xapi/monitor_pvs_proxy.ml index c10759f7c53..2fa662a6052 100644 --- a/ocaml/xapi/monitor_pvs_proxy.ml +++ b/ocaml/xapi/monitor_pvs_proxy.ml @@ -32,17 +32,17 @@ let find_rrd_files () = |> Array.to_list |> List.filter (String.startswith metrics_prefix) - (* The PVS Proxy status cache [pvs_proxy_cached] contains the status - * entries from PVS Proxies as reported via RRD. When the status - * changes, it is updated in the xapi database. However: The xapi - * databse is only updated for proxies that are currently attached. - * This can lead to divergence between the cache and the database, - * leading to error CA-229176. When the PVS Proxy is attached in - * xapi_xenops.ml, the cache entry for the PVS Proxy is invalidated - * such that it is picked up again and updated in the xapi database. - * Inconsistencies are thus limited to the time between when a PVS - * Proxy starts reporting its status and when it is attached. - *) +(* The PVS Proxy status cache [pvs_proxy_cached] contains the status + * entries from PVS Proxies as reported via RRD. When the status + * changes, it is updated in the xapi database. However: The xapi + * databse is only updated for proxies that are currently attached. + * This can lead to divergence between the cache and the database, + * leading to error CA-229176. When the PVS Proxy is attached in + * xapi_xenops.ml, the cache entry for the PVS Proxy is invalidated + * such that it is picked up again and updated in the xapi database. + * Inconsistencies are thus limited to the time between when a PVS + * Proxy starts reporting its status and when it is attached. +*) let get_changes () = List.iter (fun filename -> diff --git a/ocaml/xapi/nm.ml b/ocaml/xapi/nm.ml index 1fa34c7f7bf..d686fe26665 100644 --- a/ocaml/xapi/nm.ml +++ b/ocaml/xapi/nm.ml @@ -469,14 +469,14 @@ let bring_pif_up ~__context ?(management_interface=false) (pif: API.ref_PIF) = (* sync MTU *) begin - try - let mtu = Int64.of_int (Net.Interface.get_mtu dbg bridge) in - if mtu <> rc.API.pIF_MTU then - Db.PIF.set_MTU ~__context ~self:pif ~value:mtu - with _ -> - warn "could not update MTU field on PIF %s" rc.API.pIF_uuid + try + let mtu = Int64.of_int (Net.Interface.get_mtu dbg bridge) in + if mtu <> rc.API.pIF_MTU then + Db.PIF.set_MTU ~__context ~self:pif ~value:mtu + with _ -> + warn "could not update MTU field on PIF %s" rc.API.pIF_uuid end; - + (* sync igmp_snooping_enabled *) if rc.API.pIF_VLAN = -1L then begin let igmp_snooping = Db.Pool.get_igmp_snooping_enabled ~__context ~self:(Helpers.get_pool ~__context) in @@ -484,7 +484,7 @@ let bring_pif_up ~__context ?(management_interface=false) (pif: API.ref_PIF) = if igmp_snooping' <> rc.API.pIF_igmp_snooping_status then Db.PIF.set_igmp_snooping_status ~__context ~self:pif ~value:igmp_snooping' end - ) + ) let bring_pif_down ~__context ?(force=false) (pif: API.ref_PIF) = with_local_lock (fun () -> diff --git a/ocaml/xapi/pvs_cache_vdi.ml b/ocaml/xapi/pvs_cache_vdi.ml index f19ea59c12b..369a63a4a49 100644 --- a/ocaml/xapi/pvs_cache_vdi.ml +++ b/ocaml/xapi/pvs_cache_vdi.ml @@ -35,17 +35,17 @@ let create_vdi ~__context ~sR ~size = ) (* Before simply returning the VDI from the DB, check if it actually - still exists on disk. The VDI may have gone away if it was on a - non-persistent SR (e.g. on a RAM disk). *) + still exists on disk. The VDI may have gone away if it was on a + non-persistent SR (e.g. on a RAM disk). *) let get_vdi ~__context ~self = let vdi = Db.PVS_cache_storage.get_VDI ~__context ~self in (* If there is already an attached VBD for the VDI, then we assume that all is well. *) let vbds = Db.VBD.get_refs_where ~__context ~expr:( - And ( - Eq (Field "VDI", Literal (Ref.string_of vdi)), - Eq (Field "currently_attached", Literal "true") - ) - ) in + And ( + Eq (Field "VDI", Literal (Ref.string_of vdi)), + Eq (Field "currently_attached", Literal "true") + ) + ) in if vbds <> [] then Some vdi else begin @@ -53,8 +53,8 @@ let get_vdi ~__context ~self = by an actual volume on the SR. *) let sr = Db.PVS_cache_storage.get_SR ~__context ~self in Helpers.call_api_functions ~__context (fun rpc session_id -> - Client.Client.SR.scan ~rpc ~session_id ~sr - ); + Client.Client.SR.scan ~rpc ~session_id ~sr + ); (* If our VDI reference is still valid, then we're good. *) if Db.is_valid_ref __context vdi then Some vdi diff --git a/ocaml/xapi/pvs_proxy_control.ml b/ocaml/xapi/pvs_proxy_control.ml index d9902642acc..7b26dfd8f2e 100644 --- a/ocaml/xapi/pvs_proxy_control.ml +++ b/ocaml/xapi/pvs_proxy_control.ml @@ -72,43 +72,43 @@ module State = struct let vif_uuid = Db.VIF.get_uuid ~__context ~self:vif in let proxy_uuid = Db.PVS_proxy.get_uuid ~__context ~self:proxy in with_xs (fun xs -> - let dir = root // site_uuid // vif_uuid in - xs.Xs.write (dir // _state) (string_of state); - xs.Xs.write (dir // _proxy_uuid) proxy_uuid - ) + let dir = root // site_uuid // vif_uuid in + xs.Xs.write (dir // _state) (string_of state); + xs.Xs.write (dir // _proxy_uuid) proxy_uuid + ) let remove_proxy ~__context site vif = let site_uuid = Db.PVS_site.get_uuid ~__context ~self:site in let vif_uuid = Db.VIF.get_uuid ~__context ~self:vif in with_xs (fun xs -> - let dir = root // site_uuid // vif_uuid in - xs.Xs.rm dir - ) + let dir = root // site_uuid // vif_uuid in + xs.Xs.rm dir + ) let remove_site ~__context site = let site_uuid = Db.PVS_site.get_uuid ~__context ~self:site in with_xs (fun xs -> - xs.Xs.rm (root // site_uuid) - ) + xs.Xs.rm (root // site_uuid) + ) let get_running_proxies ~__context site = let site_uuid = Db.PVS_site.get_uuid ~__context ~self:site in with_xs (fun xs -> - xs.Xs.directory (root // site_uuid) |> - List.filter_map (fun vif_uuid -> - try - let dir = root // site_uuid // vif_uuid in - let state = of_string (xs.Xs.read (dir // _state)) in - if state = Starting || state = Started then - let proxy_uuid = xs.Xs.read (dir // _proxy_uuid) in - let vif = Db.VIF.get_by_uuid ~__context ~uuid:vif_uuid in - let proxy = Db.PVS_proxy.get_by_uuid ~__context ~uuid:proxy_uuid in - Some (vif, proxy) - else - None - with _ -> None + xs.Xs.directory (root // site_uuid) |> + List.filter_map (fun vif_uuid -> + try + let dir = root // site_uuid // vif_uuid in + let state = of_string (xs.Xs.read (dir // _state)) in + if state = Starting || state = Started then + let proxy_uuid = xs.Xs.read (dir // _proxy_uuid) in + let vif = Db.VIF.get_by_uuid ~__context ~uuid:vif_uuid in + let proxy = Db.PVS_proxy.get_by_uuid ~__context ~uuid:proxy_uuid in + Some (vif, proxy) + else + None + with _ -> None + ) ) - ) end let metadata_of_site ~__context ~site ~vdi ~proxies = @@ -155,10 +155,10 @@ let update_site_on_localhost ~__context ~site ~vdi = let open Network.Net.PVS_proxy in let dbg = Context.string_of_task __context in Mutex.execute configure_proxy_m (fun () -> - let proxies = State.get_running_proxies ~__context site in - let proxy_config = metadata_of_site ~__context ~site ~vdi ~proxies in - Network.Net.PVS_proxy.configure_site dbg proxy_config - ) + let proxies = State.get_running_proxies ~__context site in + let proxy_config = metadata_of_site ~__context ~site ~vdi ~proxies in + Network.Net.PVS_proxy.configure_site dbg proxy_config + ) (** Request xcp-networkd to tell the local PVS-proxy daemon that it must stop * proxying for the given site, and release the associated cache VDI. *) @@ -169,8 +169,8 @@ let remove_site_on_localhost ~__context ~site = let uuid = Db.PVS_site.get_uuid ~__context ~self:site in State.remove_site ~__context site; Mutex.execute configure_proxy_m (fun () -> - Network.Net.PVS_proxy.remove_site dbg uuid - ) + Network.Net.PVS_proxy.remove_site dbg uuid + ) exception No_cache_sr_available @@ -253,15 +253,15 @@ let start_proxy ~__context vif proxy = | Api_errors.Server_error ("SR_BACKEND_FAILURE_79", _) -> let proxy_uuid = Db.PVS_proxy.get_uuid ~__context ~self:proxy in let body = Printf.sprintf - "Unable to setup PVS-proxy %s for VIF %s and PVS-site %s: \ - PVS cache size for host %s exceeds SR available space." - proxy_uuid (Db.VIF.get_uuid ~__context ~self:vif) - (Db.PVS_site.get_name_label ~__context ~self:(Db.PVS_proxy.get_site ~__context ~self:proxy)) - (Db.Host.get_name_label ~__context ~self:(Helpers.get_localhost ~__context)) in + "Unable to setup PVS-proxy %s for VIF %s and PVS-site %s: \ + PVS cache size for host %s exceeds SR available space." + proxy_uuid (Db.VIF.get_uuid ~__context ~self:vif) + (Db.PVS_site.get_name_label ~__context ~self:(Db.PVS_proxy.get_site ~__context ~self:proxy)) + (Db.Host.get_name_label ~__context ~self:(Helpers.get_localhost ~__context)) in let (name, priority) = Api_messages.pvs_proxy_sr_out_of_space in Helpers.call_api_functions ~__context (fun rpc session_id -> ignore(Client.Client.Message.create - ~rpc ~session_id ~name ~priority ~cls:`PVS_proxy ~obj_uuid:proxy_uuid ~body)); + ~rpc ~session_id ~name ~priority ~cls:`PVS_proxy ~obj_uuid:proxy_uuid ~body)); "PVS cache size exceeds SR available space" | _ -> Printf.sprintf "unknown error (%s)" (Printexc.to_string e) in @@ -297,8 +297,8 @@ let stop_proxy ~__context vif proxy = error "Unable to disable PVS proxy for VIF %s: %s." (Ref.string_of vif) reason let clear_proxy_state ~__context vif proxy = - Db.PVS_proxy.set_currently_attached ~__context ~self:proxy ~value:false; - Db.PVS_proxy.set_status ~__context ~self:proxy ~value:`stopped + Db.PVS_proxy.set_currently_attached ~__context ~self:proxy ~value:false; + Db.PVS_proxy.set_status ~__context ~self:proxy ~value:`stopped let find_proxy_for_vif ~__context ~vif = let open Db_filter_types in diff --git a/ocaml/xapi/rbac.ml b/ocaml/xapi/rbac.ml index 3262f07ffd1..938f5f66d5b 100644 --- a/ocaml/xapi/rbac.ml +++ b/ocaml/xapi/rbac.ml @@ -81,7 +81,7 @@ let permission_set permission_list = let create_session_permissions_tbl ~session_id ~rbac_permissions = if use_efficient_permission_set && Pool_role.is_master () (* Create this structure on the master only, *) - (* so as to avoid heap-leaking on the slaves *) + (* so as to avoid heap-leaking on the slaves *) then begin debug "Creating permission-set tree for session %s" (Context.trackid_of_session (Some session_id)); diff --git a/ocaml/xapi/records.ml b/ocaml/xapi/records.ml index 23676784dde..fcbec271265 100644 --- a/ocaml/xapi/records.ml +++ b/ocaml/xapi/records.ml @@ -1013,9 +1013,9 @@ let vm_record rpc session_id vm = ~get:(fun () -> Record_util.s2sm_to_string "; " (x ()).API.vM_bios_strings) ~get_map:(fun () -> (x ()).API.vM_bios_strings) ~set_map:(fun x -> - List.iter (fun (k, v) -> if not (List.mem k Xapi_globs.settable_vm_bios_string_keys) then - raise (Record_util.Record_failure ("Unknown key '"^k^"': expecting " ^ (String.concat ", " Xapi_globs.settable_vm_bios_string_keys)))) x; - Client.VM.set_bios_strings rpc session_id vm x) (); + List.iter (fun (k, v) -> if not (List.mem k Xapi_globs.settable_vm_bios_string_keys) then + raise (Record_util.Record_failure ("Unknown key '"^k^"': expecting " ^ (String.concat ", " Xapi_globs.settable_vm_bios_string_keys)))) x; + Client.VM.set_bios_strings rpc session_id vm x) (); ]} let host_crashdump_record rpc session_id host = @@ -1800,11 +1800,11 @@ let vgpu_record rpc session_id vgpu = make_field ~name:"resident-on" ~get:(fun () -> try get_uuid_from_ref (x ()).API.vGPU_resident_on with _ -> nid) (); make_field ~name:"compatibility-metadata" ~get:(fun () -> - ((x ()).API.vGPU_compatibility_metadata) - |> List.map (fun (k,v) -> Printf.sprintf - "%s:(%d bytes)" k (String.length v)) - |> String.concat "; " - ) (); + ((x ()).API.vGPU_compatibility_metadata) + |> List.map (fun (k,v) -> Printf.sprintf + "%s:(%d bytes)" k (String.length v)) + |> String.concat "; " + ) (); ] } @@ -2034,7 +2034,7 @@ let pusb_record rpc session_id pusb = [ make_field ~name:"uuid" ~get:(fun () -> (x ()).API.pUSB_uuid) (); make_field ~name:"usb-group-uuid" - ~get:(fun () -> try get_uuid_from_ref (x ()).API.pUSB_USB_group with _ -> nid) (); + ~get:(fun () -> try get_uuid_from_ref (x ()).API.pUSB_USB_group with _ -> nid) (); make_field ~name:"host-uuid" ~get:(fun () -> get_uuid_from_ref (x ()).API.pUSB_host) (); make_field ~name:"host-name-label" ~get:(fun () -> try get_name_from_ref (x ()).API.pUSB_host with _ -> nid) (); make_field ~name:"path" ~get:(fun () -> (x ()).API.pUSB_path) (); diff --git a/ocaml/xapi/static_vdis.ml b/ocaml/xapi/static_vdis.ml index 5b36fd7c427..b4bf3498685 100644 --- a/ocaml/xapi/static_vdis.ml +++ b/ocaml/xapi/static_vdis.ml @@ -45,8 +45,8 @@ let permanent_vdi_detach ~__context ~vdi = (Ref.string_of vdi) (Ref.string_of (Db.VDI.get_SR ~__context ~self:vdi)); let vdi_uuid = Db.VDI.get_uuid ~__context ~self:vdi in log_and_ignore_exn(fun () -> - ignore(Helpers.call_script !Xapi_globs.static_vdis - [ "detach"; vdi_uuid ])); + ignore(Helpers.call_script !Xapi_globs.static_vdis + [ "detach"; vdi_uuid ])); ignore(Helpers.call_script !Xapi_globs.static_vdis [ "del"; vdi_uuid ]) @@ -55,7 +55,7 @@ let permanent_vdi_detach_by_uuid ~__context ~uuid = info "permanent_vdi_detach: vdi-uuid = %s" uuid; (* This might fail because the VDI has been destroyed *) log_and_ignore_exn(fun () -> - ignore(Helpers.call_script !Xapi_globs.static_vdis [ "detach"; uuid ])); + ignore(Helpers.call_script !Xapi_globs.static_vdis [ "detach"; uuid ])); ignore(Helpers.call_script !Xapi_globs.static_vdis [ "del"; uuid ]) let detach_only vdi = diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 88489623fe1..30d456793bf 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -210,7 +210,7 @@ module SMAPIv1 = struct error "SR.create failed SR:%s error:%s" (Ref.string_of sr) e'; raise e ); - List.filter (fun (x,_) -> x <> "SRmaster") device_config + List.filter (fun (x,_) -> x <> "SRmaster") device_config ) let set_name_label context ~dbg ~sr ~new_name_label = @@ -943,7 +943,7 @@ let check_queue_exists queue_name = The destination uri needs to be local as [xml_http_rpc] doesn't support https calls, only file and http. Cross-host https calls are only supported by XMLRPC_protocol.rpc - *) +*) let external_rpc queue_name uri = let open Xcp_client in if !use_switch then check_queue_exists queue_name; @@ -1084,7 +1084,7 @@ let unbind ~__context ~pbd = (* Internal SM calls: need to handle redirection, we are the toplevel caller. The SM can decide that a call needs to be run elsewhere, e.g. for a SMAPIv3 plugin the snapshot should be run on the node that has the VDI activated. - *) +*) let rpc = let srcstr = Xcp_client.get_user_agent() in let local_fn = Storage_mux.Server.process None in diff --git a/ocaml/xapi/storage_impl.ml b/ocaml/xapi/storage_impl.ml index d28f0aa1391..cb835f76967 100644 --- a/ocaml/xapi/storage_impl.ml +++ b/ocaml/xapi/storage_impl.ml @@ -657,28 +657,28 @@ module Wrapper = functor(Impl: Server_impl) -> struct it is assumed that all VDIs are already locked. *) let destroy_sr context ~dbg ~dp ~sr ~sr_t ~allow_leak vdi_already_locked = (* Every VDI in use by this session should be detached and deactivated - This code makes the assumption that a datapath is only on 0 or 1 VDIs. However, it retains debug code (identified below) to verify this. + This code makes the assumption that a datapath is only on 0 or 1 VDIs. However, it retains debug code (identified below) to verify this. It also assumes that the VDIs associated with a datapath don't change during its execution - again it retains debug code to verify this. *) let vdis = Sr.list sr_t in - + (* Note that we assume this filter returns 0 or 1 items, but we need to verify that. *) let vdis_with_dp = List.filter (fun(vdi, vdi_t) -> Vdi.dp_on_vdi dp vdi_t) vdis in debug "[destroy_sr] Filtered VDI count:%d" (List.length vdis_with_dp); List.iter (fun(vdi, vdi_t) -> debug "[destroy_sr] VDI found with the dp is %s" vdi) vdis_with_dp; - + let locker vdi = if vdi_already_locked - then fun f -> f () - else VDI.with_vdi sr vdi in + then fun f -> f () + else VDI.with_vdi sr vdi in (* This is debug code to verify that no more than 1 VDI matched the datapath. We also convert the 0 and 1 cases to an Option which is more natural to work with *) let vdi_to_remove = match vdis_with_dp with | [] -> None | [x] -> Some x | _ -> - raise (Storage_interface.Backend_error (Api_errors.internal_error, [Printf.sprintf "Expected 0 or 1 VDI with datapath, had %d" (List.length vdis_with_dp)])); + raise (Storage_interface.Backend_error (Api_errors.internal_error, [Printf.sprintf "Expected 0 or 1 VDI with datapath, had %d" (List.length vdis_with_dp)])); in (* From this point if it didn't raise, the assumption of 0 or 1 VDIs holds *) @@ -686,14 +686,14 @@ module Wrapper = functor(Impl: Server_impl) -> struct | None -> None | Some (vdi, vdi_t) -> ( locker vdi (fun () -> - try - VDI.destroy_datapath_nolock context ~dbg ~dp ~sr ~vdi ~allow_leak; - None - with e -> Some e - ) + try + VDI.destroy_datapath_nolock context ~dbg ~dp ~sr ~vdi ~allow_leak; + None + with e -> Some e + ) ) in - + (* This is debug code to assert that we removed the datapath from all VDIs by looking for a situation where a VDI not known about has the datapath at this point *) (* Can't just check for vdis_with_dp = 0, the actual removal isn't necessarily complete at this point *) let vdi_ident = match vdi_to_remove with @@ -703,7 +703,7 @@ module Wrapper = functor(Impl: Server_impl) -> struct let vdis = Sr.list sr_t in let vdis_with_dp = List.filter (fun(vdi, vdi_t) -> Vdi.dp_on_vdi dp vdi_t) vdis in - + (* Function to see if a (vdi, vdi_t) matches vdi_ident *) let matches (vdi, vdi_t) = match vdi_ident with | None -> false @@ -715,10 +715,10 @@ module Wrapper = functor(Impl: Server_impl) -> struct | [v] -> not (matches v) | _ -> true in - + if race_occured then( - let message = [Printf.sprintf "Expected no new VDIs with DP after destroy_sr. VDI expected with id %s" (match vdi_ident with | None -> "(not attached)" | Some s -> s)] @ - List.map (fun(vdi, vdi_t) -> Printf.sprintf "VDI found with the dp is %s" vdi) vdis_with_dp in + let message = [Printf.sprintf "Expected no new VDIs with DP after destroy_sr. VDI expected with id %s" (match vdi_ident with | None -> "(not attached)" | Some s -> s)] @ + List.map (fun(vdi, vdi_t) -> Printf.sprintf "VDI found with the dp is %s" vdi) vdis_with_dp in raise (Storage_interface.Backend_error (Api_errors.internal_error, message)); ); @@ -727,7 +727,7 @@ module Wrapper = functor(Impl: Server_impl) -> struct let destroy context ~dbg ~dp ~allow_leak = info "DP.destroy dbg:%s dp:%s allow_leak:%b" dbg dp allow_leak; let failures = Host.list !Host.host - |>List.filter_map (fun (sr, sr_t) -> destroy_sr context ~dbg ~dp ~sr ~sr_t ~allow_leak false) in + |>List.filter_map (fun (sr, sr_t) -> destroy_sr context ~dbg ~dp ~sr ~sr_t ~allow_leak false) in match failures, allow_leak with | [], _ -> () diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index b068bb3a9fb..7b51b6cd06d 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -211,9 +211,9 @@ let rpc ~srcstr ~dststr url = let open Http.Url in match url with | (Http h, d) -> - (Http {h with host=ip}, d) + (Http {h with host=ip}, d) | _ -> - remote_url ip + remote_url ip in let local_fn = Helpers.make_remote_rpc_of_url ~srcstr ~dststr url in Storage_utils.redirectable_rpc ~srcstr ~dststr ~remote_url_of_ip ~local_fn @@ -490,13 +490,13 @@ let start' ~task ~dbg ~sr ~vdi ~dp ~url ~dest = let local_vdi = add_to_sm_config local_vdi "mirror" ("nbd:" ^ dp) in let local_vdi = add_to_sm_config local_vdi "base_mirror" id in let snapshot = - try - Local.VDI.snapshot ~dbg ~sr ~vdi_info:local_vdi - with - | Storage_interface.Backend_error(code, _) when code = "SR_BACKEND_FAILURE_44" -> - raise (Api_errors.Server_error(Api_errors.sr_source_space_insufficient, [ sr ])) - | e -> - raise e + try + Local.VDI.snapshot ~dbg ~sr ~vdi_info:local_vdi + with + | Storage_interface.Backend_error(code, _) when code = "SR_BACKEND_FAILURE_44" -> + raise (Api_errors.Server_error(Api_errors.sr_source_space_insufficient, [ sr ])) + | e -> + raise e in debug "Done!"; diff --git a/ocaml/xapi/storage_task.ml b/ocaml/xapi/storage_task.ml index 8b82b312e02..0d8694aae16 100644 --- a/ocaml/xapi/storage_task.ml +++ b/ocaml/xapi/storage_task.ml @@ -16,6 +16,6 @@ let signal id = let handle = handle_of_id tasks id in let state = get_state handle in debug "TASK.signal %s = %s" id (state |> Task.rpc_of_state |> Jsonrpc.to_string); - Updates.add (Dynamic.Task id) updates + Updates.add (Dynamic.Task id) updates with Does_not_exist _ -> debug "TASK.signal %s (object deleted)" id diff --git a/ocaml/xapi/storage_utils.ml b/ocaml/xapi/storage_utils.ml index 4eb7ae6bf0f..df4304107fd 100644 --- a/ocaml/xapi/storage_utils.ml +++ b/ocaml/xapi/storage_utils.ml @@ -24,29 +24,29 @@ open D (** [redirectable_rpc ~srcstr ~dststr ~remote_url_of_ip ~local_fn call] is an RPC function that first attempts to call [local_fn call], and if that returns a [Redirect ip] exception then it sends a remote RPC to the url built by [remote_url_of_ip]. - *) +*) let redirectable_rpc ~srcstr ~dststr ~remote_url_of_ip ~local_fn = let rec rpc ~f call = (* on first iteration this will be the [local_fn] supplied by the caller *) let result = f call in if result.Rpc.success then result else begin - let rpcstr = Rpc.string_of_call call in - debug "Got failure: checking for redirect, call was: %s, results.contents: %s" - rpcstr (Jsonrpc.to_string result.Rpc.contents); - match Storage_interface.Exception.exnty_of_rpc result.Rpc.contents with - | Storage_interface.Exception.Redirect (Some ip) -> - let newurl = remote_url_of_ip ip in - debug "Redirecting %s to ip: %s" rpcstr ip; - (* we need to do a remote call now, so replace [f] *) - let f = Helpers.make_remote_rpc_of_url ~srcstr ~dststr newurl in - let r = rpc ~f call in - debug "Successfully redirected %s. Returning" rpcstr; - r - | _ -> - debug "Not a redirect: %s" rpcstr; - result - end + let rpcstr = Rpc.string_of_call call in + debug "Got failure: checking for redirect, call was: %s, results.contents: %s" + rpcstr (Jsonrpc.to_string result.Rpc.contents); + match Storage_interface.Exception.exnty_of_rpc result.Rpc.contents with + | Storage_interface.Exception.Redirect (Some ip) -> + let newurl = remote_url_of_ip ip in + debug "Redirecting %s to ip: %s" rpcstr ip; + (* we need to do a remote call now, so replace [f] *) + let f = Helpers.make_remote_rpc_of_url ~srcstr ~dststr newurl in + let r = rpc ~f call in + debug "Successfully redirected %s. Returning" rpcstr; + r + | _ -> + debug "Not a redirect: %s" rpcstr; + result + end in rpc ~f:local_fn let remote_url ip = Http.Url.(Http { host=ip; auth=None; port=None; ssl=true }, { uri = Constants.sm_uri; query_params=["pool_secret",!Xapi_globs.pool_secret] } ) diff --git a/ocaml/xapi/vgpuops.ml b/ocaml/xapi/vgpuops.ml index 74ad81a50c6..ba3de6b1fff 100644 --- a/ocaml/xapi/vgpuops.ml +++ b/ocaml/xapi/vgpuops.ml @@ -116,8 +116,8 @@ let reserve_free_virtual_function ~__context vm pf = (* We may still need to load the driver... do that and try again *) let pf_host = Db.PCI.get_host ~__context ~self:pf in Helpers.call_api_functions ~__context (fun rpc session_id -> - Client.Client.Host.mxgpu_vf_setup rpc session_id pf_host - ); + Client.Client.Host.mxgpu_vf_setup rpc session_id pf_host + ); get false end else (* This probably means that our capacity checking went wrong! *) @@ -165,7 +165,7 @@ let vgpu_manual_setup_of_vm vm_r = let create_vgpus ~__context host (vm, vm_r) hvm = let vgpus = vgpus_of_vm ~__context vm_r in if vgpus <> [] && not hvm then - raise (Api_errors.Server_error (Api_errors.feature_requires_hvm, ["vGPU- and GPU-passthrough needs HVM"])); + raise (Api_errors.Server_error (Api_errors.feature_requires_hvm, ["vGPU- and GPU-passthrough needs HVM"])); add_vgpus_to_vm ~__context host vm vgpus (vgpu_manual_setup_of_vm vm_r) (* This function is called from Xapi_xenops, after forwarding, so possibly on a slave. *) diff --git a/ocaml/xapi/vm_evacuation.ml b/ocaml/xapi/vm_evacuation.ml index 6cd62498f95..90d114b8f77 100644 --- a/ocaml/xapi/vm_evacuation.ml +++ b/ocaml/xapi/vm_evacuation.ml @@ -49,7 +49,7 @@ let ensure_no_vms ~__context ~rpc ~session_id ~evacuate_timeout = TaskHelper.exn_if_cancelling ~__context; (* First check if _we_ have been cancelled *) info "Requesting evacuation of host"; let timeout = if evacuate_timeout > 0. then evacuate_timeout - else estimate_evacuate_timeout ~__context ~host in + else estimate_evacuate_timeout ~__context ~host in let tasks = [ Client.Async.Host.evacuate ~rpc ~session_id ~host ] in if not (Tasks.with_tasks_destroy ~rpc ~session_id ~timeout ~tasks) then begin get_running_domains () @@ -62,11 +62,11 @@ let ensure_no_vms ~__context ~rpc ~session_id ~evacuate_timeout = let tasks = vms |> List.filter (fun vm -> - List.mem `clean_shutdown (Client.VM.get_allowed_operations ~rpc ~session_id ~self:vm)) + List.mem `clean_shutdown (Client.VM.get_allowed_operations ~rpc ~session_id ~self:vm)) |> List.map (fun vm -> - let name_label = Client.VM.get_name_label ~rpc ~session_id ~self:vm in - debug "Requesting clean shutdown of VM: %s" name_label; - Client.Async.VM.clean_shutdown ~rpc ~session_id ~vm) in + let name_label = Client.VM.get_name_label ~rpc ~session_id ~self:vm in + debug "Requesting clean shutdown of VM: %s" name_label; + Client.Async.VM.clean_shutdown ~rpc ~session_id ~vm) in Tasks.with_tasks_destroy ~rpc ~session_id ~timeout:60. ~tasks |> ignore in @@ -75,16 +75,16 @@ let ensure_no_vms ~__context ~rpc ~session_id ~evacuate_timeout = let tasks = vms |> List.map (fun vm -> - let name_label = Client.VM.get_name_label ~rpc ~session_id ~self:vm in - debug "Requesting hard shutdown of VM: %s" name_label; - Client.Async.VM.hard_shutdown ~rpc ~session_id ~vm) in + let name_label = Client.VM.get_name_label ~rpc ~session_id ~self:vm in + debug "Requesting hard shutdown of VM: %s" name_label; + Client.Async.VM.hard_shutdown ~rpc ~session_id ~vm) in (* no timeout: we need the VMs to be off *) Tasks.wait_for_all ~rpc ~session_id ~tasks; vms |> List.filter is_running |> List.iter (fun vm -> - let name_label = Client.VM.get_name_label ~rpc ~session_id ~self:vm in - info "Failure performing hard shutdown of VM: %s" name_label) + let name_label = Client.VM.get_name_label ~rpc ~session_id ~self:vm in + info "Failure performing hard shutdown of VM: %s" name_label) in let shutdown vms = diff --git a/ocaml/xapi/vm_platform.ml b/ocaml/xapi/vm_platform.ml index 69f129ffb31..01274b0e9e7 100644 --- a/ocaml/xapi/vm_platform.ml +++ b/ocaml/xapi/vm_platform.ml @@ -183,6 +183,6 @@ let check_restricted_flags ~__context platform = let check_restricted_device_model ~__context platform = if not (is_valid_device_model device_model platform) then raise (Api_errors.Server_error(Api_errors.invalid_value, - [Printf.sprintf "platform:%s when vm has VUSBs" device_model - ; try List.assoc device_model platform with _ -> "undefined"]) + [Printf.sprintf "platform:%s when vm has VUSBs" device_model + ; try List.assoc device_model platform with _ -> "undefined"]) ) diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 71f4fbaa9e5..696c722a837 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -512,8 +512,8 @@ let check_network_reset () = match vlan with | Some vlan -> begin match Db.PIF.get_refs_where ~__context ~expr:(And ( - Eq (Field "device", Literal device), - Eq (Field "VLAN", Literal vlan))) with + Eq (Field "device", Literal device), + Eq (Field "VLAN", Literal vlan))) with | [] -> None | pif :: _ -> Some (Db.PIF.get_network ~__context ~self:pif) end @@ -539,7 +539,7 @@ let check_network_reset () = | Some network -> network in let vlan, untagged_PIF = Xapi_vlan.create_internal ~__context ~host ~tagged_PIF:pif - ~network ~tag:(Int64.of_string vlan) ~device in + ~network ~tag:(Int64.of_string vlan) ~device in untagged_PIF in diff --git a/ocaml/xapi/xapi_bond.ml b/ocaml/xapi/xapi_bond.ml index 549d06c3a98..1b8af6547f0 100644 --- a/ocaml/xapi/xapi_bond.ml +++ b/ocaml/xapi/xapi_bond.ml @@ -150,8 +150,8 @@ let move_vlan ~__context host new_slave old_vlan = move_management ~__context old_master new_master; end else begin - debug "Plugging new VLAN"; - Nm.bring_pif_up ~__context new_master + debug "Plugging new VLAN"; + Nm.bring_pif_up ~__context new_master end; (* Call Xapi_vif.move_internal on VIFs of running VMs to make sure they end up on the right vSwitch *) let vifs = Db.Network.get_VIFs ~__context ~self:network in diff --git a/ocaml/xapi/xapi_cluster.ml b/ocaml/xapi/xapi_cluster.ml index 87e9ce8ac15..f39ba2b7e48 100644 --- a/ocaml/xapi/xapi_cluster.ml +++ b/ocaml/xapi/xapi_cluster.ml @@ -79,14 +79,14 @@ let destroy ~__context ~self = raise Api_errors.(Server_error(cluster_does_not_have_one_node, [string_of_int n])) in Xapi_stdext_monadic.Opt.iter (fun ch -> - assert_cluster_host_has_no_attached_sr_which_requires_cluster_stack ~__context ~self:ch - ) cluster_host; + assert_cluster_host_has_no_attached_sr_which_requires_cluster_stack ~__context ~self:ch + ) cluster_host; let result = Cluster_client.LocalClient.destroy (rpc ~__context) dbg in match result with | Result.Ok () -> Xapi_stdext_monadic.Opt.iter (fun ch -> - Db.Cluster_host.destroy ~__context ~self:ch - ) cluster_host; + Db.Cluster_host.destroy ~__context ~self:ch + ) cluster_host; Db.Cluster.destroy ~__context ~self; Xapi_clustering.Daemon.disable ~__context | Result.Error error -> handle_error error @@ -131,12 +131,12 @@ let pool_force_destroy ~__context ~self = (* First try to destroy each cluster_host - if we can do so safely then do *) List.iter (fun cluster_host -> - (* We need to run this code on the slave *) - (* We ignore failures here, we'll try a force_destroy after *) - log_and_ignore_exn (fun () -> - Helpers.call_api_functions ~__context (fun rpc session_id -> - Client.Client.Cluster_host.destroy ~rpc ~session_id ~self:cluster_host) - ) + (* We need to run this code on the slave *) + (* We ignore failures here, we'll try a force_destroy after *) + log_and_ignore_exn (fun () -> + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster_host.destroy ~rpc ~session_id ~self:cluster_host) + ) ) slave_cluster_hosts; (* We expect destroy to have failed for some, we'll try to force destroy those *) @@ -146,29 +146,29 @@ let pool_force_destroy ~__context ~self = in (* Now try to force_destroy, keep track of any errors here *) let exns = List.fold_left - (fun exns_so_far cluster_host -> - Helpers.call_api_functions ~__context (fun rpc session_id -> - try - Client.Client.Cluster_host.force_destroy ~rpc ~session_id ~self:cluster_host; - exns_so_far - with e -> - Backtrace.is_important e; - let uuid = Client.Client.Cluster_host.get_uuid ~rpc ~session_id ~self:cluster_host in - debug "Ignoring exception while trying to force destroy cluster host %s: %s" uuid (ExnHelper.string_of_exn e); - e :: exns_so_far + (fun exns_so_far cluster_host -> + Helpers.call_api_functions ~__context (fun rpc session_id -> + try + Client.Client.Cluster_host.force_destroy ~rpc ~session_id ~self:cluster_host; + exns_so_far + with e -> + Backtrace.is_important e; + let uuid = Client.Client.Cluster_host.get_uuid ~rpc ~session_id ~self:cluster_host in + debug "Ignoring exception while trying to force destroy cluster host %s: %s" uuid (ExnHelper.string_of_exn e); + e :: exns_so_far + ) ) - ) - [] all_remaining_cluster_hosts - in + [] all_remaining_cluster_hosts + in - begin + begin match exns with | [] -> () | e :: _ -> raise Api_errors.(Server_error (cluster_force_destroy_failed, [Ref.string_of self])) - end; + end; - Helpers.call_api_functions ~__context (fun rpc session_id -> - Client.Client.Cluster.destroy ~rpc ~session_id ~self) + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.Cluster.destroy ~rpc ~session_id ~self) (* Helper function; concurrency checks are done in implementation of Cluster.destroy and Cluster_host.destroy *) let pool_destroy ~__context ~self = @@ -206,5 +206,5 @@ let pool_resync ~__context ~self = (* Then create the missing Cluster_hosts *) let pool_auto_join = Db.Cluster.get_pool_auto_join ~__context ~self in if pool_auto_join then begin - Db.Host.get_all ~__context |> List.iter (fun host -> Xapi_cluster_host.create_as_necessary ~__context ~host) + Db.Host.get_all ~__context |> List.iter (fun host -> Xapi_cluster_host.create_as_necessary ~__context ~host) end diff --git a/ocaml/xapi/xapi_cluster_helpers.ml b/ocaml/xapi/xapi_cluster_helpers.ml index 3d375ff6b83..45ce82efb7c 100644 --- a/ocaml/xapi/xapi_cluster_helpers.ml +++ b/ocaml/xapi/xapi_cluster_helpers.ml @@ -70,11 +70,11 @@ let update_allowed_operations ~__context ~self = let allowed = List.fold_left check [] all_cluster_operations in (* TODO: check if we need RPU-related checks here for restricting allowed_operations based on if an RPU is in progress... - let allowed = - if Helpers.rolling_upgrade_in_progress ~__context - then Listext.List.intersect allowed Xapi_globs.rpu_allowed_cluster_host_operations - else allowed - in *) + let allowed = + if Helpers.rolling_upgrade_in_progress ~__context + then Listext.List.intersect allowed Xapi_globs.rpu_allowed_cluster_host_operations + else allowed + in *) Db.Cluster.set_allowed_operations ~__context ~self ~value:allowed (** Add to the cluster host's current_operations, call a function and then remove from the diff --git a/ocaml/xapi/xapi_cluster_host.ml b/ocaml/xapi/xapi_cluster_host.ml index 1791e764025..c5749681023 100644 --- a/ocaml/xapi/xapi_cluster_host.ml +++ b/ocaml/xapi/xapi_cluster_host.ml @@ -29,7 +29,7 @@ let fix_pif_prerequisites ~__context (pif_ref,pif_rec) = ignore(ip_of_pif (pif_ref,pif_rec)); if not pif_rec.API.pIF_currently_attached then Helpers.call_api_functions ~__context (fun rpc session_id -> - Client.Client.PIF.plug ~rpc ~session_id ~self:pif_ref); + Client.Client.PIF.plug ~rpc ~session_id ~self:pif_ref); if not pif_rec.API.pIF_disallow_unplug then begin debug "Setting disallow_unplug on cluster PIF"; Db.PIF.set_disallow_unplug ~__context ~self:pif_ref ~value:true @@ -150,6 +150,6 @@ let disable ~__context ~self = let result = Cluster_client.LocalClient.disable (rpc ~__context) dbg in match result with | Result.Ok () -> - Db.Cluster_host.set_enabled ~__context ~self ~value:false + Db.Cluster_host.set_enabled ~__context ~self ~value:false | Result.Error error -> handle_error error ) diff --git a/ocaml/xapi/xapi_cluster_host_helpers.ml b/ocaml/xapi/xapi_cluster_host_helpers.ml index 38a6a8290dd..977f9ce7bb7 100644 --- a/ocaml/xapi/xapi_cluster_host_helpers.ml +++ b/ocaml/xapi/xapi_cluster_host_helpers.ml @@ -69,11 +69,11 @@ let update_allowed_operations ~__context ~self = let allowed = List.fold_left check [] all_cluster_host_operations in (* TODO: check if we need RPU-related checks here for restricting allowed_operations based on if an RPU is in progress... - let allowed = - if Helpers.rolling_upgrade_in_progress ~__context - then Listext.List.intersect allowed Xapi_globs.rpu_allowed_cluster_operations - else allowed - in *) + let allowed = + if Helpers.rolling_upgrade_in_progress ~__context + then Listext.List.intersect allowed Xapi_globs.rpu_allowed_cluster_operations + else allowed + in *) Db.Cluster_host.set_allowed_operations ~__context ~self ~value:allowed (** Add to the cluster host's current_operations, call a function and then remove from the diff --git a/ocaml/xapi/xapi_clustering.ml b/ocaml/xapi/xapi_clustering.ml index a83081e11bd..d6bccb00129 100644 --- a/ocaml/xapi/xapi_clustering.ml +++ b/ocaml/xapi/xapi_clustering.ml @@ -31,7 +31,7 @@ let with_clustering_lock f = (fun () -> debug "Function execution finished; returned host-local clustering lock.")) (* Note we have to add type annotations to network/host here because they're only used in the context of - Db.PIF.get_records_where, and they're just strings there *) + Db.PIF.get_records_where, and they're just strings there *) let pif_of_host ~__context (network : API.ref_network) (host : API.ref_host) = debug "Looking up PIF for network %s" (Ref.string_of network); let pifs = Db.PIF.get_records_where ~__context @@ -93,8 +93,8 @@ let get_required_cluster_stacks ~__context ~sr_sm_type = let with_clustering_lock_if_needed ~__context ~sr_sm_type f = match get_required_cluster_stacks ~__context ~sr_sm_type with - | [] -> f () - | _required_cluster_stacks -> with_clustering_lock f + | [] -> f () + | _required_cluster_stacks -> with_clustering_lock f let find_cluster_host ~__context ~host = match Db.Cluster_host.get_refs_where ~__context @@ -187,7 +187,7 @@ let rpc ~__context = match Context.get_test_clusterd_rpc __context with | Some rpc -> rpc | None -> - Cluster_client.rpc (fun () -> failwith "Can only communicate with xapi-clusterd through message-switch") + Cluster_client.rpc (fun () -> failwith "Can only communicate with xapi-clusterd through message-switch") let is_clustering_disabled_on_host ~__context host = match find_cluster_host ~__context ~host with diff --git a/ocaml/xapi/xapi_db_upgrade.ml b/ocaml/xapi/xapi_db_upgrade.ml index 04ab3b869ed..c1e2ecdfe69 100644 --- a/ocaml/xapi/xapi_db_upgrade.ml +++ b/ocaml/xapi/xapi_db_upgrade.ml @@ -460,12 +460,12 @@ let update_tools_sr_pbd_device_config = { fn = fun ~__context -> let tools_srs = List.filter (fun self -> Db.SR.get_is_tools_sr ~__context ~self) (Db.SR.get_all ~__context) in begin match tools_srs with - | sr :: others -> - (* Let there be only one Tools SR *) - List.iter (fun self -> Db.SR.destroy ~__context ~self) others; - Db.SR.get_PBDs ~__context ~self:sr - |> List.iter (fun self -> Db.PBD.set_device_config ~__context ~self ~value:Xapi_globs.tools_sr_pbd_device_config) - | [] -> () (* Do nothing - dbsync_master creates new tools SR *) + | sr :: others -> + (* Let there be only one Tools SR *) + List.iter (fun self -> Db.SR.destroy ~__context ~self) others; + Db.SR.get_PBDs ~__context ~self:sr + |> List.iter (fun self -> Db.PBD.set_device_config ~__context ~self ~value:Xapi_globs.tools_sr_pbd_device_config) + | [] -> () (* Do nothing - dbsync_master creates new tools SR *) end } @@ -528,22 +528,22 @@ let upgrade_domain_type = { fn = fun ~__context -> List.iter (fun (vm, vmr) -> - if vmr.API.vM_domain_type = `unspecified then begin - let domain_type = - if Helpers.is_domain_zero_with_record ~__context vm vmr then - Xapi_globs.domain_zero_domain_type - else - Xapi_vm_helpers.derive_domain_type - ~hVM_boot_policy:vmr.API.vM_HVM_boot_policy - in - Db.VM.set_domain_type ~__context ~self:vm ~value:domain_type; - if vmr.API.vM_power_state <> `Halted then begin - let metrics = vmr.API.vM_metrics in - (* This is not _always_ correct - if you've changed HVM_boot_policy on a suspended VM - we'll calculate incorrectly here. This should be a vanishingly small probability though! *) - Db.VM_metrics.set_current_domain_type ~__context ~self:metrics ~value:domain_type - end - end + if vmr.API.vM_domain_type = `unspecified then begin + let domain_type = + if Helpers.is_domain_zero_with_record ~__context vm vmr then + Xapi_globs.domain_zero_domain_type + else + Xapi_vm_helpers.derive_domain_type + ~hVM_boot_policy:vmr.API.vM_HVM_boot_policy + in + Db.VM.set_domain_type ~__context ~self:vm ~value:domain_type; + if vmr.API.vM_power_state <> `Halted then begin + let metrics = vmr.API.vM_metrics in + (* This is not _always_ correct - if you've changed HVM_boot_policy on a suspended VM + we'll calculate incorrectly here. This should be a vanishingly small probability though! *) + Db.VM_metrics.set_current_domain_type ~__context ~self:metrics ~value:domain_type + end + end ) (Db.VM.get_all_records ~__context) } diff --git a/ocaml/xapi/xapi_gpumon.mli b/ocaml/xapi/xapi_gpumon.mli index 45da1505d87..93c8e805752 100644 --- a/ocaml/xapi/xapi_gpumon.mli +++ b/ocaml/xapi/xapi_gpumon.mli @@ -56,7 +56,7 @@ module Nvidia : sig * encoded blob that gets passed to functions checking compatibility; * the key is fixed to [key]. This function must be called on the * host where the vGPU is assigned to a pGPU. - *) + *) val get_vgpu_compatibility_metadata : __context:Context.t -> vgpu:API.ref_VGPU (** must refer to NVIDIA vGPU *) @@ -66,7 +66,7 @@ module Nvidia : sig * comatible according to their abstract compatibility metadata. This * code can run on any host. If no vGPU or pGPU metadata is * available, compatibility is assumed. - *) + *) val vgpu_pgpu_are_compatible : __context:Context.t -> vgpu:API.ref_VGPU diff --git a/ocaml/xapi/xapi_ha.mli b/ocaml/xapi/xapi_ha.mli index d54a4e584cc..e397856de2a 100644 --- a/ocaml/xapi/xapi_ha.mli +++ b/ocaml/xapi/xapi_ha.mli @@ -22,14 +22,14 @@ val ha_redo_log : Redo_log.redo_log (** {2 Interface with the low-level HA subsystem} *) module Monitor : - sig - (** Control the background HA monitoring thread *) +sig + (** Control the background HA monitoring thread *) - val plan_out_of_date : bool ref - (** Used to explicitly signal that we should replan *) + val plan_out_of_date : bool ref + (** Used to explicitly signal that we should replan *) - val stop : unit -> unit - end + val stop : unit -> unit +end val ha_prevent_restarts_for : 'a -> int64 -> unit (** Called by MTC in Orlando Update 1 to temporarily block the VM restart thread. *) diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 1ec763113b2..8614017f952 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -42,13 +42,13 @@ let total_memory_of_vm ~__context policy snapshot = let compute_evacuation_plan ~__context total_hosts remaining_hosts vms_and_snapshots = let hosts = List.map (fun host -> host, (Memory_check.host_compute_free_memory_with_maximum_compression ~__context ~host None)) remaining_hosts in let vms = List.map (fun (vm, snapshot) -> - let policy = - match Helpers.check_domain_type snapshot.API.vM_domain_type with - | `hvm | `pv -> Memory_check.Dynamic_min - | `pv_in_pvh -> Memory_check.Static_max - in - vm, total_memory_of_vm ~__context policy snapshot - ) vms_and_snapshots in + let policy = + match Helpers.check_domain_type snapshot.API.vM_domain_type with + | `hvm | `pv -> Memory_check.Dynamic_min + | `pv_in_pvh -> Memory_check.Static_max + in + vm, total_memory_of_vm ~__context policy snapshot + ) vms_and_snapshots in let config = { Binpack.hosts = hosts; vms = vms; placement = []; total_hosts = total_hosts; num_failures = 1 } in Binpack.check_configuration config; diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 5c688db2ec9..9ba05499184 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -162,14 +162,14 @@ let reboot ~__context ~host = () and add the host to the global list of known-dying hosts. *) let mark_host_as_dead ~__context ~host ~reason = let done_already = Mutex.execute Xapi_globs.hosts_which_are_shutting_down_m - (fun () -> - if List.mem host !Xapi_globs.hosts_which_are_shutting_down then - true - else ( - Xapi_globs.hosts_which_are_shutting_down := host :: !Xapi_globs.hosts_which_are_shutting_down; - false - ) - ) in + (fun () -> + if List.mem host !Xapi_globs.hosts_which_are_shutting_down then + true + else ( + Xapi_globs.hosts_which_are_shutting_down := host :: !Xapi_globs.hosts_which_are_shutting_down; + false + ) + ) in if not done_already then ( (* The heartbeat handling code (HA and non-HA) will hopefully ignore the heartbeats and leave the host as dead from now until it comes back with a Pool.hello *) @@ -314,42 +314,42 @@ module Configuration = struct in List.iter (fun ev -> match Event_helper.record_of_event ev with - | Event_helper.Host (host_ref, Some host_rec) -> begin - let oc = host_rec.API.host_other_config in - let iscsi_iqn = try Some (List.assoc "iscsi_iqn" oc) with _ -> None in - begin match iscsi_iqn with - | None -> () - | Some "" -> () - | Some iqn when iqn <> host_rec.API.host_iscsi_iqn -> - Client.Client.Host.set_iscsi_iqn rpc session_id host_ref iqn - | _ -> () - end; - (* Accepted values are "true" and "false" *) - (* If someone deletes the multipathing other_config key, we don't do anything *) - let multipathing = try Some (List.assoc "multipathing" oc |> Pervasives.bool_of_string) with _ -> None in - begin match multipathing with - | None -> () - | Some multipathing when multipathing <> host_rec.API.host_multipathing -> - Client.Client.Host.set_multipathing rpc session_id host_ref multipathing - | _ -> () - end + | Event_helper.Host (host_ref, Some host_rec) -> begin + let oc = host_rec.API.host_other_config in + let iscsi_iqn = try Some (List.assoc "iscsi_iqn" oc) with _ -> None in + begin match iscsi_iqn with + | None -> () + | Some "" -> () + | Some iqn when iqn <> host_rec.API.host_iscsi_iqn -> + Client.Client.Host.set_iscsi_iqn rpc session_id host_ref iqn + | _ -> () + end; + (* Accepted values are "true" and "false" *) + (* If someone deletes the multipathing other_config key, we don't do anything *) + let multipathing = try Some (List.assoc "multipathing" oc |> Pervasives.bool_of_string) with _ -> None in + begin match multipathing with + | None -> () + | Some multipathing when multipathing <> host_rec.API.host_multipathing -> + Client.Client.Host.set_multipathing rpc session_id host_ref multipathing + | _ -> () end - | _ -> ()) - events.Event_types.events; + end + | _ -> ()) + events.Event_types.events; events.Event_types.token) in loop let start_watcher_thread ~__context = Thread.create (fun () -> - let loop = watch_other_configs ~__context 30.0 in - while true do - begin - try - let rec inner token = inner (loop token) in inner "" - with e -> - error "Caught exception in Configuration.start_watcher_thread: %s" (Printexc.to_string e); - Thread.delay 5.0; - end; - done) () |> ignore + let loop = watch_other_configs ~__context 30.0 in + while true do + begin + try + let rec inner token = inner (loop token) in inner "" + with e -> + error "Caught exception in Configuration.start_watcher_thread: %s" (Printexc.to_string e); + Thread.delay 5.0; + end; + done) () |> ignore end diff --git a/ocaml/xapi/xapi_host_helpers.mli b/ocaml/xapi/xapi_host_helpers.mli index 02f259cb1ee..171ac2fe867 100644 --- a/ocaml/xapi/xapi_host_helpers.mli +++ b/ocaml/xapi/xapi_host_helpers.mli @@ -108,7 +108,7 @@ module Configuration : sig val set_initiator_name : string -> unit (** [set_initiator_name iqn] will write the iscsi initiator configuration to the file specified in Xapi_globs (usually /etc/iscsi/initiatorname.iscsi) - *) + *) val set_multipathing : bool -> unit (** [set_multipathing enabled] will touch the file specified in Xapi_globs diff --git a/ocaml/xapi/xapi_mgmt_iface.ml b/ocaml/xapi/xapi_mgmt_iface.ml index 57fc6f38b0c..f588b3f70eb 100644 --- a/ocaml/xapi/xapi_mgmt_iface.ml +++ b/ocaml/xapi/xapi_mgmt_iface.ml @@ -46,10 +46,10 @@ let restart_stunnel_nomutex ~__context ~accept = else [] in let xapissl_args = List.concat - [ [ "restart"; accept ] - ; back_compat ~__context - ; ["permfile=" ^ !Xapi_globs.server_cert_path] - ] in + [ [ "restart"; accept ] + ; back_compat ~__context + ; ["permfile=" ^ !Xapi_globs.server_cert_path] + ] in let (_ : Thread.t) = Thread.create (fun () -> Mutex.execute management_m (fun () -> Forkhelpers.execute_command_get_output !Xapi_globs.xapissl_path xapissl_args diff --git a/ocaml/xapi/xapi_network.ml b/ocaml/xapi/xapi_network.ml index 86f5a3f4594..e23ed84fb00 100644 --- a/ocaml/xapi/xapi_network.ml +++ b/ocaml/xapi/xapi_network.ml @@ -23,17 +23,17 @@ open Db_filter open Network let bridge_blacklist = [ - "xen"; - "xapi"; - "vif"; - "tap"; - "eth"; + "xen"; + "xapi"; + "vif"; + "tap"; + "eth"; ] let internal_bridge_m = Mutex.create () let assert_network_is_managed ~__context ~self = - if not (Db.Network.get_managed ~__context ~self) then + if not (Db.Network.get_managed ~__context ~self) then raise (Api_errors.Server_error (Api_errors.network_unmanaged, [ Ref.string_of self ])) let create_internal_bridge ~__context ~bridge ~uuid ~persist = @@ -96,7 +96,7 @@ let attach_internal ?(management_interface=false) ?(force_bringup=false) ~__cont let dbg = Context.string_of_task __context in let bridges = Net.Bridge.get_all dbg () in if not(List.mem net.API.network_bridge bridges) then - raise (Api_errors.Server_error (Api_errors.bridge_not_available, [ net.API.network_bridge ])); + raise (Api_errors.Server_error (Api_errors.bridge_not_available, [ net.API.network_bridge ])); end else begin (* Ensure internal bridge exists and is up. external bridges will be @@ -123,10 +123,10 @@ let attach_internal ?(management_interface=false) ?(force_bringup=false) ~__cont end else if management_interface then info "PIF %s is the management interface, but it is not managed by xapi. \ - The bridge and IP must be configured through other means." uuid + The bridge and IP must be configured through other means." uuid else info "PIF %s is needed by a VM, but not managed by xapi. \ - The bridge must be configured through other means." uuid + The bridge must be configured through other means." uuid ) local_pifs end @@ -341,14 +341,14 @@ let assert_can_add_purpose ~__context ~network ~current newval = * type doesn't allow searching for a value inside a list. *) Db.Network.get_all ~__context |> List.iter (fun nwk -> - Db.Network.get_purpose ~__context ~self:nwk |> - List.iter (fun suspect -> - if (List.mem suspect bads) then ( - info "Cannot set new network purpose %s when there is a network with purpose %s" (sop newval) (sop suspect); - reject suspect - ) + Db.Network.get_purpose ~__context ~self:nwk |> + List.iter (fun suspect -> + if (List.mem suspect bads) then ( + info "Cannot set new network purpose %s when there is a network with purpose %s" (sop newval) (sop suspect); + reject suspect + ) + ) ) - ) in match newval with | `nbd -> assert_no_net_has_bad_porpoise [`insecure_nbd] diff --git a/ocaml/xapi/xapi_pbd.ml b/ocaml/xapi/xapi_pbd.ml index 8750a0d0e8a..19a3f05e863 100644 --- a/ocaml/xapi/xapi_pbd.ml +++ b/ocaml/xapi/xapi_pbd.ml @@ -168,53 +168,53 @@ let unplug ~__context ~self = let sr = Db.PBD.get_SR ~__context ~self in let sr_sm_type = Db.SR.get_type ~__context ~self:sr in Xapi_clustering.with_clustering_lock_if_needed ~__context ~sr_sm_type (fun () -> - let host = Db.PBD.get_host ~__context ~self in - if Db.Host.get_enabled ~__context ~self:host - then abort_if_storage_attached_to_protected_vms ~__context ~self; + let host = Db.PBD.get_host ~__context ~self in + if Db.Host.get_enabled ~__context ~self:host + then abort_if_storage_attached_to_protected_vms ~__context ~self; - (* If HA is enabled, prevent a PBD whose SR contains a statefile being unplugged *) - let pool = Helpers.get_pool ~__context in - if Db.Pool.get_ha_enabled ~__context ~self:pool then begin - let statefiles = Db.Pool.get_ha_statefiles ~__context ~self:pool in - let statefile_srs = List.map (fun self -> Db.VDI.get_SR ~__context ~self:(Ref.of_string self)) statefiles in - if List.mem sr statefile_srs && not (Xha_scripts.can_unplug_statefile_pbd ()) - then raise (Api_errors.Server_error(Api_errors.ha_is_enabled, [])) - end; + (* If HA is enabled, prevent a PBD whose SR contains a statefile being unplugged *) + let pool = Helpers.get_pool ~__context in + if Db.Pool.get_ha_enabled ~__context ~self:pool then begin + let statefiles = Db.Pool.get_ha_statefiles ~__context ~self:pool in + let statefile_srs = List.map (fun self -> Db.VDI.get_SR ~__context ~self:(Ref.of_string self)) statefiles in + if List.mem sr statefile_srs && not (Xha_scripts.can_unplug_statefile_pbd ()) + then raise (Api_errors.Server_error(Api_errors.ha_is_enabled, [])) + end; - let vdis = get_active_vdis_by_pbd ~__context ~self in - let non_metadata_vdis = List.filter (fun vdi -> Db.VDI.get_type ~__context ~self:vdi <> `metadata) vdis in - if List.length non_metadata_vdis > 0 - then raise (Api_errors.Server_error(Api_errors.vdi_in_use,List.map Ref.string_of non_metadata_vdis)); + let vdis = get_active_vdis_by_pbd ~__context ~self in + let non_metadata_vdis = List.filter (fun vdi -> Db.VDI.get_type ~__context ~self:vdi <> `metadata) vdis in + if List.length non_metadata_vdis > 0 + then raise (Api_errors.Server_error(Api_errors.vdi_in_use,List.map Ref.string_of non_metadata_vdis)); - if Helpers.i_am_srmaster ~__context ~sr then begin - let (metadata_vdis_of_this_pool, metadata_vdis_of_foreign_pool) = - partition_metadata_vdis_by_pool ~__context ~sr - in - (* Remove all foreign metadata VDIs from the cache so that the metadata_latest of remaining VDIs can be updated. *) - Xapi_dr.remove_vdis_from_cache ~__context ~vdis:metadata_vdis_of_foreign_pool; - (* Set all the removed metadata VDIs of foreign pools to have metadata_latest = false. *) - (* This enables the metadata_latest flag to indicate whether we can recover VMs from a VDI. *) - List.iter - (fun vdi -> Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false) - metadata_vdis_of_foreign_pool; - (* Disable metadata replication to VDIs in the SR. *) - List.iter - (fun vdi -> - debug "Automatically disabling database replication to VDI %s" (Ref.string_of vdi); - Xapi_vdi_helpers.disable_database_replication ~__context ~vdi) - metadata_vdis_of_this_pool - end; - let dbg = Ref.string_of (Context.get_task_id __context) in - let uuid = Db.SR.get_uuid ~__context ~self:sr in - Storage_access.transform_storage_exn - (fun () -> C.SR.detach dbg uuid); + if Helpers.i_am_srmaster ~__context ~sr then begin + let (metadata_vdis_of_this_pool, metadata_vdis_of_foreign_pool) = + partition_metadata_vdis_by_pool ~__context ~sr + in + (* Remove all foreign metadata VDIs from the cache so that the metadata_latest of remaining VDIs can be updated. *) + Xapi_dr.remove_vdis_from_cache ~__context ~vdis:metadata_vdis_of_foreign_pool; + (* Set all the removed metadata VDIs of foreign pools to have metadata_latest = false. *) + (* This enables the metadata_latest flag to indicate whether we can recover VMs from a VDI. *) + List.iter + (fun vdi -> Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false) + metadata_vdis_of_foreign_pool; + (* Disable metadata replication to VDIs in the SR. *) + List.iter + (fun vdi -> + debug "Automatically disabling database replication to VDI %s" (Ref.string_of vdi); + Xapi_vdi_helpers.disable_database_replication ~__context ~vdi) + metadata_vdis_of_this_pool + end; + let dbg = Ref.string_of (Context.get_task_id __context) in + let uuid = Db.SR.get_uuid ~__context ~self:sr in + Storage_access.transform_storage_exn + (fun () -> C.SR.detach dbg uuid); - Storage_access.unbind ~__context ~pbd:self; - Db.PBD.set_currently_attached ~__context ~self ~value:false; + Storage_access.unbind ~__context ~pbd:self; + Db.PBD.set_currently_attached ~__context ~self ~value:false; - Xapi_sr_operations.stop_health_check_thread ~__context ~self:sr; + Xapi_sr_operations.stop_health_check_thread ~__context ~self:sr; - Xapi_sr_operations.update_allowed_operations ~__context ~self:sr) + Xapi_sr_operations.update_allowed_operations ~__context ~self:sr) let destroy ~__context ~self = if Db.PBD.get_currently_attached ~__context ~self @@ -233,8 +233,8 @@ let get_locally_attached ~__context = Db.PBD.get_refs_where ~__context ~expr:(Db_filter_types.( And( - Eq (Field "host", Literal (Ref.string_of host)), - Eq (Field "currently_attached", Literal "true")))) + Eq (Field "host", Literal (Ref.string_of host)), + Eq (Field "currently_attached", Literal "true")))) (* Called on shutdown: it unplugs all the PBDs and disables the cluster host. If anything fails it throws an exception *) @@ -243,14 +243,14 @@ let unplug_all_pbds ~__context = (* best effort unplug of all PBDs *) get_locally_attached ~__context |> List.iter (fun pbd -> - let uuid = Db.PBD.get_uuid ~__context ~self:pbd in - TaskHelper.exn_if_cancelling ~__context; - debug "Unplugging PBD %s" uuid; - unplug ~__context ~self:pbd); + let uuid = Db.PBD.get_uuid ~__context ~self:pbd in + TaskHelper.exn_if_cancelling ~__context; + debug "Unplugging PBD %s" uuid; + unplug ~__context ~self:pbd); debug "Finished unplug_all_pbds"; let host = Helpers.get_localhost ~__context in match Xapi_clustering.find_cluster_host ~__context ~host with | None -> info "No cluster host found" | Some self -> - info "Disabling cluster host"; - Xapi_cluster_host.disable ~__context ~self + info "Disabling cluster host"; + Xapi_cluster_host.disable ~__context ~self diff --git a/ocaml/xapi/xapi_pgpu_helpers.ml b/ocaml/xapi/xapi_pgpu_helpers.ml index 4e6a71d3ca6..126883fd0e0 100644 --- a/ocaml/xapi/xapi_pgpu_helpers.ml +++ b/ocaml/xapi/xapi_pgpu_helpers.ml @@ -212,9 +212,9 @@ let assert_destination_has_pgpu_compatible_with_vm ~__context ~vm ~vgpu_map ~hos | `nvidia -> Db.VGPU.get_GPU_group ~__context ~self:vgpu |> fun self -> Db.GPU_group.get_GPU_types ~__context ~self - |> fun pgpu_types -> get_first_suitable_pgpu pgpu_types vgpu pgpus - |> fun pgpu -> - assert_destination_pgpu_is_compatible_with_vm ~__context ~vm ~vgpu ~pgpu ~host ?remote () + |> fun pgpu_types -> get_first_suitable_pgpu pgpu_types vgpu pgpus + |> fun pgpu -> + assert_destination_pgpu_is_compatible_with_vm ~__context ~vm ~vgpu ~pgpu ~host ?remote () in let vgpus = Db.VM.get_VGPUs ~__context ~self:vm in let _mapped, unmapped = List.partition (fun vgpu -> List.mem_assoc vgpu vgpu_map) vgpus in diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index bd9ca3edb06..dbb40f5a414 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -272,12 +272,12 @@ let assert_fcoe_not_in_use ~__context pif = let sr = pbd_rec.API.pBD_SR in match Db.SR.get_type ~__context ~self:sr with | "lvmofcoe" ->( - try - let scsid = List.assoc "SCSIid" pbd_rec.API.pBD_device_config in - if List.mem scsid fcoe_scsids then raise (Api_errors.Server_error(Api_errors.pif_has_fcoe_sr_in_use, [Ref.string_of pif; Ref.string_of sr])) - with Not_found -> - () - ) + try + let scsid = List.assoc "SCSIid" pbd_rec.API.pBD_device_config in + if List.mem scsid fcoe_scsids then raise (Api_errors.Server_error(Api_errors.pif_has_fcoe_sr_in_use, [Ref.string_of pif; Ref.string_of sr])) + with Not_found -> + () + ) | _ -> () ) @@ -448,7 +448,7 @@ let assert_no_clustering_enabled ~__context ~network ~host = if not (Xapi_clustering.is_clustering_disabled_on_host ~__context host) then (Db.Cluster.get_refs_where ~__context - ~expr:Db_filter_types.(Eq(Field "network", Literal (Ref.string_of network)))) + ~expr:Db_filter_types.(Eq(Field "network", Literal (Ref.string_of network)))) |> function | [] -> () | _::_ -> raise Api_errors.(Server_error (clustering_enabled_on_network, [Ref.string_of network])) diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index 510ad2393c6..0f21e8d3da3 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -181,19 +181,19 @@ let create_yum_config ~__context ~self ~url = let signed_index = if signed then 1 else 0 in let name_label = Db.Pool_update.get_name_label ~__context ~self in String.concat "\n" - [ "[main]" - ; "keepcache=0" - ; "reposdir=/dev/null" - ; Printf.sprintf "gpgcheck=%d" signed_index - ; Printf.sprintf "repo_gpgcheck=%d" signed_index - ; "installonlypkgs=" - ; "" - ; Printf.sprintf "[%s]" name_label - ; Printf.sprintf "name=%s" name_label - ; Printf.sprintf "baseurl=%s" url - ; if signed then Printf.sprintf ("gpgkey=file:///etc/pki/rpm-gpg/%s") key else "" - ; "" (* Newline at the end of the file *) - ] + [ "[main]" + ; "keepcache=0" + ; "reposdir=/dev/null" + ; Printf.sprintf "gpgcheck=%d" signed_index + ; Printf.sprintf "repo_gpgcheck=%d" signed_index + ; "installonlypkgs=" + ; "" + ; Printf.sprintf "[%s]" name_label + ; Printf.sprintf "name=%s" name_label + ; Printf.sprintf "baseurl=%s" url + ; if signed then Printf.sprintf ("gpgkey=file:///etc/pki/rpm-gpg/%s") key else "" + ; "" (* Newline at the end of the file *) + ] let attach_helper ~__context ~uuid ~vdi = let host = Helpers.get_localhost ~__context in @@ -272,16 +272,16 @@ let parse_update_info xml = | Xml.Element("name-description", _, [ Xml.PCData s ]) -> s | _ -> raise (Api_errors.Server_error(Api_errors.invalid_update, ["missing in update.xml"])) in - { uuid - ; name_label - ; name_description - ; version - ; key = Filename.basename key - ; installation_size - ; after_apply_guidance = guidance - ; other_config = [] - ; enforce_homogeneity - } + { uuid + ; name_label + ; name_description + ; version + ; key = Filename.basename key + ; installation_size + ; after_apply_guidance = guidance + ; other_config = [] + ; enforce_homogeneity + } | _ -> raise (Api_errors.Server_error(Api_errors.invalid_update, ["missing in update.xml"])) let extract_applied_update_info applied_uuid = @@ -298,9 +298,9 @@ let extract_update_info ~__context ~vdi ~verify = let update_path = Printf.sprintf "%s/%s/vdi" Xapi_globs.host_update_dir vdi_uuid in debug "pool_update.extract_update_info get url='%s', will parse_file in '%s'" url update_path; let xml = try - Xml.parse_file (Filename.concat update_path "update.xml") - with _ -> - raise (Api_errors.Server_error (Api_errors.invalid_update, ["missing update document (update.xml) in the package."])) + Xml.parse_file (Filename.concat update_path "update.xml") + with _ -> + raise (Api_errors.Server_error (Api_errors.invalid_update, ["missing update document (update.xml) in the package."])) in let update_info = parse_update_info xml in ignore(verify update_info update_path); update_info @@ -308,9 +308,9 @@ let extract_update_info ~__context ~vdi ~verify = (fun () -> detach_helper ~__context ~uuid:vdi_uuid ~vdi) let get_free_bytes path = - let stat = statvfs path in - (* block size times free blocks *) - Int64.mul stat.f_frsize stat.f_bfree + let stat = statvfs path in + (* block size times free blocks *) + Int64.mul stat.f_frsize stat.f_bfree let assert_space_available ?(multiplier=3L) ?(get_free_bytes=get_free_bytes) update_dir update_size = let free_bytes = get_free_bytes update_dir in @@ -393,13 +393,13 @@ let introduce ~__context ~vdi = let update = Db.Pool_update.get_by_uuid ~__context ~uuid:update_info.uuid in let vdi_of_update = Db.Pool_update.get_vdi ~__context ~self:update in if not (Db.is_valid_ref __context vdi_of_update) then begin - Db.Pool_update.set_vdi ~__context ~self:update ~value:vdi; - update + Db.Pool_update.set_vdi ~__context ~self:update ~value:vdi; + update end else if vdi <> vdi_of_update then - raise (Api_errors.Server_error(Api_errors.update_already_exists, [update_info.uuid])) + raise (Api_errors.Server_error(Api_errors.update_already_exists, [update_info.uuid])) else - update + update with | Db_exn.Read_missing_uuid (_,_,_) -> let update = Ref.make () in @@ -518,12 +518,12 @@ let resync_host ~__context ~host = *) Db.Pool_update.get_all ~__context |> List.filter (fun self -> - Db.Pool_update.get_hosts ~__context ~self = [] - && Xapi_pool_patch.pool_patch_of_update ~__context self - |> fun self -> Db.Pool_patch.get_host_patches ~__context ~self - |> function [] -> false | _ -> true) + Db.Pool_update.get_hosts ~__context ~self = [] + && Xapi_pool_patch.pool_patch_of_update ~__context self + |> fun self -> Db.Pool_patch.get_host_patches ~__context ~self + |> function [] -> false | _ -> true) |> List.iter (fun self -> destroy ~__context ~self); - + (* Clean up host_patch table *) Db_gc_util.gc_Host_patches ~__context end diff --git a/ocaml/xapi/xapi_pusb.ml b/ocaml/xapi/xapi_pusb.ml index 6a6e24559f5..ff3a9b1a992 100644 --- a/ocaml/xapi/xapi_pusb.ml +++ b/ocaml/xapi/xapi_pusb.ml @@ -20,7 +20,7 @@ module D = Debug.Make(struct let name="xapi" end) open D let create ~__context ~uSB_group ~host ~other_config ~path - ~vendor_id ~vendor_desc ~product_id ~product_desc ~serial ~version ~description = + ~vendor_id ~vendor_desc ~product_id ~product_desc ~serial ~version ~description = let pusb = Ref.make () and uuid = Uuid.make_uuid () in let host = Helpers.get_localhost ~__context in Db.PUSB.create ~__context ~ref:pusb ~uuid:(Uuid.to_string uuid) @@ -46,18 +46,18 @@ let scan_start ~__context usbs = let local_usb_set = get_local_usb usbs in (* Create the newly added pusbs *) USBSet.iter (fun s -> let self = create ~__context ~uSB_group:(Ref.null) ~host ~other_config:[] ~path:s.USB.path ~vendor_id:s.USB.vendor_id - ~vendor_desc:s.USB.vendor_desc ~product_id:s.USB.product_id ~product_desc:s.USB.product_desc ~serial:s.USB.serial - ~version:s.USB.version ~description:s.USB.description in - let group = Xapi_pusb_helpers.find_or_create ~__context self in - Db.PUSB.set_USB_group ~__context ~self ~value:group - ) (USBSet.diff local_usb_set known_usb_set); + ~vendor_desc:s.USB.vendor_desc ~product_id:s.USB.product_id ~product_desc:s.USB.product_desc ~serial:s.USB.serial + ~version:s.USB.version ~description:s.USB.description in + let group = Xapi_pusb_helpers.find_or_create ~__context self in + Db.PUSB.set_USB_group ~__context ~self ~value:group + ) (USBSet.diff local_usb_set known_usb_set); List.filter (fun (rf, rc) -> USBSet.mem (extract_known_usb_info rc) (USBSet.diff known_usb_set local_usb_set)) known_pusbs_in_db |> List.iter (fun (self, _) -> - try - Xapi_pusb_helpers.destroy_pusb ~__context self; - with e -> error "Caught exception while removing PUSB %s: %s" (Ref.string_of self) (Printexc.to_string e); - ) + try + Xapi_pusb_helpers.destroy_pusb ~__context self; + with e -> error "Caught exception while removing PUSB %s: %s" (Ref.string_of self) (Printexc.to_string e); + ) let cond = Condition.create () let mutex = Mutex.create () @@ -103,57 +103,57 @@ let get_sm_usb_path ~__context vdi = let set_passthrough_enabled ~__context ~self ~value = Mutex.execute mutex (fun () -> - match value with - | true -> - (* Remove the vdi records which 'usb_path' in sm-config has the - same value with the field 'path' in PUSB. *) - let pusb_path = Db.PUSB.get_path ~__context ~self in - let udev_srs = Db.SR.get_refs_where ~__context ~expr:(Eq(Field "type", Literal "udev")) in - List.iter (fun sr -> - Db.VDI.get_refs_where ~__context ~expr:(Eq(Field "SR", Literal (Ref.string_of sr))) |> - List.iter (fun rf -> - try - if (get_sm_usb_path ~__context rf) = pusb_path then begin - let vbds = Db.VDI.get_VBDs ~__context ~self:rf in - if vbds <> [] then - raise (Api_errors.Server_error(Api_errors.pusb_vdi_conflict, [ Ref.string_of self; Ref.string_of rf ])); - Xapi_vdi.forget ~__context ~vdi:rf - end; - with e -> - debug "Caught failure during remove vdi records."; - raise e - ) - ) udev_srs; - debug "set passthrough_enabled %b" value; - Db.PUSB.set_passthrough_enabled ~__context ~self ~value - | false -> - try - let usb_group = Db.PUSB.get_USB_group ~__context ~self in - let vusbs = Db.USB_group.get_VUSBs ~__context ~self:usb_group in - (* If the USB is passthroughed to vm, need to unplug it firstly*) - let _ = match vusbs with - | [] -> () - | _ :: _ :: _ -> raise Api_errors.(Server_error(internal_error, - [Printf.sprintf "too many vusb on the USB_group: %s" (Ref.string_of usb_group)])) - | [vusb] -> - let currently_attached = Db.VUSB.get_currently_attached ~__context ~self:vusb in - if currently_attached then - let vm = Db.VUSB.get_VM ~__context ~self:vusb in - raise (Api_errors.Server_error(Api_errors.usb_already_attached, [Ref.string_of self; Ref.string_of vm])) - in - (* If vusb has been created, need to destroy it. *) - List.iter (fun vusb -> Db.VUSB.destroy ~__context ~self:vusb) vusbs; - debug "set passthrough_enabled %b." value; - Db.PUSB.set_passthrough_enabled ~__context ~self ~value; - (* Re-display the removed vdi records. There is a problem here that - we scan all the udev SR, as we cannot get the SR corresponding to the PUSB when - we want to re-display the vdi records. But in udevSR.py we will handle this, as - if passthrough_enabled = true, we will not re-introduce the vdi. - *) - let open Db_filter_types in - Db.SR.get_refs_where ~__context ~expr:(Eq(Field "type", Literal "udev")) + match value with + | true -> + (* Remove the vdi records which 'usb_path' in sm-config has the + same value with the field 'path' in PUSB. *) + let pusb_path = Db.PUSB.get_path ~__context ~self in + let udev_srs = Db.SR.get_refs_where ~__context ~expr:(Eq(Field "type", Literal "udev")) in + List.iter (fun sr -> + Db.VDI.get_refs_where ~__context ~expr:(Eq(Field "SR", Literal (Ref.string_of sr))) |> + List.iter (fun rf -> + try + if (get_sm_usb_path ~__context rf) = pusb_path then begin + let vbds = Db.VDI.get_VBDs ~__context ~self:rf in + if vbds <> [] then + raise (Api_errors.Server_error(Api_errors.pusb_vdi_conflict, [ Ref.string_of self; Ref.string_of rf ])); + Xapi_vdi.forget ~__context ~vdi:rf + end; + with e -> + debug "Caught failure during remove vdi records."; + raise e + ) + ) udev_srs; + debug "set passthrough_enabled %b" value; + Db.PUSB.set_passthrough_enabled ~__context ~self ~value + | false -> + try + let usb_group = Db.PUSB.get_USB_group ~__context ~self in + let vusbs = Db.USB_group.get_VUSBs ~__context ~self:usb_group in + (* If the USB is passthroughed to vm, need to unplug it firstly*) + let _ = match vusbs with + | [] -> () + | _ :: _ :: _ -> raise Api_errors.(Server_error(internal_error, + [Printf.sprintf "too many vusb on the USB_group: %s" (Ref.string_of usb_group)])) + | [vusb] -> + let currently_attached = Db.VUSB.get_currently_attached ~__context ~self:vusb in + if currently_attached then + let vm = Db.VUSB.get_VM ~__context ~self:vusb in + raise (Api_errors.Server_error(Api_errors.usb_already_attached, [Ref.string_of self; Ref.string_of vm])) + in + (* If vusb has been created, need to destroy it. *) + List.iter (fun vusb -> Db.VUSB.destroy ~__context ~self:vusb) vusbs; + debug "set passthrough_enabled %b." value; + Db.PUSB.set_passthrough_enabled ~__context ~self ~value; + (* Re-display the removed vdi records. There is a problem here that + we scan all the udev SR, as we cannot get the SR corresponding to the PUSB when + we want to re-display the vdi records. But in udevSR.py we will handle this, as + if passthrough_enabled = true, we will not re-introduce the vdi. + *) + let open Db_filter_types in + Db.SR.get_refs_where ~__context ~expr:(Eq(Field "type", Literal "udev")) |> List.iter (fun sr -> Helpers.call_api_functions ~__context (fun rpc session_id -> Client.Client.SR.scan rpc session_id sr)); - with e -> - debug "Caught failure during set passthrough_enabled %b." value; - raise e - ) + with e -> + debug "Caught failure during set passthrough_enabled %b." value; + raise e + ) diff --git a/ocaml/xapi/xapi_pusb_helpers.ml b/ocaml/xapi/xapi_pusb_helpers.ml index 90a7fdb0e9b..e913b16b8ee 100644 --- a/ocaml/xapi/xapi_pusb_helpers.ml +++ b/ocaml/xapi/xapi_pusb_helpers.ml @@ -47,11 +47,11 @@ let extract_member json member = let safe_hd = function | x::_ -> x | _ -> failwith (Printf.sprintf "Internal error: Json from scan script missing element: %s" member) - in - [json] - |> filter_member member - |> filter_string - |> safe_hd + in + [json] + |> filter_member member + |> filter_string + |> safe_hd let extract_local_usb_info usb = let open USB in @@ -123,11 +123,11 @@ let destroy_pusb ~__context pusb = let usb_group = Db.PUSB.get_USB_group ~__context ~self:pusb in let vusbs = Db.USB_group.get_VUSBs ~__context ~self:usb_group in List.iter (fun vusb -> - let currently_attached = Db.VUSB.get_currently_attached ~__context ~self:vusb in - if currently_attached then - Helpers.call_api_functions ~__context (fun rpc session_id -> - Client.Client.VUSB.unplug rpc session_id vusb); - Db.VUSB.destroy ~__context ~self:vusb - ) vusbs; + let currently_attached = Db.VUSB.get_currently_attached ~__context ~self:vusb in + if currently_attached then + Helpers.call_api_functions ~__context (fun rpc session_id -> + Client.Client.VUSB.unplug rpc session_id vusb); + Db.VUSB.destroy ~__context ~self:vusb + ) vusbs; Db.PUSB.destroy ~__context ~self:pusb; Db.USB_group.destroy ~__context ~self:usb_group diff --git a/ocaml/xapi/xapi_sdn_controller.ml b/ocaml/xapi/xapi_sdn_controller.ml index 08aa8724241..f91f6f96971 100644 --- a/ocaml/xapi/xapi_sdn_controller.ml +++ b/ocaml/xapi/xapi_sdn_controller.ml @@ -57,4 +57,4 @@ let forget ~__context ~self = let dbg = Context.string_of_task __context in Db.SDN_controller.destroy ~__context ~self; if Net.Bridge.get_kind dbg () = Network_interface.Openvswitch then - List.iter (fun host -> Helpers.update_vswitch_controller ~__context ~host) (Db.Host.get_all ~__context) + List.iter (fun host -> Helpers.update_vswitch_controller ~__context ~host) (Db.Host.get_all ~__context) diff --git a/ocaml/xapi/xapi_session.ml b/ocaml/xapi/xapi_session.ml index 6a2ce2c065b..74ddebb16cf 100644 --- a/ocaml/xapi/xapi_session.ml +++ b/ocaml/xapi/xapi_session.ml @@ -294,8 +294,8 @@ let login_no_password_common ~__context ~uname ~originator ~host ~pool ~is_local Ref.string_of session_id in let session_id = Ref.of_string (match db_ref with - | Some db_ref -> Db_backend.create_registered_session create_session db_ref - | None -> create_session ()) + | Some db_ref -> Db_backend.create_registered_session create_session db_ref + | None -> create_session ()) in Rbac_audit.session_create ~__context ~session_id ~uname; (* At this point, the session is created, but with an incorrect time *) diff --git a/ocaml/xapi/xapi_sr.ml b/ocaml/xapi/xapi_sr.ml index ad4ca512c53..c0476dcdc68 100644 --- a/ocaml/xapi/xapi_sr.ml +++ b/ocaml/xapi/xapi_sr.ml @@ -193,9 +193,9 @@ let create ~__context ~host ~device_config ~(physical_size:int64) ~name_label ~ ~_type ~content_type ~shared ~sm_config = let pbds, sr_ref = Xapi_clustering.with_clustering_lock_if_needed ~__context ~sr_sm_type:_type (fun () -> Xapi_clustering.assert_cluster_host_is_enabled_for_matching_sms ~__context ~host ~sr_sm_type:_type; - Helpers.assert_rolling_upgrade_not_in_progress ~__context ; - debug "SR.create name_label=%s sm_config=[ %s ]" name_label (String.concat "; " (List.map (fun (k, v) -> k ^ " = " ^ v) sm_config)); - (* This breaks the udev SR which doesn't support sr_probe *) + Helpers.assert_rolling_upgrade_not_in_progress ~__context ; + debug "SR.create name_label=%s sm_config=[ %s ]" name_label (String.concat "; " (List.map (fun (k, v) -> k ^ " = " ^ v) sm_config)); + (* This breaks the udev SR which doesn't support sr_probe *) (* let probe_result = probe ~__context ~host ~device_config ~_type ~sm_config in begin @@ -212,48 +212,48 @@ let create ~__context ~host ~device_config ~(physical_size:int64) ~name_label ~ | _ -> () end; *) - let sr_uuid = Uuid.make_uuid() in - let sr_uuid_str = Uuid.to_string sr_uuid in - (* Create the SR in the database before creating on disk, so the backends can read the sm_config field. If an error happens here - we have to clean up the record.*) - let sr_ref = - introduce ~__context ~uuid:sr_uuid_str ~name_label - ~name_description ~_type ~content_type ~shared ~sm_config - in - let pbds = - if shared then - let create_on_host host = - Xapi_pbd.create ~__context ~sR:sr_ref ~device_config ~host ~other_config:[] + let sr_uuid = Uuid.make_uuid() in + let sr_uuid_str = Uuid.to_string sr_uuid in + (* Create the SR in the database before creating on disk, so the backends can read the sm_config field. If an error happens here + we have to clean up the record.*) + let sr_ref = + introduce ~__context ~uuid:sr_uuid_str ~name_label + ~name_description ~_type ~content_type ~shared ~sm_config in - let master = Helpers.get_master ~__context in - let hosts = master :: (List.filter (fun x -> x <> master) (Db.Host.get_all ~__context)) in - List.map create_on_host hosts - else - [Xapi_pbd.create_thishost ~__context ~sR:sr_ref ~device_config ~currently_attached:false ] - in - let device_config = begin - try - Storage_access.create_sr ~__context ~sr:sr_ref ~name_label ~name_description ~physical_size - with e -> - Db.SR.destroy ~__context ~self:sr_ref; - List.iter (fun pbd -> Db.PBD.destroy ~__context ~self:pbd) pbds; - raise e - end in - Helpers.call_api_functions ~__context - (fun rpc session_id -> - List.iter - (fun self -> - try - Db.PBD.set_device_config ~__context ~self ~value:device_config; + let pbds = + if shared then + let create_on_host host = + Xapi_pbd.create ~__context ~sR:sr_ref ~device_config ~host ~other_config:[] + in + let master = Helpers.get_master ~__context in + let hosts = master :: (List.filter (fun x -> x <> master) (Db.Host.get_all ~__context)) in + List.map create_on_host hosts + else + [Xapi_pbd.create_thishost ~__context ~sR:sr_ref ~device_config ~currently_attached:false ] + in + let device_config = begin + try + Storage_access.create_sr ~__context ~sr:sr_ref ~name_label ~name_description ~physical_size + with e -> + Db.SR.destroy ~__context ~self:sr_ref; + List.iter (fun pbd -> Db.PBD.destroy ~__context ~self:pbd) pbds; + raise e + end in + Helpers.call_api_functions ~__context + (fun rpc session_id -> + List.iter + (fun self -> + try + Db.PBD.set_device_config ~__context ~self ~value:device_config; with e -> warn "Could not set PBD device-config '%s': %s" (Db.PBD.get_uuid ~__context ~self) (Printexc.to_string e)) pbds); pbds, sr_ref ) in Helpers.call_api_functions ~__context (fun rpc session_id -> - List.iter - (fun self -> - try + List.iter + (fun self -> + try Client.PBD.plug ~rpc ~session_id ~self with e -> warn "Could not plug PBD '%s': %s" (Db.PBD.get_uuid ~__context ~self) (Printexc.to_string e)) pbds); diff --git a/ocaml/xapi/xapi_usb_group.ml b/ocaml/xapi/xapi_usb_group.ml index 59db7d372ec..1ce847e2fe8 100644 --- a/ocaml/xapi/xapi_usb_group.ml +++ b/ocaml/xapi/xapi_usb_group.ml @@ -34,7 +34,7 @@ let destroy ~__context ~self = (* Destroy all vUSBs *) List.iter (fun vusb -> - Helpers.log_exn_continue (Printf.sprintf "destroying VUSB: %s" (Ref.string_of vusb)) - (fun vusb -> Db.VUSB.destroy ~__context ~self:vusb) vusb) vusbs; + Helpers.log_exn_continue (Printf.sprintf "destroying VUSB: %s" (Ref.string_of vusb)) + (fun vusb -> Db.VUSB.destroy ~__context ~self:vusb) vusb) vusbs; Db.USB_group.destroy ~__context ~self diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index d29685c56b0..588444b20a6 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -148,7 +148,7 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = (match gmr.Db_actions.vM_guest_metrics_can_use_hotplug_vbd with | `yes -> () (* Drivers have made an explicit claim of support. *) | `no -> set_errors Api_errors.operation_not_allowed ["VM states it does not support VBD hotplug."] plug_ops - (* according to xen docs PV drivers are enough for this to be possible *) + (* according to xen docs PV drivers are enough for this to be possible *) | `unspecified when gmr.Db_actions.vM_guest_metrics_PV_drivers_detected -> () | `unspecified -> fallback ()) ); diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index 11db636b1a0..eaf17dea688 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -27,22 +27,22 @@ open Printf let check_sm_feature_error (op:API.vdi_operations) sm_features sr = let required_sm_feature = Smint.(match op with - | `forget - | `copy - | `force_unlock - | `blocked - -> None - | `snapshot -> Some Vdi_snapshot - | `destroy -> Some Vdi_delete - | `resize -> Some Vdi_resize - | `update -> Some Vdi_update - | `resize_online -> Some Vdi_resize_online - | `generate_config -> Some Vdi_generate_config - | `clone -> Some Vdi_clone - | `mirror -> Some Vdi_mirror - | `enable_cbt | `disable_cbt | `data_destroy | `list_changed_blocks -> Some Vdi_configure_cbt - | `set_on_boot -> Some Vdi_reset_on_boot - ) in + | `forget + | `copy + | `force_unlock + | `blocked + -> None + | `snapshot -> Some Vdi_snapshot + | `destroy -> Some Vdi_delete + | `resize -> Some Vdi_resize + | `update -> Some Vdi_update + | `resize_online -> Some Vdi_resize_online + | `generate_config -> Some Vdi_generate_config + | `clone -> Some Vdi_clone + | `mirror -> Some Vdi_mirror + | `enable_cbt | `disable_cbt | `data_destroy | `list_changed_blocks -> Some Vdi_configure_cbt + | `set_on_boot -> Some Vdi_reset_on_boot + ) in match required_sm_feature with | None -> None | Some feature -> @@ -78,201 +78,201 @@ let check_operation_error ~__context ?(sr_records=[]) ?(pbd_records=[]) ?(vbd_re not (List.mem op Xapi_globs.rpu_allowed_vdi_operations) then Some (Api_errors.not_supported_during_upgrade, []) else - (* Don't fail with other_operation_in_progress if VDI mirroring is in progress - * and destroy is called as part of VDI mirroring *) - let is_vdi_mirroring_in_progress = (List.exists (fun (_, op) -> op = `mirror) current_ops) && (op = `destroy) in - if (List.exists (fun (_, op) -> op <> `copy) current_ops) && not is_vdi_mirroring_in_progress - then Some(Api_errors.other_operation_in_progress,["VDI"; _ref]) - else - (* check to see whether it's a local cd drive *) - let sr = record.Db_actions.vDI_SR in - let sr_type = Db.SR.get_type ~__context ~self:sr in - let is_tools_sr = Db.SR.get_is_tools_sr ~__context ~self:sr in - - (* Check to see if any PBDs are attached *) - let open Db_filter_types in - let pbds_attached = match pbd_records with - | [] -> Db.PBD.get_records_where ~__context ~expr:(And(Eq(Field "SR", Literal (Ref.string_of sr)), Eq(Field "currently_attached", Literal "true"))) - | _ -> List.filter (fun (_, pbd_record) -> (pbd_record.API.pBD_SR = sr) && pbd_record.API.pBD_currently_attached) pbd_records - in - if (List.length pbds_attached = 0) && List.mem op [`resize;] - then Some(Api_errors.sr_no_pbds, [Ref.string_of sr]) + (* Don't fail with other_operation_in_progress if VDI mirroring is in progress + * and destroy is called as part of VDI mirroring *) + let is_vdi_mirroring_in_progress = (List.exists (fun (_, op) -> op = `mirror) current_ops) && (op = `destroy) in + if (List.exists (fun (_, op) -> op <> `copy) current_ops) && not is_vdi_mirroring_in_progress + then Some(Api_errors.other_operation_in_progress,["VDI"; _ref]) else - (* check to see whether VBDs exist which are using this VDI *) - - (* Only a 'live' operation can be performed if there are active (even RO) devices *) - let my_active_vbd_records = match vbd_records with - | [] -> List.map snd (Db.VBD.get_internal_records_where ~__context - ~expr:( - And(Eq (Field "VDI", Literal _ref), - Or( - Eq (Field "currently_attached", Literal "true"), - Eq (Field "reserved", Literal "true"))) - )) - | _ -> List.map snd (List.filter (fun (_, vbd_record) -> - vbd_record.Db_actions.vBD_VDI = _ref' && (vbd_record.Db_actions.vBD_currently_attached || vbd_record.Db_actions.vBD_reserved) - ) vbd_records) - in - let my_active_rw_vbd_records = List.filter - (fun vbd -> vbd.Db_actions.vBD_mode = `RW) - my_active_vbd_records - in + (* check to see whether it's a local cd drive *) + let sr = record.Db_actions.vDI_SR in + let sr_type = Db.SR.get_type ~__context ~self:sr in + let is_tools_sr = Db.SR.get_is_tools_sr ~__context ~self:sr in - (* VBD operations (plug/unplug) (which should be transient) cause us to serialise *) - let my_has_current_operation_vbd_records = match vbd_records with - | [] -> List.map snd (Db.VBD.get_internal_records_where ~__context - ~expr:( - And(Eq (Field "VDI", Literal _ref), Not (Eq (Field "current_operations", Literal "()"))) - )) - | _ -> List.map snd (List.filter (fun (_, vbd_record) -> - vbd_record.Db_actions.vBD_VDI = _ref' && vbd_record.Db_actions.vBD_current_operations <> [] - ) vbd_records) - in - - (* If the VBD is currently_attached then some operations can still be performed ie: - VDI.clone (if the VM is suspended we have to have the 'allow_clone_suspended_vm'' flag) - VDI.snapshot; VDI.resize_online; 'blocked' (CP-831) - VDI.data_destroy: it is not allowed on VDIs linked to a VM, but the - implementation first waits for the VDI's VBDs to be unplugged and - destroyed, and the checks are performed there. - *) - let operation_can_be_performed_live = match op with - | `snapshot | `resize_online | `blocked | `clone | `mirror | `enable_cbt | `disable_cbt | `data_destroy -> true - | _ -> false in - - let operation_can_be_performed_with_ro_attach = - operation_can_be_performed_live || - (match op with - | `copy -> true - | _ -> false) + (* Check to see if any PBDs are attached *) + let open Db_filter_types in + let pbds_attached = match pbd_records with + | [] -> Db.PBD.get_records_where ~__context ~expr:(And(Eq(Field "SR", Literal (Ref.string_of sr)), Eq(Field "currently_attached", Literal "true"))) + | _ -> List.filter (fun (_, pbd_record) -> (pbd_record.API.pBD_SR = sr) && pbd_record.API.pBD_currently_attached) pbd_records in - - (* NB RO vs RW sharing checks are done in xapi_vbd.ml *) - - let blocked_by_attach = - let blocked_by_attach = - if operation_can_be_performed_live - then false - else begin - if operation_can_be_performed_with_ro_attach - then (my_active_rw_vbd_records <> []) - else (my_active_vbd_records <> []) - end + if (List.length pbds_attached = 0) && List.mem op [`resize;] + then Some(Api_errors.sr_no_pbds, [Ref.string_of sr]) + else + (* check to see whether VBDs exist which are using this VDI *) + + (* Only a 'live' operation can be performed if there are active (even RO) devices *) + let my_active_vbd_records = match vbd_records with + | [] -> List.map snd (Db.VBD.get_internal_records_where ~__context + ~expr:( + And(Eq (Field "VDI", Literal _ref), + Or( + Eq (Field "currently_attached", Literal "true"), + Eq (Field "reserved", Literal "true"))) + )) + | _ -> List.map snd (List.filter (fun (_, vbd_record) -> + vbd_record.Db_actions.vBD_VDI = _ref' && (vbd_record.Db_actions.vBD_currently_attached || vbd_record.Db_actions.vBD_reserved) + ) vbd_records) in - let allow_attached_vbds = - (* We use Valid_ref_list.list to ignore exceptions due to invalid references that - could propagate to the message forwarding layer, which calls this - function to check for errors - these exceptions would prevent the - actual XenAPI function from being run. Checks called from the - message forwarding layer should not fail with an exception. *) - let true_for_all_active_vbds f = Valid_ref_list.for_all f my_active_vbd_records in - match op with - | `list_changed_blocks -> - let vbd_connected_to_vm_snapshot vbd = - let vm = vbd.Db_actions.vBD_VM in - Db.is_valid_ref __context vm && (Db.VM.get_is_a_snapshot ~__context ~self:vm) - in - (* We allow list_changed_blocks on VDIs attached to snapshot VMs, - because VM.checkpoint may set the currently_attached fields of the - snapshot's VBDs to true, and this would block list_changed_blocks. *) - true_for_all_active_vbds vbd_connected_to_vm_snapshot - | _ -> false + let my_active_rw_vbd_records = List.filter + (fun vbd -> vbd.Db_actions.vBD_mode = `RW) + my_active_vbd_records in - blocked_by_attach && (not allow_attached_vbds) - in - if blocked_by_attach - then Some (Api_errors.vdi_in_use,[_ref; (Record_util.vdi_operation_to_string op)]) - else - (* data_destroy first waits for all the VBDs to disappear in its - implementation, so it is harmless to allow it when any of the VDI's - VBDs have operations in progress. This ensures that we avoid the retry - mechanism of message forwarding and only use the event loop. *) - if my_has_current_operation_vbd_records <> [] && op <> `data_destroy - then Some (Api_errors.other_operation_in_progress, [ "VDI"; _ref ]) - else + (* VBD operations (plug/unplug) (which should be transient) cause us to serialise *) + let my_has_current_operation_vbd_records = match vbd_records with + | [] -> List.map snd (Db.VBD.get_internal_records_where ~__context + ~expr:( + And(Eq (Field "VDI", Literal _ref), Not (Eq (Field "current_operations", Literal "()"))) + )) + | _ -> List.map snd (List.filter (fun (_, vbd_record) -> + vbd_record.Db_actions.vBD_VDI = _ref' && vbd_record.Db_actions.vBD_current_operations <> [] + ) vbd_records) + in - let sm_features = Xapi_sr_operations.features_of_sr_internal ~__context ~_type:sr_type in - let sm_feature_error = check_sm_feature_error op sm_features sr in - if sm_feature_error <> None - then sm_feature_error + (* If the VBD is currently_attached then some operations can still be performed ie: + VDI.clone (if the VM is suspended we have to have the 'allow_clone_suspended_vm'' flag) + VDI.snapshot; VDI.resize_online; 'blocked' (CP-831) + VDI.data_destroy: it is not allowed on VDIs linked to a VM, but the + implementation first waits for the VDI's VBDs to be unplugged and + destroyed, and the checks are performed there. + *) + let operation_can_be_performed_live = match op with + | `snapshot | `resize_online | `blocked | `clone | `mirror | `enable_cbt | `disable_cbt | `data_destroy -> true + | _ -> false in + + let operation_can_be_performed_with_ro_attach = + operation_can_be_performed_live || + (match op with + | `copy -> true + | _ -> false) + in - else - let allowed_for_cbt_metadata_vdi = match op with - | `clone | `copy | `disable_cbt | `enable_cbt | `mirror | `resize | `resize_online | `snapshot | `set_on_boot -> false - | `blocked | `data_destroy | `destroy | `list_changed_blocks | `force_unlock | `forget | `generate_config | `update -> true in - if not allowed_for_cbt_metadata_vdi && record.Db_actions.vDI_type = `cbt_metadata - then Some (Api_errors.vdi_incompatible_type, [ _ref; Record_util.vdi_type_to_string `cbt_metadata ]) - else - let allowed_when_cbt_enabled = match op with - | `mirror | `set_on_boot -> false - | `blocked | `clone | `copy | `data_destroy | `destroy | `disable_cbt | `enable_cbt | `list_changed_blocks | `force_unlock | `forget | `generate_config | `resize | `resize_online | `snapshot | `update -> true in - if not allowed_when_cbt_enabled && record.Db_actions.vDI_cbt_enabled - then Some (Api_errors.vdi_cbt_enabled, [_ref]) - else + (* NB RO vs RW sharing checks are done in xapi_vbd.ml *) - let check_destroy () = - if sr_type = "udev" - then Some (Api_errors.vdi_is_a_physical_device, [_ref]) + let blocked_by_attach = + let blocked_by_attach = + if operation_can_be_performed_live + then false + else begin + if operation_can_be_performed_with_ro_attach + then (my_active_rw_vbd_records <> []) + else (my_active_vbd_records <> []) + end + in + let allow_attached_vbds = + (* We use Valid_ref_list.list to ignore exceptions due to invalid references that + could propagate to the message forwarding layer, which calls this + function to check for errors - these exceptions would prevent the + actual XenAPI function from being run. Checks called from the + message forwarding layer should not fail with an exception. *) + let true_for_all_active_vbds f = Valid_ref_list.for_all f my_active_vbd_records in + match op with + | `list_changed_blocks -> + let vbd_connected_to_vm_snapshot vbd = + let vm = vbd.Db_actions.vBD_VM in + Db.is_valid_ref __context vm && (Db.VM.get_is_a_snapshot ~__context ~self:vm) + in + (* We allow list_changed_blocks on VDIs attached to snapshot VMs, + because VM.checkpoint may set the currently_attached fields of the + snapshot's VBDs to true, and this would block list_changed_blocks. *) + true_for_all_active_vbds vbd_connected_to_vm_snapshot + | _ -> false + in + blocked_by_attach && (not allow_attached_vbds) + in + if blocked_by_attach + then Some (Api_errors.vdi_in_use,[_ref; (Record_util.vdi_operation_to_string op)]) else - if is_tools_sr - then Some (Api_errors.sr_operation_not_supported, [Ref.string_of sr]) - else if List.mem record.Db_actions.vDI_type [ `rrd ] - then Some (Api_errors.vdi_has_rrds, [_ref]) + + (* data_destroy first waits for all the VBDs to disappear in its + implementation, so it is harmless to allow it when any of the VDI's + VBDs have operations in progress. This ensures that we avoid the retry + mechanism of message forwarding and only use the event loop. *) + if my_has_current_operation_vbd_records <> [] && op <> `data_destroy + then Some (Api_errors.other_operation_in_progress, [ "VDI"; _ref ]) else - if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] - then Some (Api_errors.ha_is_enabled, []) - else if List.mem record.Db_actions.vDI_type [`ha_statefile; `metadata ] && Xapi_pool_helpers.ha_enable_in_progress ~__context - then Some (Api_errors.ha_enable_in_progress, []) - else if List.mem record.Db_actions.vDI_type [`ha_statefile; `metadata ] && Xapi_pool_helpers.ha_disable_in_progress ~__context - then Some (Api_errors.ha_disable_in_progress, []) - else None - in - begin match op with - | `forget -> - if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] - then Some (Api_errors.ha_is_enabled, []) - else if List.mem record.Db_actions.vDI_type [ `rrd ] - then Some (Api_errors.vdi_has_rrds, [_ref]) - else None - | `destroy -> check_destroy () - | `data_destroy -> - if not record.Db_actions.vDI_is_a_snapshot - then Some (Api_errors.operation_not_allowed, ["VDI is not a snapshot: " ^ _ref]) - else if not record.Db_actions.vDI_cbt_enabled - then Some (Api_errors.vdi_no_cbt_metadata, [_ref]) - else check_destroy () - | `resize -> - if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] - then Some (Api_errors.ha_is_enabled, []) - else None - | `resize_online -> - if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] - then Some (Api_errors.ha_is_enabled, []) - else None - | `snapshot when record.Db_actions.vDI_sharable -> - Some (Api_errors.vdi_is_sharable, [ _ref ]) - | `snapshot when reset_on_boot -> - Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) - | `snapshot -> - if List.exists (fun (_, op) -> op = `copy) current_ops - then Some (Api_errors.operation_not_allowed, ["Snapshot operation not allowed during copy."]) - else None - | `copy -> - if List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] - then Some (Api_errors.operation_not_allowed, ["VDI containing HA statefile or redo log cannot be copied (check the VDI's allowed operations)."]) - else None - | (`enable_cbt | `disable_cbt) -> - if record.Db_actions.vDI_is_a_snapshot - then Some (Api_errors.operation_not_allowed, ["VDI is a snapshot: " ^ _ref]) - else if not (List.mem record.Db_actions.vDI_type [ `user; `system ]) - then Some (Api_errors.vdi_incompatible_type, [ _ref; Record_util.vdi_type_to_string record.Db_actions.vDI_type ]) - else if reset_on_boot - then Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) - else None - | `mirror | `clone | `generate_config | `force_unlock | `set_on_boot | `list_changed_blocks | `blocked | `update -> None - end + let sm_features = Xapi_sr_operations.features_of_sr_internal ~__context ~_type:sr_type in + let sm_feature_error = check_sm_feature_error op sm_features sr in + if sm_feature_error <> None + then sm_feature_error + + else + let allowed_for_cbt_metadata_vdi = match op with + | `clone | `copy | `disable_cbt | `enable_cbt | `mirror | `resize | `resize_online | `snapshot | `set_on_boot -> false + | `blocked | `data_destroy | `destroy | `list_changed_blocks | `force_unlock | `forget | `generate_config | `update -> true in + if not allowed_for_cbt_metadata_vdi && record.Db_actions.vDI_type = `cbt_metadata + then Some (Api_errors.vdi_incompatible_type, [ _ref; Record_util.vdi_type_to_string `cbt_metadata ]) + else + let allowed_when_cbt_enabled = match op with + | `mirror | `set_on_boot -> false + | `blocked | `clone | `copy | `data_destroy | `destroy | `disable_cbt | `enable_cbt | `list_changed_blocks | `force_unlock | `forget | `generate_config | `resize | `resize_online | `snapshot | `update -> true in + if not allowed_when_cbt_enabled && record.Db_actions.vDI_cbt_enabled + then Some (Api_errors.vdi_cbt_enabled, [_ref]) + else + + let check_destroy () = + if sr_type = "udev" + then Some (Api_errors.vdi_is_a_physical_device, [_ref]) + else + if is_tools_sr + then Some (Api_errors.sr_operation_not_supported, [Ref.string_of sr]) + else if List.mem record.Db_actions.vDI_type [ `rrd ] + then Some (Api_errors.vdi_has_rrds, [_ref]) + else + if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] + then Some (Api_errors.ha_is_enabled, []) + else if List.mem record.Db_actions.vDI_type [`ha_statefile; `metadata ] && Xapi_pool_helpers.ha_enable_in_progress ~__context + then Some (Api_errors.ha_enable_in_progress, []) + else if List.mem record.Db_actions.vDI_type [`ha_statefile; `metadata ] && Xapi_pool_helpers.ha_disable_in_progress ~__context + then Some (Api_errors.ha_disable_in_progress, []) + else None + in + + begin match op with + | `forget -> + if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] + then Some (Api_errors.ha_is_enabled, []) + else if List.mem record.Db_actions.vDI_type [ `rrd ] + then Some (Api_errors.vdi_has_rrds, [_ref]) + else None + | `destroy -> check_destroy () + | `data_destroy -> + if not record.Db_actions.vDI_is_a_snapshot + then Some (Api_errors.operation_not_allowed, ["VDI is not a snapshot: " ^ _ref]) + else if not record.Db_actions.vDI_cbt_enabled + then Some (Api_errors.vdi_no_cbt_metadata, [_ref]) + else check_destroy () + | `resize -> + if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] + then Some (Api_errors.ha_is_enabled, []) + else None + | `resize_online -> + if ha_enabled && List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] + then Some (Api_errors.ha_is_enabled, []) + else None + | `snapshot when record.Db_actions.vDI_sharable -> + Some (Api_errors.vdi_is_sharable, [ _ref ]) + | `snapshot when reset_on_boot -> + Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) + | `snapshot -> + if List.exists (fun (_, op) -> op = `copy) current_ops + then Some (Api_errors.operation_not_allowed, ["Snapshot operation not allowed during copy."]) + else None + | `copy -> + if List.mem record.Db_actions.vDI_type [ `ha_statefile; `redo_log ] + then Some (Api_errors.operation_not_allowed, ["VDI containing HA statefile or redo log cannot be copied (check the VDI's allowed operations)."]) + else None + | (`enable_cbt | `disable_cbt) -> + if record.Db_actions.vDI_is_a_snapshot + then Some (Api_errors.operation_not_allowed, ["VDI is a snapshot: " ^ _ref]) + else if not (List.mem record.Db_actions.vDI_type [ `user; `system ]) + then Some (Api_errors.vdi_incompatible_type, [ _ref; Record_util.vdi_type_to_string record.Db_actions.vDI_type ]) + else if reset_on_boot + then Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation, []) + else None + | `mirror | `clone | `generate_config | `force_unlock | `set_on_boot | `list_changed_blocks | `blocked | `update -> None + end let assert_operation_valid ~__context ~self ~(op:API.vdi_operations) = let pool = Helpers.get_pool ~__context in @@ -298,12 +298,12 @@ let update_allowed_operations_internal ~__context ~self ~sr_records ~pbd_records * If/when we do this, we can update test_vdi_allowed_operations.ml to * re-enable (and maybe alter) the relevant part of * test_update_allowed_operations. - *) + *) let all_ops = Listext.List.set_difference - (* Older XenServers choke on ops they don't recognise during SXM, so - * until we have a better solution we consider only old ones: CA-260245 *) - Xapi_globs.pre_ely_vdi_operations - [`blocked] + (* Older XenServers choke on ops they don't recognise during SXM, so + * until we have a better solution we consider only old ones: CA-260245 *) + Xapi_globs.pre_ely_vdi_operations + [`blocked] in let all = Db.VDI.get_record_internal ~__context ~self in let allowed = @@ -658,10 +658,10 @@ let destroy_and_data_destroy_common ~__context ~self ~(operation:[ `destroy | `d Xapi_vdi_helpers.assert_managed ~__context ~vdi:self; begin match operation with - | `data_destroy timeout -> - (* If this VDI has any VBDs, first wait for them to disappear. *) - wait_for_vbds_to_be_unplugged_and_destroyed ~__context ~self ~timeout - | `destroy -> () + | `data_destroy timeout -> + (* If this VDI has any VBDs, first wait for them to disappear. *) + wait_for_vbds_to_be_unplugged_and_destroyed ~__context ~self ~timeout + | `destroy -> () end; let vbds = Db.VDI.get_VBDs ~__context ~self in @@ -1032,11 +1032,11 @@ let _get_nbd_info ~__context ~self ~get_server_certificate = in let nbd_networks = Db.Network.get_all ~__context |> - Valid_ref_list.filter (fun nwk -> - (* Despite the singular name, Db.get_purpose returns a list. *) - Db.Network.get_purpose ~__context ~self:nwk |> - List.exists (fun p -> p=`nbd || p=`insecure_nbd) - ) in + Valid_ref_list.filter (fun nwk -> + (* Despite the singular name, Db.get_purpose returns a list. *) + Db.Network.get_purpose ~__context ~self:nwk |> + List.exists (fun p -> p=`nbd || p=`insecure_nbd) + ) in let get_ips host = let get_ips pif = @@ -1052,7 +1052,7 @@ let _get_nbd_info ~__context ~self ~get_server_certificate = Eq (Field "currently_attached", Literal "true"))) in let attached_nbd_pifs = attached_pifs |> - List.filter (fun pif -> List.mem (Db.PIF.get_network ~__context ~self:pif) nbd_networks) in + List.filter (fun pif -> List.mem (Db.PIF.get_network ~__context ~self:pif) nbd_networks) in attached_nbd_pifs |> Valid_ref_list.flat_map get_ips in @@ -1061,42 +1061,42 @@ let _get_nbd_info ~__context ~self ~get_server_certificate = let exportname = Printf.sprintf "/%s?session_id=%s" vdi_uuid session_id in hosts_with_attached_pbds |> Valid_ref_list.flat_map (fun host -> - let ips = get_ips host in - (* Check if empty: avoid inter-host calls and other work if so. *) - if ips = [] then [] else - let cert = get_server_certificate ~host in - let port = 10809L in - let rec seek = function - | [] -> ( - error "Found no subject DNS names in this hosts's certificate. Returning empty string as subject."; - "" - ) - | last :: [] -> last (* Better to return a possible wildcard than nothing *) - | name :: xs -> if (String.contains name '*') then seek xs else name - in - let subject = try - seek (Certificates.hostnames_of_pem_cert cert) - with e -> ( - error "get_nbd_info: failed to read subject from TLS certificate! Falling back to Host.hostname. Exn was %s" (ExnHelper.string_of_exn e); - Db.Host.get_hostname ~__context ~self:host + let ips = get_ips host in + (* Check if empty: avoid inter-host calls and other work if so. *) + if ips = [] then [] else + let cert = get_server_certificate ~host in + let port = 10809L in + let rec seek = function + | [] -> ( + error "Found no subject DNS names in this hosts's certificate. Returning empty string as subject."; + "" + ) + | last :: [] -> last (* Better to return a possible wildcard than nothing *) + | name :: xs -> if (String.contains name '*') then seek xs else name + in + let subject = try + seek (Certificates.hostnames_of_pem_cert cert) + with e -> ( + error "get_nbd_info: failed to read subject from TLS certificate! Falling back to Host.hostname. Exn was %s" (ExnHelper.string_of_exn e); + Db.Host.get_hostname ~__context ~self:host + ) + in + let template = API.{ + vdi_nbd_server_info_exportname = exportname; + vdi_nbd_server_info_address = ""; + vdi_nbd_server_info_port = port; + vdi_nbd_server_info_cert = cert; + vdi_nbd_server_info_subject = subject; + } in + ips |> List.map + (fun addr -> API.{template with vdi_nbd_server_info_address = addr}) ) - in - let template = API.{ - vdi_nbd_server_info_exportname = exportname; - vdi_nbd_server_info_address = ""; - vdi_nbd_server_info_port = port; - vdi_nbd_server_info_cert = cert; - vdi_nbd_server_info_subject = subject; - } in - ips |> List.map - (fun addr -> API.{template with vdi_nbd_server_info_address = addr}) - ) let get_nbd_info ~__context ~self = - let get_server_certificate ~host = Helpers.call_api_functions - ~__context - (fun rpc session_id -> Client.Host.get_server_certificate ~rpc ~session_id ~host) - in - _get_nbd_info ~__context ~self ~get_server_certificate + let get_server_certificate ~host = Helpers.call_api_functions + ~__context + (fun rpc session_id -> Client.Host.get_server_certificate ~rpc ~session_id ~host) + in + _get_nbd_info ~__context ~self ~get_server_certificate (* let pool_migrate = "See Xapi_vm_migrate.vdi_pool_migrate!" *) diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 02cf8edacb0..4359b2b7296 100644 --- a/ocaml/xapi/xapi_vdi_helpers.ml +++ b/ocaml/xapi/xapi_vdi_helpers.ml @@ -194,40 +194,40 @@ module VDI_CStruct = struct (* Set the magic number *) let set_magic_number cstruct = - Cstruct.BE.set_uint32 cstruct magic_number_offset magic_number + Cstruct.BE.set_uint32 cstruct magic_number_offset magic_number (* Get the magic number *) let get_magic_number cstruct = - Cstruct.BE.get_uint32 cstruct magic_number_offset + Cstruct.BE.get_uint32 cstruct magic_number_offset (* Set the version *) let set_version cstruct = - Cstruct.BE.set_uint32 cstruct version_offset version + Cstruct.BE.set_uint32 cstruct version_offset version (* Set the data length *) let set_data_length cstruct len = - Cstruct.BE.set_uint32 cstruct length_offset len + Cstruct.BE.set_uint32 cstruct length_offset len (* Get the data length *) let get_data_length cstruct = - Cstruct.BE.get_uint32 cstruct length_offset + Cstruct.BE.get_uint32 cstruct length_offset (* Write the string to the cstruct *) let write cstruct text text_len = - Cstruct.blit_from_string text default_offset cstruct data_offset text_len; - set_data_length cstruct (Int32.of_int text_len) + Cstruct.blit_from_string text default_offset cstruct data_offset text_len; + set_data_length cstruct (Int32.of_int text_len) (* Read the string from the cstruct *) let read cstruct = - let curr_len = Int32.to_int (get_data_length cstruct) in - let curr_text = String.make curr_len '\000' in - Cstruct.blit_to_string cstruct data_offset curr_text default_offset curr_len; - curr_text + let curr_len = Int32.to_int (get_data_length cstruct) in + let curr_text = String.make curr_len '\000' in + Cstruct.blit_to_string cstruct data_offset curr_text default_offset curr_len; + curr_text (* Format the cstruct for the first time *) let format cstruct = - set_magic_number cstruct; - set_version cstruct + set_magic_number cstruct; +set_version cstruct end @@ -242,14 +242,14 @@ let write_raw ~__context ~vdi ~text = (fun fd -> let contents = Unixext.really_read_string fd VDI_CStruct.vdi_size in let cstruct = Cstruct.of_string contents in - if (VDI_CStruct.get_magic_number cstruct) <> VDI_CStruct.magic_number then - VDI_CStruct.format cstruct; - VDI_CStruct.write cstruct text (String.length text); - Unix.ftruncate fd 0; - Unixext.seek_to fd 0 |> ignore; - Unixext.really_write_string fd (VDI_CStruct.read cstruct); - ) - ) +if (VDI_CStruct.get_magic_number cstruct) <> VDI_CStruct.magic_number then + VDI_CStruct.format cstruct; +VDI_CStruct.write cstruct text (String.length text); + Unix.ftruncate fd 0; + Unixext.seek_to fd 0 |> ignore; + Unixext.really_write_string fd (VDI_CStruct.read cstruct); +) +) let read_raw ~__context ~vdi = Helpers.call_api_functions ~__context @@ -257,11 +257,11 @@ let read_raw ~__context ~vdi = (fun fd -> let contents = Unixext.really_read_string fd VDI_CStruct.vdi_size in let cstruct = Cstruct.of_string contents in - if (VDI_CStruct.get_magic_number cstruct) <> VDI_CStruct.magic_number then begin - debug "Attempted read from raw VDI but VDI not formatted: returning None"; - None - end - else - Some (VDI_CStruct.read cstruct) - ) - ) +if (VDI_CStruct.get_magic_number cstruct) <> VDI_CStruct.magic_number then begin + debug "Attempted read from raw VDI but VDI not formatted: returning None"; + None +end +else + Some (VDI_CStruct.read cstruct) +) +) diff --git a/ocaml/xapi/xapi_vgpu.ml b/ocaml/xapi/xapi_vgpu.ml index ad1b2dbf237..e88aad149b9 100644 --- a/ocaml/xapi/xapi_vgpu.ml +++ b/ocaml/xapi/xapi_vgpu.ml @@ -54,14 +54,14 @@ let create' ~__context ~vM ~gPU_group ~device ~other_config ~_type ~powerstate_ ~currently_attached:false ~other_config ~_type ~resident_on:Ref.null ~scheduled_to_be_resident_on:Ref.null ~compatibility_metadata:[] - ; + ; ); debug "VGPU ref='%s' created (VM = '%s', type = '%s')" (Ref.string_of vgpu) (Ref.string_of vM) (Ref.string_of _type); vgpu (* create is defined by the autogenerated code, so we keep the same signature for it but add a new function create' that will accept extra parameters indicating the desired behaviour - *) +*) let create = create' ~powerstate_check:true let destroy ~__context ~self = diff --git a/ocaml/xapi/xapi_vgpu_type.ml b/ocaml/xapi/xapi_vgpu_type.ml index 94f0cc5f4c5..827f030aa76 100644 --- a/ocaml/xapi/xapi_vgpu_type.ml +++ b/ocaml/xapi/xapi_vgpu_type.ml @@ -394,9 +394,9 @@ module Nvidia_old = struct (* The last two arguments of the following function are unused, and only * present to match the function signature *) let find_or_create_supported_types ~__context ~pci - ~is_system_display_device - ~is_host_display_enabled - ~is_pci_hidden = + ~is_system_display_device + ~is_host_display_enabled + ~is_pci_hidden = if is_system_display_device then [] else begin @@ -461,9 +461,9 @@ module Vendor = functor (V : VENDOR) -> struct (get_devices access) in vendor_name, device - in - List.filter_map (V.vgpu_type_of_conf access vendor_name device) whitelist - )) + in + List.filter_map (V.vgpu_type_of_conf access vendor_name device) whitelist + )) let find_or_create_supported_types ~__context ~pci ~is_system_display_device @@ -556,21 +556,21 @@ module Vendor_nvidia = struct maxVgpus value and the pgpu's subsystemId. *) List.filter_map (fun pgpu -> - let devid = find_one_by_name "devId" pgpu in - if int_of_string (get_attr "deviceId" devid) = device_id then - let psubdev_id = - let id = int_of_string (get_attr "subsystemId" devid) in - if id = 0 then None else Some id - in - let vgpus = find_by_name "supportedVgpu" pgpu in - Some (List.map (fun vgpu -> - let id = get_attr "vgpuId" vgpu in - let max = Int64.of_string (get_data (find_one_by_name "maxVgpus" vgpu)) in - id, (max, psubdev_id) - ) vgpus) - else - None - ) pgpus |> List.concat + let devid = find_one_by_name "devId" pgpu in + if int_of_string (get_attr "deviceId" devid) = device_id then + let psubdev_id = + let id = int_of_string (get_attr "subsystemId" devid) in + if id = 0 then None else Some id + in + let vgpus = find_by_name "supportedVgpu" pgpu in + Some (List.map (fun vgpu -> + let id = get_attr "vgpuId" vgpu in + let max = Int64.of_string (get_data (find_one_by_name "maxVgpus" vgpu)) in + id, (max, psubdev_id) + ) vgpus) + else + None + ) pgpus |> List.concat let extract_conf whitelist device_id vgpu_types vgpu_ids = (* @@ -587,40 +587,40 @@ module Vendor_nvidia = struct and construct vgpu_conf records. *) List.filter_map (fun vgpu_type -> - let id = get_attr "id" vgpu_type in - if List.mem_assoc id vgpu_ids then - let max_instance, psubdev_id = List.assoc id vgpu_ids in - let framebufferlength = Int64.of_string (get_data (find_one_by_name "framebuffer" vgpu_type)) in - let num_heads = Int64.of_string (get_data (find_one_by_name "numHeads" vgpu_type)) in - let max_x, max_y = - let display = find_one_by_name "display" vgpu_type in - Int64.of_string (get_attr "width" display), - Int64.of_string (get_attr "height" display) - in - let devid = find_one_by_name "devId" vgpu_type in - let identifier = Identifier.{ - pdev_id = device_id; - psubdev_id; - vdev_id = int_of_string (get_attr "deviceId" devid); - vsubdev_id = int_of_string (get_attr "subsystemId" devid); - } in - let file_path = whitelist in - Some {identifier; framebufferlength; - num_heads; max_instance; max_x; max_y; file_path} - else - None - ) vgpu_types + let id = get_attr "id" vgpu_type in + if List.mem_assoc id vgpu_ids then + let max_instance, psubdev_id = List.assoc id vgpu_ids in + let framebufferlength = Int64.of_string (get_data (find_one_by_name "framebuffer" vgpu_type)) in + let num_heads = Int64.of_string (get_data (find_one_by_name "numHeads" vgpu_type)) in + let max_x, max_y = + let display = find_one_by_name "display" vgpu_type in + Int64.of_string (get_attr "width" display), + Int64.of_string (get_attr "height" display) + in + let devid = find_one_by_name "devId" vgpu_type in + let identifier = Identifier.{ + pdev_id = device_id; + psubdev_id; + vdev_id = int_of_string (get_attr "deviceId" devid); + vsubdev_id = int_of_string (get_attr "subsystemId" devid); + } in + let file_path = whitelist in + Some {identifier; framebufferlength; + num_heads; max_instance; max_x; max_y; file_path} + else + None + ) vgpu_types let read_whitelist ~whitelist ~device_id = try let ch = open_in whitelist in let t = finally (fun () -> - let i = Xmlm.make_input ~strip:true (`Channel ch) in - let _, t = Xmlm.input_doc_tree ~el ~data i in - t - ) - (fun () -> close_in ch) + let i = Xmlm.make_input ~strip:true (`Channel ch) in + let _, t = Xmlm.input_doc_tree ~el ~data i in + t + ) + (fun () -> close_in ch) in let pgpus = find_by_name "pgpu" t in let vgpu_types = find_by_name "vgpuType" t in @@ -747,9 +747,9 @@ module Vendor_intel = struct ; vgt_fence_sz, Int64.to_string conf.identifier.fence_sz ] ; match conf.identifier.monitor_config_file with - | Some monitor_config_file -> - [vgt_monitor_config_file, monitor_config_file] - | None -> [] + | Some monitor_config_file -> + [vgt_monitor_config_file, monitor_config_file] + | None -> [] ] in Some { diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 7c7a689a33b..ac0cc53c7f2 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -98,7 +98,7 @@ let valid_operations ~__context record _ref' : table = match gmr.Db_actions.vM_guest_metrics_can_use_hotplug_vif with | `yes -> () (* Drivers have made an explicit claim of support. *) | `no -> set_errors Api_errors.operation_not_allowed ["VM states it does not support VIF hotplug."] [`plug; `unplug] - (* according to xen docs PV drivers are enough for this to be possible *) + (* according to xen docs PV drivers are enough for this to be possible *) | `unspecified when gmr.Db_actions.vM_guest_metrics_PV_drivers_detected -> () | `unspecified -> fallback ()) ); diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index f9b348f5db7..5da8216f074 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1009,8 +1009,8 @@ let set_bios_strings ~__context ~self ~value = Xapi_vm_helpers.assert_valid_bios_strings ~__context ~value; let bios_strings = List.map (fun (k, v) -> - if List.mem_assoc k value then (k, (List.assoc k value)) else (k, v) - ) Xapi_globs.generic_bios_strings + if List.mem_assoc k value then (k, (List.assoc k value)) else (k, v) + ) Xapi_globs.generic_bios_strings in Db.VM.set_bios_strings ~__context ~self ~value:bios_strings @@ -1020,27 +1020,27 @@ let set_protection_policy ~__context ~self ~value = raise (Api_errors.Server_error (Api_errors.message_removed, [])) let set_snapshot_schedule ~__context ~self ~value = - Pool_features.assert_enabled ~__context ~f:Features.VMSS; - (* Validate the VMSS Ref *) - let is_vmss_valid_ref = Db.is_valid_ref __context value in - if not (is_vmss_valid_ref || (value = Ref.null) || (Ref.string_of value = "")) then - raise (Api_errors.Server_error(Api_errors.invalid_value, [Ref.string_of value])); - if (value <> Ref.null && is_vmss_valid_ref) then begin - if Db.VM.get_is_control_domain ~__context ~self then - (* do not assign vmss to the dom0 vm of any host in the pool *) - raise (Api_errors.Server_error(Api_errors.invalid_value, [Ref.string_of value])); - if Db.VM.get_is_a_template ~__context ~self then - (* Do not assign templates to a VMSS. *) - raise (Api_errors.Server_error(Api_errors.vm_is_template, [Ref.string_of self])); - (* For snapshot_type=snapshot_with_quiesce, Check VM supports the snapshot_with_quiesce *) - let snapshot_type = Db.VMSS.get_type ~__context ~self:value in - if snapshot_type = `snapshot_with_quiesce then begin - Pool_features.assert_enabled ~__context ~f:Features.VSS; - Xapi_vm_helpers.assert_vm_supports_quiesce_snapshot ~__context ~self - end - end; - Db.VM.set_snapshot_schedule ~__context ~self ~value; - update_allowed_operations ~__context ~self + Pool_features.assert_enabled ~__context ~f:Features.VMSS; + (* Validate the VMSS Ref *) + let is_vmss_valid_ref = Db.is_valid_ref __context value in + if not (is_vmss_valid_ref || (value = Ref.null) || (Ref.string_of value = "")) then + raise (Api_errors.Server_error(Api_errors.invalid_value, [Ref.string_of value])); + if (value <> Ref.null && is_vmss_valid_ref) then begin + if Db.VM.get_is_control_domain ~__context ~self then + (* do not assign vmss to the dom0 vm of any host in the pool *) + raise (Api_errors.Server_error(Api_errors.invalid_value, [Ref.string_of value])); + if Db.VM.get_is_a_template ~__context ~self then + (* Do not assign templates to a VMSS. *) + raise (Api_errors.Server_error(Api_errors.vm_is_template, [Ref.string_of self])); + (* For snapshot_type=snapshot_with_quiesce, Check VM supports the snapshot_with_quiesce *) + let snapshot_type = Db.VMSS.get_type ~__context ~self:value in + if snapshot_type = `snapshot_with_quiesce then begin + Pool_features.assert_enabled ~__context ~f:Features.VSS; + Xapi_vm_helpers.assert_vm_supports_quiesce_snapshot ~__context ~self + end + end; + Db.VM.set_snapshot_schedule ~__context ~self ~value; + update_allowed_operations ~__context ~self let set_start_delay ~__context ~self ~value = if value < 0L then invalid_value diff --git a/ocaml/xapi/xapi_vm_clone.ml b/ocaml/xapi/xapi_vm_clone.ml index a1ed87655f4..d53e4864536 100644 --- a/ocaml/xapi/xapi_vm_clone.ml +++ b/ocaml/xapi/xapi_vm_clone.ml @@ -248,7 +248,7 @@ let copy_vm_record ?(snapshot_info_record) ~__context ~vm ~disk_op ~new_name ~ne (* verify if this action is happening due to a VM Schedule Snapshot *) let is_vmss_snapshot = - is_a_snapshot && (Xapi_vmss.is_vmss_snapshot ~__context) in + is_a_snapshot && (Xapi_vmss.is_vmss_snapshot ~__context) in let platform = all.Db_actions.vM_platform diff --git a/ocaml/xapi/xapi_vm_helpers.ml b/ocaml/xapi/xapi_vm_helpers.ml index 06f17020b33..1106e724303 100644 --- a/ocaml/xapi/xapi_vm_helpers.ml +++ b/ocaml/xapi/xapi_vm_helpers.ml @@ -238,17 +238,17 @@ let validate_basic_parameters ~__context ~self ~snapshot:x = let assert_vm_supports_quiesce_snapshot ~__context ~self = let vmr = Db.VM.get_record_internal ~__context ~self in if List.exists ( fun vbd -> - try - let vdi = Db.VBD.get_VDI ~__context ~self:vbd in - let sm_config = Db.VDI.get_sm_config ~__context ~self:vdi in - Xapi_vm_lifecycle.assoc_opt "on_boot" sm_config = Some "reset" - with _ -> false - ) vmr.Db_actions.vM_VBDs then + try + let vdi = Db.VBD.get_VDI ~__context ~self:vbd in + let sm_config = Db.VDI.get_sm_config ~__context ~self:vdi in + Xapi_vm_lifecycle.assoc_opt "on_boot" sm_config = Some "reset" + with _ -> false + ) vmr.Db_actions.vM_VBDs then raise (Api_errors.Server_error(Api_errors.vdi_on_boot_mode_incompatible_with_operation, [ ])); let vmgmr = Xapi_vm_lifecycle.maybe_get_guest_metrics ~__context ~ref:(vmr.Db_actions.vM_guest_metrics) in if not ((Xapi_vm_lifecycle.has_feature ~vmgmr ~feature:"feature-snapshot") || - (Xapi_vm_lifecycle.has_feature ~vmgmr ~feature:"feature-quiesce")) then + (Xapi_vm_lifecycle.has_feature ~vmgmr ~feature:"feature-quiesce")) then raise (Api_errors.Server_error(Api_errors.vm_snapshot_with_quiesce_not_supported, [ Ref.string_of self ])) let assert_hardware_platform_support ~__context ~vm ~host = @@ -397,16 +397,16 @@ let assert_gpus_available ~__context ~self ~host = let assert_usbs_available ~__context ~self ~host = Db.VM.get_VUSBs ~__context ~self |> List.iter (fun vusb -> - try - let usb_group = Db.VUSB.get_USB_group ~__context ~self:vusb in - let pusb = List.hd (Db.USB_group.get_PUSBs ~__context ~self:usb_group) in - let usb_host = Db.PUSB.get_host ~__context ~self:pusb in - assert (usb_host = host) - with _ -> raise (Api_errors.Server_error (Api_errors.operation_not_allowed, - [Printf.sprintf "VUSB %s is not available on Host %s" - (Ref.string_of vusb) - (Ref.string_of host) - ])) + try + let usb_group = Db.VUSB.get_USB_group ~__context ~self:vusb in + let pusb = List.hd (Db.USB_group.get_PUSBs ~__context ~self:usb_group) in + let usb_host = Db.PUSB.get_host ~__context ~self:pusb in + assert (usb_host = host) + with _ -> raise (Api_errors.Server_error (Api_errors.operation_not_allowed, + [Printf.sprintf "VUSB %s is not available on Host %s" + (Ref.string_of vusb) + (Ref.string_of host) + ])) ) let assert_host_supports_hvm ~__context ~self ~host = @@ -446,9 +446,9 @@ let assert_enough_memory_available ~__context ~self ~host ~snapshot = let assert_matches_control_domain_affinity ~__context ~self ~host = if Db.VM.get_is_control_domain ~__context ~self then match Db.VM.get_affinity ~__context ~self with - | x when x = Ref.null || x = host -> () - | _ -> raise (Api_errors.Server_error (Api_errors.operation_not_allowed, - ["Cannot boot a control domain on a host different from its affinity"])) + | x when x = Ref.null || x = host -> () + | _ -> raise (Api_errors.Server_error (Api_errors.operation_not_allowed, + ["Cannot boot a control domain on a host different from its affinity"])) (** Checks to see if a VM can boot on a particular host, throws an error if not. * Criteria: @@ -490,9 +490,9 @@ let assert_can_boot_here ~__context ~self ~host ~snapshot ?(do_sr_check=true) ?( assert_gpus_available ~__context ~self ~host; assert_usbs_available ~__context ~self ~host; begin match Helpers.domain_type ~__context ~self with - | `hvm | `pv_in_pvh -> - assert_host_supports_hvm ~__context ~self ~host - | `pv -> () + | `hvm | `pv_in_pvh -> + assert_host_supports_hvm ~__context ~self ~host + | `pv -> () end; if do_memory_check then assert_enough_memory_available ~__context ~self ~host ~snapshot; @@ -614,8 +614,8 @@ let vm_can_run_on_host ~__context ~vm ~snapshot ~do_memory_check host = try let _ = List.find (fun s -> snd s = `evacuate) (Db.Host.get_current_operations ~__context ~self:host) in false with _ -> true in try host_has_proper_version () - && (is_control_domain || host_enabled ()) (*CA-233580: allow control domains to start on a disabled host*) - && host_live () && host_can_run_vm () && host_evacuate_in_progress + && (is_control_domain || host_enabled ()) (*CA-233580: allow control domains to start on a disabled host*) + && host_live () && host_can_run_vm () && host_evacuate_in_progress with _ -> false @@ -717,9 +717,9 @@ let choose_host_for_vm ~__context ~vm ~snapshot = | ["WLB"; "0.0"; rec_id; zero_reason] -> filter_and_convert tl | ["WLB"; stars; rec_id] -> - let st = try float_of_string stars with Failure _ -> raise Float_of_string_failure - in - (h, st, rec_id) :: filter_and_convert tl + let st = try float_of_string stars with Failure _ -> raise Float_of_string_failure + in + (h, st, rec_id) :: filter_and_convert tl | _ -> filter_and_convert tl end | [] -> [] @@ -1021,20 +1021,20 @@ let assert_valid_bios_strings ~__context ~value = (* Validate size of value provided is within bios_string_limit_size and not empty *) (* Validate value chars are printable ASCII characters *) value |> List.iter (fun (k, v) -> - if not (List.mem k Xapi_globs.settable_vm_bios_string_keys) then - raise (Api_errors.Server_error(Api_errors.invalid_value, [k; "Unknown key"])); - match String.length v with - | 0 -> raise (Api_errors.Server_error(Api_errors.invalid_value, [k; "Value provided is empty"])) - | len when len > Xapi_globs.bios_string_limit_size -> - let err = Printf.sprintf "%s has length more than %d characters" v Xapi_globs.bios_string_limit_size in - raise (Api_errors.Server_error(Api_errors.invalid_value, [k; err])) - | _ -> - String.iter - (fun c -> - if c < (Char.chr 32) || c >= (Char.chr 127) then - raise (Api_errors.Server_error(Api_errors.invalid_value, [k; v ^ " has non-printable ASCII characters"])) - ) v - ) + if not (List.mem k Xapi_globs.settable_vm_bios_string_keys) then + raise (Api_errors.Server_error(Api_errors.invalid_value, [k; "Unknown key"])); + match String.length v with + | 0 -> raise (Api_errors.Server_error(Api_errors.invalid_value, [k; "Value provided is empty"])) + | len when len > Xapi_globs.bios_string_limit_size -> + let err = Printf.sprintf "%s has length more than %d characters" v Xapi_globs.bios_string_limit_size in + raise (Api_errors.Server_error(Api_errors.invalid_value, [k; err])) + | _ -> + String.iter + (fun c -> + if c < (Char.chr 32) || c >= (Char.chr 127) then + raise (Api_errors.Server_error(Api_errors.invalid_value, [k; v ^ " has non-printable ASCII characters"])) + ) v + ) let copy_bios_strings ~__context ~vm ~host = (* only allow to fill in BIOS strings if they are not yet set *) diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index 22d98a00c6f..f97a249fc77 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -255,8 +255,8 @@ let check_vgpu ~__context ~op ~ref_str ~vgpus = try (* Prevent VMs with VGPU from being migrated from pre-Jura to Jura and later hosts during RPU *) let host_from = Db.VGPU.get_VM ~__context ~self:vgpu - |> fun vm -> Db.VM.get_resident_on ~__context ~self:vm - |> fun host -> Helpers.LocalObject host + |> fun vm -> Db.VM.get_resident_on ~__context ~self:vm + |> fun host -> Helpers.LocalObject host in (* true if platform version of host_from more than inverness' 2.4.0 *) Helpers.(compare_int_lists (version_of ~__context host_from) platform_version_inverness) > 0 @@ -270,13 +270,13 @@ let check_vgpu ~__context ~op ~ref_str ~vgpus = let is_suspendable vgpu = Db.VGPU.get_type ~__context ~self:vgpu |> fun self -> Db.VGPU_type.get_implementation ~__context ~self - |> function - | `nvidia -> - let pgpu = Db.VGPU.get_resident_on ~__context ~self:vgpu in - Db.is_valid_ref __context pgpu && - (Db.PGPU.get_compatibility_metadata ~__context ~self:pgpu - |> List.mem_assoc Xapi_gpumon.Nvidia.key) - | _ -> false + |> function + | `nvidia -> + let pgpu = Db.VGPU.get_resident_on ~__context ~self:vgpu in + Db.is_valid_ref __context pgpu && + (Db.PGPU.get_compatibility_metadata ~__context ~self:pgpu + |> List.mem_assoc Xapi_gpumon.Nvidia.key) + | _ -> false in match op with | `pool_migrate | `migrate_send @@ -374,184 +374,184 @@ let check_operation_error ~__context ~ref = (fun ~op ~strict -> - let current_error = None in - - let check c f = match c with | Some e -> Some e | None -> f () in - - (* Check if the operation has been explicitly blocked by the/a user *) - let current_error = check current_error (fun () -> - Opt.map (fun v -> Api_errors.operation_blocked, [ref_str; v]) - (assoc_opt op vmr.Db_actions.vM_blocked_operations)) in - - (* Always check the power state constraint of the operation first *) - let current_error = check current_error (fun () -> - if not (is_allowed_sequentially ~__context ~vmr ~power_state ~op) - then report_power_state_error ~__context ~vmr ~power_state ~op ~ref_str - else None) in - - (* if other operations are in progress, check that the new operation is allowed concurrently with them. *) - let current_error = check current_error (fun () -> - let current_ops = vmr.Db_actions.vM_current_operations in - if List.length current_ops <> 0 && not (is_allowed_concurrently ~op ~current_ops) - then report_concurrent_operations_error ~current_ops ~ref_str - else None) in - - (* if the VM is a template, check the template behavior exceptions. *) - let current_error = check current_error (fun () -> - if is_template && not is_snapshot - then check_template ~vmr ~op ~ref_str - else None) in - - (* if the VM is a snapshot, check the snapshot behavior exceptions. *) - let current_error = check current_error (fun () -> - if is_snapshot - then check_snapshot ~vmr ~op ~ref_str - else None) in - - (* if the VM is neither a template nor a snapshot, do not allow provision and revert. *) - let current_error = check current_error (fun () -> - if op = `provision && (not is_template) - then Some (Api_errors.only_provision_template, []) - else None) in - - let current_error = check current_error (fun () -> - if op = `revert && (not is_snapshot) - then Some (Api_errors.only_revert_snapshot, []) - else None) in - - (* Some ops must be blocked if VM is not mobile *) - let current_error = check current_error (fun () -> - match op with - | `suspend - | `checkpoint - | `pool_migrate - | `migrate_send - when not (is_mobile ~__context ref strict) -> - Some (Api_errors.vm_is_immobile, [ref_str]) - | _ -> None - ) in - - let current_error = - let metrics = Db.VM.get_metrics ~__context ~self:ref in - check current_error (fun () -> - match op with - | `changing_dynamic_range - when nested_virt ~__context ref metrics && strict -> - Some (Api_errors.vm_is_using_nested_virt, [ref_str]) - | _ -> None - ) in - - - (* Check if the VM is a control domain (eg domain 0). *) - (* FIXME: Instead of special-casing for the control domain here, *) - (* make use of the Helpers.ballooning_enabled_for_vm function. *) - let current_error = check current_error (fun () -> + let current_error = None in + + let check c f = match c with | Some e -> Some e | None -> f () in + + (* Check if the operation has been explicitly blocked by the/a user *) + let current_error = check current_error (fun () -> + Opt.map (fun v -> Api_errors.operation_blocked, [ref_str; v]) + (assoc_opt op vmr.Db_actions.vM_blocked_operations)) in + + (* Always check the power state constraint of the operation first *) + let current_error = check current_error (fun () -> + if not (is_allowed_sequentially ~__context ~vmr ~power_state ~op) + then report_power_state_error ~__context ~vmr ~power_state ~op ~ref_str + else None) in + + (* if other operations are in progress, check that the new operation is allowed concurrently with them. *) + let current_error = check current_error (fun () -> + let current_ops = vmr.Db_actions.vM_current_operations in + if List.length current_ops <> 0 && not (is_allowed_concurrently ~op ~current_ops) + then report_concurrent_operations_error ~current_ops ~ref_str + else None) in + + (* if the VM is a template, check the template behavior exceptions. *) + let current_error = check current_error (fun () -> + if is_template && not is_snapshot + then check_template ~vmr ~op ~ref_str + else None) in + + (* if the VM is a snapshot, check the snapshot behavior exceptions. *) + let current_error = check current_error (fun () -> + if is_snapshot + then check_snapshot ~vmr ~op ~ref_str + else None) in + + (* if the VM is neither a template nor a snapshot, do not allow provision and revert. *) + let current_error = check current_error (fun () -> + if op = `provision && (not is_template) + then Some (Api_errors.only_provision_template, []) + else None) in + + let current_error = check current_error (fun () -> + if op = `revert && (not is_snapshot) + then Some (Api_errors.only_revert_snapshot, []) + else None) in + + (* Some ops must be blocked if VM is not mobile *) + let current_error = check current_error (fun () -> + match op with + | `suspend + | `checkpoint + | `pool_migrate + | `migrate_send + when not (is_mobile ~__context ref strict) -> + Some (Api_errors.vm_is_immobile, [ref_str]) + | _ -> None + ) in + + let current_error = + let metrics = Db.VM.get_metrics ~__context ~self:ref in + check current_error (fun () -> + match op with + | `changing_dynamic_range + when nested_virt ~__context ref metrics && strict -> + Some (Api_errors.vm_is_using_nested_virt, [ref_str]) + | _ -> None + ) in + + + (* Check if the VM is a control domain (eg domain 0). *) + (* FIXME: Instead of special-casing for the control domain here, *) + (* make use of the Helpers.ballooning_enabled_for_vm function. *) + let current_error = check current_error (fun () -> let vm_ref () = Db.VM.get_by_uuid ~__context ~uuid:vmr.Db_actions.vM_uuid in if (op = `changing_VCPUs || op = `destroy) && Helpers.is_domain_zero ~__context (vm_ref ()) - then Some (Api_errors.operation_not_allowed, ["This operation is not allowed on dom0"]) - else if vmr.Db_actions.vM_is_control_domain - && op <> `data_source_op - && op <> `changing_memory_live - && op <> `awaiting_memory_live - && op <> `metadata_export - && op <> `changing_dynamic_range - && op <> `changing_memory_limits - && op <> `changing_static_range - && op <> `start - && op <> `start_on - && op <> `changing_VCPUs - && op <> `destroy - then Some (Api_errors.operation_not_allowed, ["This operation is not allowed on a control domain"]) - else None) in - - (* check for any HVM guest feature needed by the op *) - let current_error = check current_error (fun () -> - check_op_for_feature ~__context ~vmr ~vmmr ~vmgmr ~power_state ~op ~ref ~strict - ) in - - (* check if the dynamic changeable operations are still valid *) - let current_error = check current_error (fun () -> - if op = `snapshot_with_quiesce && - (Pervasiveext.maybe_with_default true - (fun gm -> let other = gm.Db_actions.vM_guest_metrics_other in - not (List.mem_assoc "feature-quiesce" other || List.mem_assoc "feature-snapshot" other)) - vmgmr) - then Some (Api_errors.vm_snapshot_with_quiesce_not_supported, [ ref_str ]) - else None) in - - (* Check for an error due to VDI caching/reset behaviour *) - let current_error = check current_error (fun () -> - let vdis_reset_and_caching = List.filter_map (fun vdi -> - try - let sm_config = Db.VDI.get_sm_config ~__context ~self:vdi in - Some ((assoc_opt "on_boot" sm_config = Some "reset"), (bool_of_assoc "caching" sm_config)) - with _ -> None) vdis in - if op = `checkpoint || op = `snapshot || op = `suspend || op = `snapshot_with_quiesce - then (* If any vdi exists with on_boot=reset, then disallow checkpoint, snapshot, suspend *) - if List.exists fst vdis_reset_and_caching - then Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation,[]) - else None - else if op = `pool_migrate then - (* If any vdi exists with on_boot=reset and caching is enabled, disallow migrate *) - if List.exists (fun (reset,caching) -> reset && caching) vdis_reset_and_caching - then Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation,[]) - else None - else None) in - - (* If a PCI device is passed-through, check if the operation is allowed *) - let current_error = check current_error (fun () -> - if vmr.Db_actions.vM_attached_PCIs <> [] - then check_pci ~op ~ref_str - else None) in - - (* The VM has a VGPU, check if the operation is allowed*) - let current_error = check current_error (fun () -> - if vmr.Db_actions.vM_VGPUs <> [] - then check_vgpu ~__context ~op ~ref_str ~vgpus:vmr.Db_actions.vM_VGPUs - else None) in - - (* The VM has a VUSB, check if the operation is allowed*) - let current_error = check current_error (fun () -> - match op with - | `suspend - | `snapshot - | `checkpoint - | `migrate_send - | `pool_migrate when vmr.Db_actions.vM_VUSBs <> [] -> Some (Api_errors.vm_has_vusbs, [ref_str]) - | _ -> None) in - - (* Check for errors caused by VM being in an appliance. *) - let current_error = check current_error (fun () -> - if Db.is_valid_ref __context vmr.Db_actions.vM_appliance - then check_appliance ~vmr ~op ~ref_str - else None) in - - (* Check for errors caused by VM being assigned to a protection policy. *) - let current_error = check current_error (fun () -> - if Db.is_valid_ref __context vmr.Db_actions.vM_protection_policy - then check_protection_policy ~vmr ~op ~ref_str - else None) in - - (* Check for errors caused by VM being assigned to a snapshot schedule. *) - let current_error = check current_error (fun () -> - if Db.is_valid_ref __context vmr.Db_actions.vM_snapshot_schedule - then check_snapshot_schedule ~vmr ~ref_str op - else None) in - - (* Check whether this VM needs to be a system domain. *) - let current_error = check current_error (fun () -> - if op = `query_services && not (bool_of_assoc "is_system_domain" vmr.Db_actions.vM_other_config) - then Some (Api_errors.not_system_domain, [ ref_str ]) - else None) in - - let current_error = check current_error (fun () -> - if Helpers.rolling_upgrade_in_progress ~__context && - not (List.mem op Xapi_globs.rpu_allowed_vm_operations) - then Some (Api_errors.not_supported_during_upgrade, []) - else None) - in - - current_error + then Some (Api_errors.operation_not_allowed, ["This operation is not allowed on dom0"]) + else if vmr.Db_actions.vM_is_control_domain + && op <> `data_source_op + && op <> `changing_memory_live + && op <> `awaiting_memory_live + && op <> `metadata_export + && op <> `changing_dynamic_range + && op <> `changing_memory_limits + && op <> `changing_static_range + && op <> `start + && op <> `start_on + && op <> `changing_VCPUs + && op <> `destroy + then Some (Api_errors.operation_not_allowed, ["This operation is not allowed on a control domain"]) + else None) in + + (* check for any HVM guest feature needed by the op *) + let current_error = check current_error (fun () -> + check_op_for_feature ~__context ~vmr ~vmmr ~vmgmr ~power_state ~op ~ref ~strict + ) in + + (* check if the dynamic changeable operations are still valid *) + let current_error = check current_error (fun () -> + if op = `snapshot_with_quiesce && + (Pervasiveext.maybe_with_default true + (fun gm -> let other = gm.Db_actions.vM_guest_metrics_other in + not (List.mem_assoc "feature-quiesce" other || List.mem_assoc "feature-snapshot" other)) + vmgmr) + then Some (Api_errors.vm_snapshot_with_quiesce_not_supported, [ ref_str ]) + else None) in + + (* Check for an error due to VDI caching/reset behaviour *) + let current_error = check current_error (fun () -> + let vdis_reset_and_caching = List.filter_map (fun vdi -> + try + let sm_config = Db.VDI.get_sm_config ~__context ~self:vdi in + Some ((assoc_opt "on_boot" sm_config = Some "reset"), (bool_of_assoc "caching" sm_config)) + with _ -> None) vdis in + if op = `checkpoint || op = `snapshot || op = `suspend || op = `snapshot_with_quiesce + then (* If any vdi exists with on_boot=reset, then disallow checkpoint, snapshot, suspend *) + if List.exists fst vdis_reset_and_caching + then Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation,[]) + else None + else if op = `pool_migrate then + (* If any vdi exists with on_boot=reset and caching is enabled, disallow migrate *) + if List.exists (fun (reset,caching) -> reset && caching) vdis_reset_and_caching + then Some (Api_errors.vdi_on_boot_mode_incompatible_with_operation,[]) + else None + else None) in + + (* If a PCI device is passed-through, check if the operation is allowed *) + let current_error = check current_error (fun () -> + if vmr.Db_actions.vM_attached_PCIs <> [] + then check_pci ~op ~ref_str + else None) in + + (* The VM has a VGPU, check if the operation is allowed*) + let current_error = check current_error (fun () -> + if vmr.Db_actions.vM_VGPUs <> [] + then check_vgpu ~__context ~op ~ref_str ~vgpus:vmr.Db_actions.vM_VGPUs + else None) in + + (* The VM has a VUSB, check if the operation is allowed*) + let current_error = check current_error (fun () -> + match op with + | `suspend + | `snapshot + | `checkpoint + | `migrate_send + | `pool_migrate when vmr.Db_actions.vM_VUSBs <> [] -> Some (Api_errors.vm_has_vusbs, [ref_str]) + | _ -> None) in + + (* Check for errors caused by VM being in an appliance. *) + let current_error = check current_error (fun () -> + if Db.is_valid_ref __context vmr.Db_actions.vM_appliance + then check_appliance ~vmr ~op ~ref_str + else None) in + + (* Check for errors caused by VM being assigned to a protection policy. *) + let current_error = check current_error (fun () -> + if Db.is_valid_ref __context vmr.Db_actions.vM_protection_policy + then check_protection_policy ~vmr ~op ~ref_str + else None) in + + (* Check for errors caused by VM being assigned to a snapshot schedule. *) + let current_error = check current_error (fun () -> + if Db.is_valid_ref __context vmr.Db_actions.vM_snapshot_schedule + then check_snapshot_schedule ~vmr ~ref_str op + else None) in + + (* Check whether this VM needs to be a system domain. *) + let current_error = check current_error (fun () -> + if op = `query_services && not (bool_of_assoc "is_system_domain" vmr.Db_actions.vM_other_config) + then Some (Api_errors.not_system_domain, [ ref_str ]) + else None) in + + let current_error = check current_error (fun () -> + if Helpers.rolling_upgrade_in_progress ~__context && + not (List.mem op Xapi_globs.rpu_allowed_vm_operations) + then Some (Api_errors.not_supported_during_upgrade, []) + else None) + in + + current_error ) let get_operation_error ~__context ~self ~op ~strict = diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 11cfbab112c..9a3aa69bdd8 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -217,33 +217,33 @@ let infer_vgpu_map ~__context ?remote vm = | None -> let vgpus = Db.VM.get_VGPUs ~__context ~self:vm in List.map (fun self -> - let vgpu = Db.VGPU.get_record ~__context ~self in - let device = vgpu.API.vGPU_device in - let pci () = - vgpu.API.vGPU_scheduled_to_be_resident_on - |> fun self -> Db.PGPU.get_PCI ~__context ~self - |> fun self -> Db.PCI.get_pci_id ~__context ~self - |> Xenops_interface.Pci.address_of_string - in - try - device, pci () - with e -> raise (VGPU_mapping(Printexc.to_string e)) - ) vgpus + let vgpu = Db.VGPU.get_record ~__context ~self in + let device = vgpu.API.vGPU_device in + let pci () = + vgpu.API.vGPU_scheduled_to_be_resident_on + |> fun self -> Db.PGPU.get_PCI ~__context ~self + |> fun self -> Db.PCI.get_pci_id ~__context ~self + |> Xenops_interface.Pci.address_of_string + in + try + device, pci () + with e -> raise (VGPU_mapping(Printexc.to_string e)) + ) vgpus | Some {rpc; session} -> let vgpus = XenAPI.VM.get_VGPUs rpc session vm in List.map (fun self -> - let vgpu = XenAPI.VGPU.get_record rpc session self in - let device = vgpu.API.vGPU_device in - let pci () = - vgpu.API.vGPU_scheduled_to_be_resident_on - |> fun self -> XenAPI.PGPU.get_PCI rpc session self - |> fun self -> XenAPI.PCI.get_pci_id rpc session self - |> Xenops_interface.Pci.address_of_string - in - try - device, pci () - with e -> raise (VGPU_mapping(Printexc.to_string e)) - ) vgpus + let vgpu = XenAPI.VGPU.get_record rpc session self in + let device = vgpu.API.vGPU_device in + let pci () = + vgpu.API.vGPU_scheduled_to_be_resident_on + |> fun self -> XenAPI.PGPU.get_PCI rpc session self + |> fun self -> XenAPI.PCI.get_pci_id rpc session self + |> Xenops_interface.Pci.address_of_string + in + try + device, pci () + with e -> raise (VGPU_mapping(Printexc.to_string e)) + ) vgpus let pool_migrate ~__context ~vm ~host ~options = Pool_features.assert_enabled ~__context ~f:Features.Xen_motion; @@ -1024,7 +1024,7 @@ let migrate_send' ~__context ~vm ~dest ~live ~vdi_map ~vif_map ~vgpu_map ~optio as soon as the domain migration starts. For these case, there will be no (clean) way back from this point. So we disable task cancellation for them here. - *) + *) if is_same_host then (TaskHelper.exn_if_cancelling ~__context; TaskHelper.set_not_cancellable ~__context); (* It's acceptable for the VM not to exist at this point; shutdown commutes with storage migrate *) @@ -1063,7 +1063,7 @@ let migrate_send' ~__context ~vm ~dest ~live ~vdi_map ~vif_map ~vgpu_map ~optio updates, config or cleanup on the source and destination. There will be no (clean) way back from this point, due to these destructive changes, so we don't want user intervention e.g. task cancellation. - *) + *) TaskHelper.exn_if_cancelling ~__context; TaskHelper.set_not_cancellable ~__context; XenAPI.VM.pool_migrate_complete remote.rpc remote.session new_vm remote.dest_host; @@ -1194,77 +1194,77 @@ let assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map ~vif_map ~options ~v let host_from = Helpers.LocalObject source_host_ref in begin match migration_type ~__context ~remote with - | `intra_pool -> - (* Prevent VMs from being migrated onto a host with a lower platform version *) - let host_to = Helpers.LocalObject remote.dest_host in - if not (Helpers.host_versions_not_decreasing ~__context ~host_from ~host_to) then - raise (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])); - - (* Check VDIs are not migrating to or from an SR which doesn't have required_sr_operations *) - assert_sr_support_operations ~__context ~vdi_map ~remote ~ops:required_sr_operations; - if not force then Cpuid_helpers.assert_vm_is_compatible ~__context ~vm ~host:remote.dest_host (); - let snapshot = Db.VM.get_record ~__context ~self:vm in - Xapi_vm_helpers.assert_can_boot_here ~__context ~self:vm ~host:remote.dest_host ~snapshot ~do_sr_check:false (); - if vif_map <> [] then - raise (Api_errors.Server_error(Api_errors.operation_not_allowed, [ - "VIF mapping is not allowed for intra-pool migration"])); - - | `cross_pool -> - (* Prevent VMs from being migrated onto a host with a lower platform version *) - let host_to = Helpers.RemoteObject (remote.rpc, remote.session, remote.dest_host) in - if not (Helpers.host_versions_not_decreasing ~__context ~host_from ~host_to) then - raise (Api_errors.Server_error (Api_errors.vm_host_incompatible_version_migrate, - [Ref.string_of vm; Ref.string_of remote.dest_host])); - - (* Check VDIs are not migrating to or from an SR which doesn't have required_sr_operations *) - assert_sr_support_operations ~__context ~vdi_map ~remote ~ops:required_sr_operations; - let power_state = Db.VM.get_power_state ~__context ~self:vm in - (* The copy mode is only allow on stopped VM *) - if (not force) && copy && power_state <> `Halted then - raise (Api_errors.Server_error (Api_errors.vm_bad_power_state, - [Ref.string_of vm; Record_util.power_to_string `Halted; Record_util.power_to_string power_state])); - (* Check the host can support the VM's required version of virtual hardware platform *) - Xapi_vm_helpers.assert_hardware_platform_support ~__context ~vm ~host:host_to; - (*Check that the remote host is enabled and not in maintenance mode*) - let check_host_enabled = XenAPI.Host.get_enabled remote.rpc remote.session (remote.dest_host) in - if not check_host_enabled then - raise (Api_errors.Server_error (Api_errors.host_disabled,[Ref.string_of remote.dest_host])); - - (* Check that the VM's required CPU features are available on the host *) - if not force then - Cpuid_helpers.assert_vm_is_compatible ~__context ~vm ~host:remote.dest_host - ~remote:(remote.rpc, remote.session) (); - - (* Check that all VIFs are mapped. *) - let vifs = Db.VM.get_VIFs ~__context ~self:vm in - let snapshots = Db.VM.get_snapshots ~__context ~self:vm in - let snapshot_vifs = List.flatten - (List.map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots) in - let vif_map = infer_vif_map ~__context (vifs @ snapshot_vifs) vif_map in + | `intra_pool -> + (* Prevent VMs from being migrated onto a host with a lower platform version *) + let host_to = Helpers.LocalObject remote.dest_host in + if not (Helpers.host_versions_not_decreasing ~__context ~host_from ~host_to) then + raise (Api_errors.Server_error (Api_errors.not_supported_during_upgrade, [])); + + (* Check VDIs are not migrating to or from an SR which doesn't have required_sr_operations *) + assert_sr_support_operations ~__context ~vdi_map ~remote ~ops:required_sr_operations; + if not force then Cpuid_helpers.assert_vm_is_compatible ~__context ~vm ~host:remote.dest_host (); + let snapshot = Db.VM.get_record ~__context ~self:vm in + Xapi_vm_helpers.assert_can_boot_here ~__context ~self:vm ~host:remote.dest_host ~snapshot ~do_sr_check:false (); + if vif_map <> [] then + raise (Api_errors.Server_error(Api_errors.operation_not_allowed, [ + "VIF mapping is not allowed for intra-pool migration"])); + + | `cross_pool -> + (* Prevent VMs from being migrated onto a host with a lower platform version *) + let host_to = Helpers.RemoteObject (remote.rpc, remote.session, remote.dest_host) in + if not (Helpers.host_versions_not_decreasing ~__context ~host_from ~host_to) then + raise (Api_errors.Server_error (Api_errors.vm_host_incompatible_version_migrate, + [Ref.string_of vm; Ref.string_of remote.dest_host])); + + (* Check VDIs are not migrating to or from an SR which doesn't have required_sr_operations *) + assert_sr_support_operations ~__context ~vdi_map ~remote ~ops:required_sr_operations; + let power_state = Db.VM.get_power_state ~__context ~self:vm in + (* The copy mode is only allow on stopped VM *) + if (not force) && copy && power_state <> `Halted then + raise (Api_errors.Server_error (Api_errors.vm_bad_power_state, + [Ref.string_of vm; Record_util.power_to_string `Halted; Record_util.power_to_string power_state])); + (* Check the host can support the VM's required version of virtual hardware platform *) + Xapi_vm_helpers.assert_hardware_platform_support ~__context ~vm ~host:host_to; + (*Check that the remote host is enabled and not in maintenance mode*) + let check_host_enabled = XenAPI.Host.get_enabled remote.rpc remote.session (remote.dest_host) in + if not check_host_enabled then + raise (Api_errors.Server_error (Api_errors.host_disabled,[Ref.string_of remote.dest_host])); + + (* Check that the VM's required CPU features are available on the host *) + if not force then + Cpuid_helpers.assert_vm_is_compatible ~__context ~vm ~host:remote.dest_host + ~remote:(remote.rpc, remote.session) (); + + (* Check that all VIFs are mapped. *) + let vifs = Db.VM.get_VIFs ~__context ~self:vm in + let snapshots = Db.VM.get_snapshots ~__context ~self:vm in + let snapshot_vifs = List.flatten + (List.map (fun self -> Db.VM.get_VIFs ~__context ~self) snapshots) in + let vif_map = infer_vif_map ~__context (vifs @ snapshot_vifs) vif_map in - try - let vdi_map = - List.map (fun (vdi, sr) -> { - local_vdi_reference = vdi; - remote_vdi_reference = None; - }) - vdi_map in - let vif_map = - List.map (fun (vif, network) -> { - local_vif_reference = vif; - remote_network_reference = network; - }) - vif_map in - let vgpu_map = - List.map (fun (vgpu, gpu_group) -> { - local_vgpu_reference = vgpu; - remote_gpu_group_reference = gpu_group; - }) - vgpu_map in - if not (inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map ~vgpu_map ~dry_run:true ~live:true ~copy = []) then - raise Api_errors.(Server_error(internal_error, ["assert_can_migrate: inter_pool_metadata_transfer returned a nonempty list"])) - with Xmlrpc_client.Connection_reset -> - raise (Api_errors.Server_error(Api_errors.cannot_contact_host, [remote.remote_ip])) + try + let vdi_map = + List.map (fun (vdi, sr) -> { + local_vdi_reference = vdi; + remote_vdi_reference = None; + }) + vdi_map in + let vif_map = + List.map (fun (vif, network) -> { + local_vif_reference = vif; + remote_network_reference = network; + }) + vif_map in + let vgpu_map = + List.map (fun (vgpu, gpu_group) -> { + local_vgpu_reference = vgpu; + remote_gpu_group_reference = gpu_group; + }) + vgpu_map in + if not (inter_pool_metadata_transfer ~__context ~remote ~vm ~vdi_map ~vif_map ~vgpu_map ~dry_run:true ~live:true ~copy = []) then + raise Api_errors.(Server_error(internal_error, ["assert_can_migrate: inter_pool_metadata_transfer returned a nonempty list"])) + with Xmlrpc_client.Connection_reset -> + raise (Api_errors.Server_error(Api_errors.cannot_contact_host, [remote.remote_ip])) end; (* check_vdi_map above has already verified that all VDIs are in the vdi_map *) diff --git a/ocaml/xapi/xapi_vmss.ml b/ocaml/xapi/xapi_vmss.ml index db2697444b7..0ca0f733fb5 100644 --- a/ocaml/xapi/xapi_vmss.ml +++ b/ocaml/xapi/xapi_vmss.ml @@ -22,7 +22,7 @@ let vmss_snapshot_other_config_show_in_xencenter = "ShowInXenCenter" let vmss_snapshot_other_config_applies_to = "applies_to" let assert_licensed ~__context = - Pool_features.assert_enabled ~__context ~f:Features.VMSS + Pool_features.assert_enabled ~__context ~f:Features.VMSS (* Create VM snapshots just after creating a VMSS *) let snapshot_now ~__context ~vmss = @@ -55,10 +55,10 @@ let schedule_frequency_weekly_keys = schedule_field,[schedule_frequency_weekly,[ (* look-up structures, contain allowed map keys in a specific map type *) let schedule_keys = schedule_field, (List.map - (function (f,[k]) -> k - | _ -> assert false - ) - [schedule_frequency_hourly_keys;schedule_frequency_daily_keys;schedule_frequency_weekly_keys]) + (function (f,[k]) -> k + | _ -> assert false + ) + [schedule_frequency_hourly_keys;schedule_frequency_daily_keys;schedule_frequency_weekly_keys]) (* look-up structures, contain allowed map keys in all map types *) let schedule_all_keys = schedule_field,["",(List.fold_left (fun acc (sf,ks)->acc@ks) [] (let (f,kss)=schedule_keys in kss))] @@ -72,8 +72,8 @@ let assert_set_frequency ~frequency ~schedule= let assert_retained_snapshots ~retained_snapshots = let value = retained_snapshots in (if (value < 1L) || (value > 10L) - then - err "retained_snapshots" "" (Printf.sprintf "%Li" value) + then + err "retained_snapshots" "" (Printf.sprintf "%Li" value) ) let set_frequency ~__context ~self ~value = @@ -96,8 +96,8 @@ let set_type ~__context ~self ~value = Pool_features.assert_enabled ~__context ~f:Features.VSS; Db.VMSS.get_VMs ~__context ~self |> List.iter (fun vm -> - Xapi_vm_helpers.assert_vm_supports_quiesce_snapshot ~__context ~self:vm - ) + Xapi_vm_helpers.assert_vm_supports_quiesce_snapshot ~__context ~self:vm + ) end; Db.VMSS.set_type ~__context ~self ~value @@ -133,7 +133,7 @@ let set_retained_snapshots ~__context ~self ~value = (* VMSS constructors/destructors *) let create ~__context ~name_label ~name_description ~enabled - ~_type ~retained_snapshots ~frequency ~schedule + ~_type ~retained_snapshots ~frequency ~schedule : API.ref_VMSS = assert_licensed ~__context; @@ -157,8 +157,8 @@ let create ~__context ~name_label ~name_description ~enabled let destroy_all_messages ~__context ~self = let uuid = Db.VMSS.get_uuid ~__context ~self in Xapi_message.get_all_records ~__context - |> List.filter (fun (_, record) -> record.API.message_obj_uuid = uuid) - |> List.iter (fun (ref, _) -> Xapi_message.destroy ~__context ~self:ref) + |> List.filter (fun (_, record) -> record.API.message_obj_uuid = uuid) + |> List.iter (fun (ref, _) -> Xapi_message.destroy ~__context ~self:ref) let destroy ~__context ~self = assert_licensed ~__context; @@ -176,9 +176,9 @@ let destroy ~__context ~self = let is_vmss_snapshot ~__context = try (let session = Xapi_session.get_top ~__context ~self:(Context.get_session_id __context) in - let uname = Db.Session.get_auth_user_name ~__context ~self:session in - let is_lsu = Db.Session.get_is_local_superuser ~__context ~self:session in - is_lsu && (uname = vmss_username) + let uname = Db.Session.get_auth_user_name ~__context ~self:session in + let is_lsu = Db.Session.get_is_local_superuser ~__context ~self:session in + is_lsu && (uname = vmss_username) ) with e -> debug "Error obtaining is_vmss_snapshot: %s" (Printexc.to_string e); @@ -191,7 +191,7 @@ let show_task_in_xencenter ~__context ~vm = try debug "show_in_xencenter: task=%s" (Ref.string_of task); (* this key is used to make sure the snapshotting task *) - (* is seen from all xencenter clients *) + (* is seen from all xencenter clients *) Db.Task.add_to_other_config ~__context ~self:task ~key:vmss_snapshot_other_config_show_in_xencenter ~value:""; @@ -200,6 +200,6 @@ let show_task_in_xencenter ~__context ~vm = ~value:(Ref.string_of vm) with e-> debug "Error adding other_config:show_in_xencenter to task %s: %s" - (Ref.string_of task) (Printexc.to_string e) + (Ref.string_of task) (Printexc.to_string e) ) diff --git a/ocaml/xapi/xapi_vusb.ml b/ocaml/xapi/xapi_vusb.ml index e93d9977eb9..8a86e770334 100644 --- a/ocaml/xapi/xapi_vusb.ml +++ b/ocaml/xapi/xapi_vusb.ml @@ -25,26 +25,26 @@ let create ~__context ~vM ~uSB_group ~other_config = let uuid = Uuid.to_string (Uuid.make_uuid ()) in Pool_features.assert_enabled ~__context ~f:Features.USB_passthrough; Mutex.execute m (fun () -> - let attached_vusbs = Db.VM.get_VUSBs ~__context ~self:vM in - (* At most 6 VUSBS can be attached to one vm *) - if List.length attached_vusbs > 5 then - raise (Api_errors.Server_error (Api_errors.too_many_vusbs, ["6"])); - let vusbs = Db.USB_group.get_VUSBs ~__context ~self:uSB_group in - (* Currently USB_group only have one PUSB. So when vusb is created with a USB_group, - another vusb can not create with the same USB_group. *) - if vusbs <> [] then - raise (Api_errors.Server_error(Api_errors.usb_group_conflict, [Ref.string_of uSB_group])); - (* We won't attach VUSB when VM ha_restart_priority is set to 'restart' *) - let ha_restart_priority = Db.VM.get_ha_restart_priority ~__context ~self:vM in - match ha_restart_priority with - | hp when hp = Constants.ha_restart -> raise (Api_errors.Server_error(Api_errors.operation_not_allowed, - [Printf.sprintf "VM %s ha_restart_priority has been set to 'restart', can not create VUSB for it. " (Ref.string_of vM)])) - | _ -> - Db.VUSB.create ~__context ~ref:vusb ~uuid ~current_operations:[] ~allowed_operations:[] ~vM ~uSB_group - ~other_config ~currently_attached:false; - debug "VUSB ref='%s' created VM = '%s'" (Ref.string_of vusb) (Ref.string_of vM); - vusb - ) + let attached_vusbs = Db.VM.get_VUSBs ~__context ~self:vM in + (* At most 6 VUSBS can be attached to one vm *) + if List.length attached_vusbs > 5 then + raise (Api_errors.Server_error (Api_errors.too_many_vusbs, ["6"])); + let vusbs = Db.USB_group.get_VUSBs ~__context ~self:uSB_group in + (* Currently USB_group only have one PUSB. So when vusb is created with a USB_group, + another vusb can not create with the same USB_group. *) + if vusbs <> [] then + raise (Api_errors.Server_error(Api_errors.usb_group_conflict, [Ref.string_of uSB_group])); + (* We won't attach VUSB when VM ha_restart_priority is set to 'restart' *) + let ha_restart_priority = Db.VM.get_ha_restart_priority ~__context ~self:vM in + match ha_restart_priority with + | hp when hp = Constants.ha_restart -> raise (Api_errors.Server_error(Api_errors.operation_not_allowed, + [Printf.sprintf "VM %s ha_restart_priority has been set to 'restart', can not create VUSB for it. " (Ref.string_of vM)])) + | _ -> + Db.VUSB.create ~__context ~ref:vusb ~uuid ~current_operations:[] ~allowed_operations:[] ~vM ~uSB_group + ~other_config ~currently_attached:false; + debug "VUSB ref='%s' created VM = '%s'" (Ref.string_of vusb) (Ref.string_of vM); + vusb + ) let unplug ~__context ~self = Xapi_xenops.vusb_unplug ~__context ~self @@ -56,5 +56,5 @@ let destroy ~__context ~self = (* Force the user to unplug first *) if r.Db_actions.vUSB_currently_attached then raise (Api_errors.Server_error(Api_errors.operation_not_allowed, - [Printf.sprintf "VUSB '%s' still attached to '%s'" r.Db_actions.vUSB_uuid (Db.VM.get_uuid __context vm)])); + [Printf.sprintf "VUSB '%s' still attached to '%s'" r.Db_actions.vUSB_uuid (Db.VM.get_uuid __context vm)])); Db.VUSB.destroy ~__context ~self diff --git a/ocaml/xapi/xapi_vusb_helpers.ml b/ocaml/xapi/xapi_vusb_helpers.ml index d31e560392a..52d3ac302ee 100644 --- a/ocaml/xapi/xapi_vusb_helpers.ml +++ b/ocaml/xapi/xapi_vusb_helpers.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) - open Stdext.Xstringext +open Stdext.Xstringext module D=Debug.Make(struct let name="xapi" end) open D @@ -60,9 +60,9 @@ let valid_operations ~__context record _ref': table = | `Running, true -> set_errors Api_errors.device_already_attached [ _ref ] [ `plug] | `Running, false -> set_errors Api_errors.device_already_detached [ _ref ] [ `unplug] | _,_ -> - let actual = Record_util.power_to_string power_state in - let expected = Record_util.power_to_string `Running in - set_errors Api_errors.vm_bad_power_state [ Ref.string_of vm; expected; actual ] [ `plug; `unplug ]); + let actual = Record_util.power_to_string power_state in + let expected = Record_util.power_to_string `Running in + set_errors Api_errors.vm_bad_power_state [ Ref.string_of vm; expected; actual ] [ `plug; `unplug ]); let vm_current_ops = Db.VM.get_current_operations ~__context ~self:vm in List.iter (fun (task,op) -> @@ -77,7 +77,7 @@ let valid_operations ~__context record _ref': table = let throw_error (table: table) op = if not(Hashtbl.mem table op) then raise (Api_errors.Server_error(Api_errors.internal_error, - [ Printf.sprintf "xapi_vusb_helpers.assert_operation_valid unknown operation: %s" (vusb_operation_to_string op) ])); + [ Printf.sprintf "xapi_vusb_helpers.assert_operation_valid unknown operation: %s" (vusb_operation_to_string op) ])); match Hashtbl.find table op with | Some (code, params) -> raise (Api_errors.Server_error(code, params)) diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index d44872ef836..3ba7b821fd8 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -34,7 +34,7 @@ let check_power_state_is ~__context ~self ~expected = else (* CA-233915: only warn about unexpected power state - the check * is too naive to make it an assertion - *) + *) let actual = Db.VM.get_power_state ~__context ~self in if actual <> expected then warn "Potential problem: VM %s in power state '%s' when expecting '%s'" @@ -712,7 +712,7 @@ module MD = struct path = path; } with - | e -> + | e -> error "Caught %s: while getting PUSB path %s" (Printexc.to_string e) pusb.API.pUSB_path; raise e @@ -1882,17 +1882,17 @@ let update_pci ~__context id = Opt.iter (fun vgpu -> - let scheduled = - Db.VGPU.get_scheduled_to_be_resident_on ~__context ~self:vgpu - in - if Db.is_valid_ref __context scheduled && state.plugged - then - Helpers.call_api_functions ~__context - (fun rpc session_id -> - XenAPI.VGPU.atomic_set_resident_on ~rpc ~session_id - ~self:vgpu ~value:scheduled); - debug "xenopsd event: Update VGPU %s.%s currently_attached <- %b" (fst id) (snd id) state.plugged; - Db.VGPU.set_currently_attached ~__context ~self:vgpu ~value:state.plugged + let scheduled = + Db.VGPU.get_scheduled_to_be_resident_on ~__context ~self:vgpu + in + if Db.is_valid_ref __context scheduled && state.plugged + then + Helpers.call_api_functions ~__context + (fun rpc session_id -> + XenAPI.VGPU.atomic_set_resident_on ~rpc ~session_id + ~self:vgpu ~value:scheduled); + debug "xenopsd event: Update VGPU %s.%s currently_attached <- %b" (fst id) (snd id) state.plugged; + Db.VGPU.set_currently_attached ~__context ~self:vgpu ~value:state.plugged ) vgpu_opt ) info; Xenops_cache.update_pci id (Opt.map snd info); @@ -2151,16 +2151,16 @@ let resync_resident_on ~__context = let xapi_thinks_are_here, xapi_thinks_are_not_here = List.partition (fun ((id, _), _) -> List.exists (fun (id', _) -> id=id') resident_vms_in_db) - xenopsd_vms_in_xapi in + xenopsd_vms_in_xapi in (* Of those xapi thinks aren't here, are any running on another host? If so, kill the VM here. If they aren't running on another host (to the best of our knowledge), set the resident_on to be here. *) let xapi_thinks_are_elsewhere, xapi_thinks_are_nowhere = List.partition (fun ((id, _), _) -> - let vm_ref = vm_of_id ~__context id in - Db.is_valid_ref __context (Db.VM.get_resident_on ~__context ~self:vm_ref) - ) xapi_thinks_are_not_here in + let vm_ref = vm_of_id ~__context id in + Db.is_valid_ref __context (Db.VM.get_resident_on ~__context ~self:vm_ref) + ) xapi_thinks_are_not_here in (* This is the list of VMs xapi thought were running here, but actually aren't *) @@ -2218,14 +2218,14 @@ let resync_resident_on ~__context = let vm = vm_of_id ~__context id in info "Setting resident_on for VM %s to be this host as xenopsd is aware of it" id; Db.VM.set_resident_on ~__context ~self:vm ~value:localhost) - xapi_thinks_are_nowhere; + xapi_thinks_are_nowhere; (* Sync VM state in Xapi for VMs not running on this host *) List.iter (fun (id, vm) -> info "VM %s was marked as resident here in the DB but isn't known to xenopsd. Resetting in DB" id; Xapi_vm_lifecycle.force_state_reset ~__context ~self:vm ~value:`Halted; Db.VM.set_resident_on ~__context ~self:vm ~value:Ref.null; - ) xapi_vms_not_in_xenopsd + ) xapi_vms_not_in_xenopsd let resync_all_vms ~__context = (* This should now be correct *) @@ -2242,7 +2242,7 @@ let on_xapi_restart ~__context = (* For all available xenopsds, start the event thread. This will cause events on everything xenopsd knows about, hence a refresh of all VMs. *) List.iter (fun queue_name -> - let (_: Thread.t) = Thread.create events_from_xenopsd queue_name in + let (_: Thread.t) = Thread.create events_from_xenopsd queue_name in () ) (all_known_xenopsds ()); @@ -2861,7 +2861,7 @@ let resume ~__context ~self ~start_paused ~force = Db.VM.set_suspend_VDI ~__context ~self ~value:Ref.null; (* Clearing vGPU metadata should happen as late as possible * to make sure we only do it on a successful resume - *) + *) Xapi_gpumon.clear_vgpu_metadata ~__context ~vm:self; Helpers.call_api_functions ~__context (fun rpc session_id -> @@ -3199,4 +3199,4 @@ let vusb_unplug ~__context ~self = vusb_unplug_hvm ~__context ~self else raise Api_errors.(Server_error(internal_error, [ - Printf.sprintf "vusb_unplug: Unable to unplug vusb %s" (Ref.string_of self)])) + Printf.sprintf "vusb_unplug: Unable to unplug vusb %s" (Ref.string_of self)])) diff --git a/ocaml/xapi/xha_scripts.ml b/ocaml/xapi/xha_scripts.ml index c240cd44693..f23b7c5ae09 100644 --- a/ocaml/xapi/xha_scripts.ml +++ b/ocaml/xapi/xha_scripts.ml @@ -67,11 +67,11 @@ let can_unplug_statefile_pbd () = However during shutdown we stop the daemon, so querying the liveset should fail with daemon not running *) match call_script ~log_successful_output:false ha_query_liveset [] with | exception Xha_error Xha_errno.Mtc_exit_daemon_is_not_present -> - info "HA daemon not running: safe to unplug statefile PBD"; - true + info "HA daemon not running: safe to unplug statefile PBD"; + true | exception e -> - info "Caught exception querying liveset; assuming it is not safe to unplug: %s" (ExnHelper.string_of_exn e); - false + info "Caught exception querying liveset; assuming it is not safe to unplug: %s" (ExnHelper.string_of_exn e); + false | _ -> - info "HA daemon still running or in unknown state: assuming it is not safe to unplug"; - false + info "HA daemon still running or in unknown state: assuming it is not safe to unplug"; + false