diff --git a/ocaml/idl/datamodel_errors.ml b/ocaml/idl/datamodel_errors.ml index 20acb06f60b..4d019ce0564 100644 --- a/ocaml/idl/datamodel_errors.ml +++ b/ocaml/idl/datamodel_errors.ml @@ -538,7 +538,8 @@ let _ = ~doc:"You attempted an operation on a VM which is not suspendable." () ; error Api_errors.vm_is_template ["vm"] ~doc:"The operation attempted is not valid for a template VM" () ; - error Api_errors.other_operation_in_progress ["class"; "object"] + error Api_errors.other_operation_in_progress + ["class"; "object"; "operation_type"; "operation_ref"] ~doc:"Another operation involving the object is currently in progress" () ; error Api_errors.vbd_not_removable_media ["vbd"] ~doc:"Media could not be ejected because it is not removable" () ; diff --git a/ocaml/tests/test_clustering.ml b/ocaml/tests/test_clustering.ml index 9be97c5fdb5..edd33cb6025 100644 --- a/ocaml/tests/test_clustering.ml +++ b/ocaml/tests/test_clustering.ml @@ -581,11 +581,21 @@ let test_disallow_unplug_during_cluster_host_create () = let key = Context.get_task_id __context |> Ref.string_of in Db.Cluster.add_to_current_operations ~__context ~self:cluster ~key ~value in - let check_disallow_unplug_false_fails self msg = + let check_disallow_unplug_false_fails self op msg = + let op_ref, _ = + List.hd (Db.Cluster.get_current_operations ~__context ~self:cluster) + in Alcotest.check_raises msg Api_errors.( Server_error - (other_operation_in_progress, ["Cluster"; Ref.string_of cluster]) + ( other_operation_in_progress + , [ + "Cluster" + ; Ref.string_of cluster + ; API.cluster_operation_to_string op + ; op_ref + ] + ) ) (fun () -> Xapi_pif.set_disallow_unplug ~__context ~self ~value:false) in @@ -598,14 +608,14 @@ let test_disallow_unplug_during_cluster_host_create () = let test_with_current op = Xapi_pif.set_disallow_unplug ~__context ~self:pIF ~value:true ; add_op op ; - check_disallow_unplug_false_fails pIF + check_disallow_unplug_false_fails pIF op "disallow_unplug cannot be set to false during cluster_host creation or \ enable on same PIF" ; let other_pif = T.make_pif ~__context ~network ~host () in check_successful_disallow_unplug true other_pif "Should always be able to set disallow_unplug:true regardless of \ clustering operations" ; - check_disallow_unplug_false_fails other_pif + check_disallow_unplug_false_fails other_pif op "disallow_unplug cannot be set to false during cluster_host creation or \ enable on any PIF" ; let key = Context.get_task_id __context |> Ref.string_of in diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index aff1b815566..ddb957d119a 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -1685,7 +1685,7 @@ module Repeat_with_uniform_backoff : POLICY = struct debug "Waiting for up to %f seconds before retrying..." this_timeout ; let start = Unix.gettimeofday () in ( match e with - | Api_errors.Server_error (code, [cls; objref]) + | Api_errors.Server_error (code, cls :: objref :: _) when code = Api_errors.other_operation_in_progress -> Early_wakeup.wait (cls, objref) this_timeout | _ -> diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 4c79f91cf5f..8adf9ea632e 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -5720,14 +5720,21 @@ functor if Helpers.i_am_srmaster ~__context ~sr then List.iter (fun vdi -> - if Db.VDI.get_current_operations ~__context ~self:vdi <> [] - then - raise - (Api_errors.Server_error - ( Api_errors.other_operation_in_progress - , [Datamodel_common._vdi; Ref.string_of vdi] - ) - ) + match Db.VDI.get_current_operations ~__context ~self:vdi with + | (op_ref, op_type) :: _ -> + raise + (Api_errors.Server_error + ( Api_errors.other_operation_in_progress + , [ + Datamodel_common._vdi + ; Ref.string_of vdi + ; API.vdi_operations_to_string op_type + ; op_ref + ] + ) + ) + | [] -> + () ) (Db.SR.get_VDIs ~__context ~self:sr) ; SR.mark_sr ~__context ~sr ~doc ~op diff --git a/ocaml/xapi/xapi_cluster_helpers.ml b/ocaml/xapi/xapi_cluster_helpers.ml index a4d30bcedaa..1afdefb2864 100644 --- a/ocaml/xapi/xapi_cluster_helpers.ml +++ b/ocaml/xapi/xapi_cluster_helpers.ml @@ -24,19 +24,23 @@ let is_allowed_concurrently ~op:_ ~current_ops:_ = false let report_concurrent_operations_error ~current_ops ~ref_str = - let current_ops_str = + let current_ops_ref_str, current_ops_str = let op_to_str = Record_util.cluster_operation_to_string in + let ( >> ) f g x = g (f x) in match current_ops with | [] -> failwith "No concurrent operation to report" - | [(_, cop)] -> - op_to_str cop + | [(op_ref, cop)] -> + (op_ref, op_to_str cop) | l -> - "{" ^ String.concat "," (List.map op_to_str (List.map snd l)) ^ "}" + ( Printf.sprintf "{%s}" (String.concat "," (List.map fst l)) + , Printf.sprintf "{%s}" + (String.concat "," (List.map (snd >> op_to_str) l)) + ) in Some ( Api_errors.other_operation_in_progress - , ["Cluster." ^ current_ops_str; ref_str] + , ["Cluster"; ref_str; current_ops_str; current_ops_ref_str] ) (** Take an internal Cluster record and a proposed operation. Return None iff the operation diff --git a/ocaml/xapi/xapi_cluster_host_helpers.ml b/ocaml/xapi/xapi_cluster_host_helpers.ml index 59e5141da73..abdaa58c285 100644 --- a/ocaml/xapi/xapi_cluster_host_helpers.ml +++ b/ocaml/xapi/xapi_cluster_host_helpers.ml @@ -22,19 +22,23 @@ let is_allowed_concurrently ~op:_ ~current_ops:_ = false let report_concurrent_operations_error ~current_ops ~ref_str = - let current_ops_str = + let current_ops_ref_str, current_ops_str = let op_to_str = Record_util.cluster_host_operation_to_string in + let ( >> ) f g x = g (f x) in match current_ops with | [] -> failwith "No concurrent operation to report" - | [(_, cop)] -> - op_to_str cop + | [(op_ref, cop)] -> + (op_ref, op_to_str cop) | l -> - "{" ^ String.concat "," (List.map op_to_str (List.map snd l)) ^ "}" + ( Printf.sprintf "{%s}" (String.concat "," (List.map fst l)) + , Printf.sprintf "{%s}" + (String.concat "," (List.map (snd >> op_to_str) l)) + ) in Some ( Api_errors.other_operation_in_progress - , ["Cluster_host." ^ current_ops_str; ref_str] + , ["Cluster_host"; ref_str; current_ops_str; current_ops_ref_str] ) (** Take an internal Cluster_host record and a proposed operation. Return None iff the operation diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index 7b9ac9d7a2e..3523ceaefcf 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -31,7 +31,7 @@ let all_operations = API.host_allowed_operations__all (** Returns a table of operations -> API error options (None if the operation would be ok) *) let valid_operations ~__context record _ref' = let _ref = Ref.string_of _ref' in - let current_ops = List.map snd record.Db_actions.host_current_operations in + let current_ops = record.Db_actions.host_current_operations in let table = Hashtbl.create 10 in List.iter (fun x -> Hashtbl.replace table x None) all_operations ; let set_errors (code : string) (params : string list) @@ -49,40 +49,53 @@ let valid_operations ~__context record _ref' = let is_creating_new x = List.mem x [`provision; `vm_resume; `vm_migrate] in let is_removing x = List.mem x [`evacuate; `reboot; `shutdown] in let creating_new = - List.fold_left (fun acc op -> acc || is_creating_new op) false current_ops - in - let removing = - List.fold_left (fun acc op -> acc || is_removing op) false current_ops + List.find_opt (fun (_, op) -> is_creating_new op) current_ops in + let removing = List.find_opt (fun (_, op) -> is_removing op) current_ops in List.iter (fun op -> - if (is_creating_new op && removing) || (is_removing op && creating_new) - then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string (List.hd current_ops)] - [op] + match (is_creating_new op, removing, is_removing op, creating_new) with + | true, Some (op_ref, op_type), _, _ | _, _, true, Some (op_ref, op_type) + -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string op_type; op_ref] + [op] + | _ -> + () ) (List.filter (fun x -> x <> `power_on) all_operations) ; (* reboot, shutdown and apply_updates cannot run concurrently *) - if List.mem `reboot current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `reboot] - [`shutdown; `apply_updates] ; - if List.mem `shutdown current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `shutdown] - [`reboot; `apply_updates] ; - if List.mem `apply_updates current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `apply_updates] - [`reboot; `shutdown; `enable] ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `reboot; op_ref] + [`shutdown; `apply_updates] + ) + (List.find_opt (fun (_, op) -> op = `reboot) current_ops) ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `shutdown; op_ref] + [`reboot; `apply_updates] + ) + (List.find_opt (fun (_, op) -> op = `shutdown) current_ops) ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `apply_updates; op_ref] + [`reboot; `shutdown; `enable] + ) + (List.find_opt (fun (_, op) -> op = `apply_updates) current_ops) ; (* Prevent more than one provision happening at a time to prevent extreme dom0 load (in the case of the debian template). Once the template becomes a 'real' template we can relax this. *) - if List.mem `provision current_ops then - set_errors Api_errors.other_operation_in_progress - ["host"; _ref; host_operation_to_string `provision] - [`provision] ; + Option.iter + (fun (op_ref, _op_type) -> + set_errors Api_errors.other_operation_in_progress + ["host"; _ref; host_operation_to_string `provision; op_ref] + [`provision] + ) + (List.find_opt (fun (_, op) -> op = `provision) current_ops) ; (* The host must be disabled before reboots or shutdowns are permitted *) if record.Db_actions.host_enabled then set_errors Api_errors.host_not_disabled [] diff --git a/ocaml/xapi/xapi_pif.ml b/ocaml/xapi/xapi_pif.ml index 163e1f31d57..eaf4b37b8b9 100644 --- a/ocaml/xapi/xapi_pif.ml +++ b/ocaml/xapi/xapi_pif.ml @@ -926,17 +926,25 @@ let assert_cluster_host_operation_not_in_progress ~__context = match Db.Cluster.get_all ~__context with | [] -> () - | cluster :: _ -> - let ops = - Db.Cluster.get_current_operations ~__context ~self:cluster - |> List.map snd - in - if List.mem `enable ops || List.mem `add ops then - raise - Api_errors.( - Server_error - (other_operation_in_progress, ["Cluster"; Ref.string_of cluster]) - ) + | cluster :: _ -> ( + let ops = Db.Cluster.get_current_operations ~__context ~self:cluster in + match List.find_opt (fun (_, op) -> op = `enable || op = `add) ops with + | Some (op_ref, op_type) -> + raise + Api_errors.( + Server_error + ( other_operation_in_progress + , [ + "Cluster" + ; Ref.string_of cluster + ; API.cluster_operation_to_string op_type + ; op_ref + ] + ) + ) + | None -> + () + ) (* Block allowing unplug if - a cluster host is enabled on this PIF diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index 14f4c37d030..bdd4e0454b1 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -99,7 +99,7 @@ type validity = Unknown | Allowed | Disallowed of string * string list let compute_valid_operations ~__context record pool : API.pool_allowed_operations -> validity = let ref = Ref.string_of pool in - let current_ops = List.map snd record.Db_actions.pool_current_operations in + let current_ops = record.Db_actions.pool_current_operations in let table = (Hashtbl.create 32 : (all_operations, validity) Hashtbl.t) in let set_validity = Hashtbl.replace table in (* Start by assuming all operations are allowed. *) @@ -118,30 +118,45 @@ let compute_valid_operations ~__context record pool : in List.iter populate ops in - let other_operation_in_progress = - (Api_errors.other_operation_in_progress, [Datamodel_common._pool; ref]) + let other_operation_in_progress waiting_op = + let additional_info = + match waiting_op with + | Some (op_ref, op_type) -> + [API.pool_allowed_operations_to_string op_type; op_ref] + | _ -> + [] + in + ( Api_errors.other_operation_in_progress + , [Datamodel_common._pool; ref] @ additional_info + ) + in + let is_current_op op = + List.exists (fun (_, current_op) -> op = current_op) current_ops in - let is_current_op = Fun.flip List.mem current_ops in let blocking = List.find_opt (fun (op, _) -> is_current_op op) blocking_ops_table in - let waiting = List.find_opt is_current_op waiting_ops in + let waiting = + List.find_opt + (fun (_, current_op) -> List.mem current_op waiting_ops) + current_ops + in ( match (blocking, waiting) with - | Some (_, reason), _ -> + | Some (_, reason), waiting_current_op -> (* Mark all potentially blocking operations as invalid due to the specific blocking operation's "in progress" error. *) set_errors blocking_ops (reason, []) ; (* Mark all waiting operations as invalid for the generic "OTHER_OPERATION_IN_PROGRESS" reason. *) - set_errors waiting_ops other_operation_in_progress + set_errors waiting_ops (other_operation_in_progress waiting_current_op) (* Note that all_operations ⊆ blocking_ops ∪ waiting_ops, so this invalidates all operations (with the reason partitioned between whether the operation is blocking or waiting). *) - | None, Some _ -> + | None, (Some _ as waiting_current_op) -> (* If there's no blocking operation in current operations, but there is a waiting operation, invalidate all operations for the generic reason. Again, this covers every operation. *) - set_errors all_operations other_operation_in_progress + set_errors all_operations (other_operation_in_progress waiting_current_op) | None, None -> ( (* If there's no blocking or waiting operation in current operations (i.e. current operations is empty), we can report diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 75a3c695af4..b08a82c20f2 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -200,24 +200,35 @@ let valid_operations ~__context ?op record _ref' : table = let check_parallel_ops ~__context _record = let safe_to_parallelise = [`plug] in let current_ops = - Xapi_stdext_std.Listext.List.setify (List.map snd current_ops) + List.sort_uniq + (fun (_ref1, op1) (_ref2, op2) -> compare op1 op2) + current_ops in (* If there are any current operations, all the non_parallelisable operations must definitely be stopped *) - if current_ops <> [] then - set_errors Api_errors.other_operation_in_progress - ["SR"; _ref; sr_operation_to_string (List.hd current_ops)] - (Xapi_stdext_std.Listext.List.set_difference all_ops safe_to_parallelise) ; - let all_are_parallelisable = - List.fold_left ( && ) true - (List.map (fun op -> List.mem op safe_to_parallelise) current_ops) - in - (* If not all are parallelisable (eg a vdi_resize), ban the otherwise - parallelisable operations too *) - if not all_are_parallelisable then - set_errors Api_errors.other_operation_in_progress - ["SR"; _ref; sr_operation_to_string (List.hd current_ops)] - safe_to_parallelise + match current_ops with + | (current_op_ref, current_op_type) :: _ -> + set_errors Api_errors.other_operation_in_progress + ["SR"; _ref; sr_operation_to_string current_op_type; current_op_ref] + (Xapi_stdext_std.Listext.List.set_difference all_ops + safe_to_parallelise + ) ; + let non_parallelisable_op = + List.find_opt + (fun (_, op) -> not (List.mem op safe_to_parallelise)) + current_ops + in + (* If not all are parallelisable (eg a vdi_resize), ban the otherwise + parallelisable operations too *) + Option.iter + (fun (op_ref, op_type) -> + set_errors Api_errors.other_operation_in_progress + ["SR"; _ref; sr_operation_to_string op_type; op_ref] + safe_to_parallelise + ) + non_parallelisable_op + | [] -> + () in let check_cluster_stack_compatible ~__context _record = (* Check whether there are any conflicts with HA that prevent us from diff --git a/ocaml/xapi/xapi_vbd.ml b/ocaml/xapi/xapi_vbd.ml index cf7ab173882..331284eb344 100644 --- a/ocaml/xapi/xapi_vbd.ml +++ b/ocaml/xapi/xapi_vbd.ml @@ -184,19 +184,26 @@ let create ~__context ~vM ~vDI ~device ~userdevice ~bootable ~mode ~_type (* CA-75697: Disallow VBD.create on a VM that's in the middle of a migration *) debug "Checking whether there's a migrate in progress..." ; let vm_current_ops = - Xapi_stdext_std.Listext.List.setify - (List.map snd (Db.VM.get_current_operations ~__context ~self:vM)) + List.sort_uniq + (fun (_ref1, op1) (_ref2, op2) -> compare op1 op2) + (Db.VM.get_current_operations ~__context ~self:vM) in + let migrate_ops = [`migrate_send; `pool_migrate] in let migrate_ops_in_progress = - List.filter (fun op -> List.mem op vm_current_ops) migrate_ops + List.filter (fun (_, op) -> List.mem op migrate_ops) vm_current_ops in match migrate_ops_in_progress with - | op :: _ -> + | (op_ref, op_type) :: _ -> raise (Api_errors.Server_error ( Api_errors.other_operation_in_progress - , ["VM"; Ref.string_of vM; Record_util.vm_operation_to_string op] + , [ + "VM" + ; Ref.string_of vM + ; Record_util.vm_operation_to_string op_type + ; op_ref + ] ) ) | _ -> diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index 3e74dfe1f88..d23d161e988 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -42,7 +42,9 @@ type table = (API.vbd_operations, (string * string list) option) Hashtbl.t let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = let _ref = Ref.string_of _ref' in let current_ops = - Listext.List.setify (List.map snd record.Db_actions.vBD_current_operations) + List.sort_uniq + (fun (_ref1, op1) (_ref2, op2) -> compare op1 op2) + record.Db_actions.vBD_current_operations in (* Policy: * current_ops must be empty [ will make exceptions later for eg eject/unplug of attached vbd ] @@ -74,30 +76,48 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = let safe_to_parallelise = [`pause; `unpause] in (* Any current_operations preclude everything that isn't safe to parallelise *) ( if current_ops <> [] then - let concurrent_op = List.hd current_ops in + let concurrent_op_ref, concurrent_op_type = List.hd current_ops in set_errors Api_errors.other_operation_in_progress - ["VBD"; _ref; vbd_operations_to_string concurrent_op] + [ + "VBD" + ; _ref + ; vbd_operations_to_string concurrent_op_type + ; concurrent_op_ref + ] (Listext.List.set_difference all_ops safe_to_parallelise) ) ; (* If not all operations are parallisable then preclude pause *) - let all_are_parallelisable = - List.fold_left ( && ) true - (List.map (fun op -> List.mem op safe_to_parallelise) current_ops) + let non_parallelisable_op = + List.find_opt + (fun (_, op) -> not (List.mem op safe_to_parallelise)) + current_ops in (* If not all are parallelisable, ban the otherwise parallelisable operations too *) - if not all_are_parallelisable then - set_errors Api_errors.other_operation_in_progress - ["VBD"; _ref; vbd_operations_to_string (List.hd current_ops)] - [`pause] ; + ( match non_parallelisable_op with + | Some (concurrent_op_ref, concurrent_op_type) -> + set_errors Api_errors.other_operation_in_progress + [ + "VBD" + ; _ref + ; vbd_operations_to_string concurrent_op_type + ; concurrent_op_ref + ] + [`pause] + | None -> + () + ) ; + (* If something other than `pause `unpause *and* `attach (for VM.reboot, see CA-24282) then disallow unpause *) - if - Listext.List.set_difference current_ops (`attach :: safe_to_parallelise) - <> [] - then - set_errors Api_errors.other_operation_in_progress - ["VBD"; _ref; vbd_operations_to_string (List.hd current_ops)] - [`unpause] ; + let set_difference a b = List.filter (fun (_, x) -> not (List.mem x b)) a in + ( match set_difference current_ops (`attach :: safe_to_parallelise) with + | (op_ref, op_type) :: _ -> + set_errors Api_errors.other_operation_in_progress + ["VBD"; _ref; vbd_operations_to_string op_type; op_ref] + [`unpause] + | [] -> + () + ) ; (* Drives marked as not unpluggable cannot be unplugged *) if not record.Db_actions.vBD_unpluggable then set_errors Api_errors.vbd_not_unpluggable [_ref] [`unplug; `unplug_force] ; @@ -128,7 +148,10 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = let bad_ops = [`plug; `unplug; `unplug_force] in (* However allow VBD pause and unpause if the VM is paused: *) let bad_ops' = - if power_state = `Paused then bad_ops else `pause :: `unpause :: bad_ops + if power_state = `Paused then + bad_ops + else + `pause :: `unpause :: bad_ops in set_errors Api_errors.vm_bad_power_state [Ref.string_of vm; expected; actual] @@ -226,17 +249,23 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = | _ -> true in - List.exists + List.find_opt (fun (_, operation) -> is_illegal_operation operation) vdi_record.Db_actions.vDI_current_operations in - ( if vdi_operations_besides_copy then - let concurrent_op = - snd (List.hd vdi_record.Db_actions.vDI_current_operations) - in + + ( match vdi_operations_besides_copy with + | Some (concurrent_op_ref, concurrent_op_type) -> set_errors Api_errors.other_operation_in_progress - ["VDI"; Ref.string_of vdi; vdi_operations_to_string concurrent_op] + [ + "VDI" + ; Ref.string_of vdi + ; vdi_operations_to_string concurrent_op_type + ; concurrent_op_ref + ] [`attach; `plug; `insert] + | None -> + () ) ; if (not record.Db_actions.vBD_currently_attached) && expensive_sharing_checks diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index 0f9904d72fb..624875c21e5 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -187,13 +187,18 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) let is_vdi_mirroring_in_progress = op = `destroy && List.exists (fun (_, op) -> op = `mirror) current_ops in - if - List.exists (fun (_, op) -> op <> `copy) current_ops - && not is_vdi_mirroring_in_progress - then - Error (Api_errors.other_operation_in_progress, ["VDI"; _ref]) - else - Ok () + match + ( is_vdi_mirroring_in_progress + , List.find_opt (fun (_, op) -> op <> `copy) current_ops + ) + with + | false, Some (op_ref, op_type) -> + Error + ( Api_errors.other_operation_in_progress + , ["VDI"; _ref; API.vdi_operations_to_string op_type; op_ref] + ) + | _ -> + Ok () in let* () = if pbds_attached = [] && op = `resize then @@ -277,7 +282,15 @@ let check_operation_error ~__context ?sr_records:_ ?(pbd_records = []) mechanism of message forwarding and only use the event loop. *) my_has_current_operation_vbd_records <> [] && op <> `data_destroy then - Error (Api_errors.other_operation_in_progress, ["VDI"; _ref]) + let op_ref, op_type = + List.hd + (List.hd my_has_current_operation_vbd_records) + .Db_actions.vBD_current_operations + in + Error + ( Api_errors.other_operation_in_progress + , ["VDI"; _ref; API.vbd_operations_to_string op_type; op_ref] + ) else Ok () in diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 5ab6f146339..34682f9aa78 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -50,18 +50,20 @@ let valid_operations ~__context record _ref' : table = in let vm = Db.VIF.get_VM ~__context ~self:_ref' in (* Any current_operations preclude everything else *) - if current_ops <> [] then ( - debug "No operations are valid because current-operations = [ %s ]" - (String.concat "; " - (List.map - (fun (task, op) -> task ^ " -> " ^ vif_operations_to_string op) - current_ops - ) - ) ; - let concurrent_op = snd (List.hd current_ops) in - set_errors Api_errors.other_operation_in_progress - ["VIF"; _ref; vif_operations_to_string concurrent_op] - all_ops + ( if current_ops <> [] then + let concurrent_op_refs, concurrent_op_types = + List.fold_left + (fun (refs, types) (ref, op) -> + (ref :: refs, vif_operations_to_string op :: types) + ) + ([], []) current_ops + in + let format x = Printf.sprintf "{%s}" (String.concat "; " x) in + let concurrent_op_refs = format concurrent_op_refs in + let concurrent_op_types = format concurrent_op_types in + set_errors Api_errors.other_operation_in_progress + ["VIF"; _ref; concurrent_op_types; concurrent_op_refs] + all_ops ) ; (* No hotplug on dom0 *) if Helpers.is_domain_zero ~__context vm then diff --git a/ocaml/xapi/xapi_vm_appliance_lifecycle.ml b/ocaml/xapi/xapi_vm_appliance_lifecycle.ml index 330d028cf1c..765fd9c3568 100644 --- a/ocaml/xapi/xapi_vm_appliance_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_appliance_lifecycle.ml @@ -18,38 +18,48 @@ let check_operation_error ~__context record self op = let _ref = Ref.string_of self in let current_ops = record.Db_actions.vM_appliance_current_operations in (* Only allow one operation of [`start | `clean_shutdown | `hard_shutdown | `shutdown ] at a time. *) - if current_ops <> [] then - Some (Api_errors.other_operation_in_progress, ["VM_appliance"; _ref]) - else - let vms = Db.VM_appliance.get_VMs ~__context ~self in - if vms = [] then - Some (Api_errors.operation_not_allowed, ["Appliance has no VMs."]) - else (* Allow the op if any VMs are in a state where the op makes sense. *) - let power_states = - List.map (fun vm -> Db.VM.get_power_state ~__context ~self:vm) vms - in - let predicate, error = - match op with - (* Can start if any are halted. *) - | `start -> - ( (fun power_state -> power_state = `Halted) - , "There are no halted VMs in this appliance." - ) - (* Can clean_shutdown if any are running. *) - | `clean_shutdown -> - ( (fun power_state -> power_state = `Running) - , "There are no running VMs in this appliance." - ) - (* Can hard_shutdown/shutdown if any are not halted. *) - | `hard_shutdown | `shutdown -> - ( (fun power_state -> power_state <> `Halted) - , "All VMs in this appliance are halted." - ) - in - if List.exists predicate power_states then - None + match current_ops with + | (op_ref, op_type) :: _ -> + Some + ( Api_errors.other_operation_in_progress + , [ + "VM_appliance" + ; _ref + ; API.vm_appliance_operation_to_string op_type + ; op_ref + ] + ) + | [] -> + let vms = Db.VM_appliance.get_VMs ~__context ~self in + if vms = [] then + Some (Api_errors.operation_not_allowed, ["Appliance has no VMs."]) else - Some (Api_errors.operation_not_allowed, [error]) + (* Allow the op if any VMs are in a state where the op makes sense. *) + let power_states = + List.map (fun vm -> Db.VM.get_power_state ~__context ~self:vm) vms + in + let predicate, error = + match op with + (* Can start if any are halted. *) + | `start -> + ( (fun power_state -> power_state = `Halted) + , "There are no halted VMs in this appliance." + ) + (* Can clean_shutdown if any are running. *) + | `clean_shutdown -> + ( (fun power_state -> power_state = `Running) + , "There are no running VMs in this appliance." + ) + (* Can hard_shutdown/shutdown if any are not halted. *) + | `hard_shutdown | `shutdown -> + ( (fun power_state -> power_state <> `Halted) + , "All VMs in this appliance are halted." + ) + in + if List.exists predicate power_states then + None + else + Some (Api_errors.operation_not_allowed, [error]) let assert_operation_valid ~__context ~self ~(op : API.vm_appliance_operation) = let all = Db.VM_appliance.get_record_internal ~__context ~self in diff --git a/ocaml/xapi/xapi_vm_lifecycle.ml b/ocaml/xapi/xapi_vm_lifecycle.ml index 30a6a4b3307..6db1c70a84c 100644 --- a/ocaml/xapi/xapi_vm_lifecycle.ml +++ b/ocaml/xapi/xapi_vm_lifecycle.ml @@ -276,20 +276,24 @@ let report_power_state_error ~__context ~vmr ~power_state ~op ~ref_str = Some (Api_errors.vm_bad_power_state, [ref_str; expected; actual]) let report_concurrent_operations_error ~current_ops ~ref_str = - let current_ops_str = + let current_ops_ref_str, current_ops_str = + let op_to_str = Record_util.vm_operation_to_string in + let ( >> ) f g x = g (f x) in match current_ops with | [] -> failwith "No concurrent operation to report" - | [(_, cop)] -> - Record_util.vm_operation_to_string cop + | [(op_ref, cop)] -> + (op_ref, op_to_str cop) | l -> - "{" - ^ String.concat "," - (List.map Record_util.vm_operation_to_string (List.map snd l)) - ^ "}" + ( Printf.sprintf "{%s}" (String.concat "," (List.map fst l)) + , Printf.sprintf "{%s}" + (String.concat "," (List.map (snd >> op_to_str) l)) + ) in Some - (Api_errors.other_operation_in_progress, ["VM." ^ current_ops_str; ref_str]) + ( Api_errors.other_operation_in_progress + , ["VM"; ref_str; current_ops_str; current_ops_ref_str] + ) let check_vgpu ~__context ~op ~ref_str ~vgpus ~power_state = let is_migratable vgpu = diff --git a/ocaml/xapi/xapi_vusb_helpers.ml b/ocaml/xapi/xapi_vusb_helpers.ml index 9b1870cf141..5c17c5e8130 100644 --- a/ocaml/xapi/xapi_vusb_helpers.ml +++ b/ocaml/xapi/xapi_vusb_helpers.ml @@ -16,8 +16,6 @@ open Xapi_stdext_std.Xstringext module D = Debug.Make (struct let name = "xapi_vusb_helpers" end) -open D - (**************************************************************************************) (* current/allowed operations checking *) @@ -48,18 +46,20 @@ let valid_operations ~__context record _ref' : table = ops in (* Any current_operations preclude everything else *) - if current_ops <> [] then ( - debug "No operations are valid because current-operations = [ %s ]" - (String.concat "; " - (List.map - (fun (task, op) -> task ^ " -> " ^ vusb_operations_to_string op) - current_ops - ) - ) ; - let concurrent_op = snd (List.hd current_ops) in - set_errors Api_errors.other_operation_in_progress - ["VUSB"; _ref; vusb_operations_to_string concurrent_op] - all_ops + ( if current_ops <> [] then + let concurrent_op_refs, concurrent_op_types = + List.fold_left + (fun (refs, types) (ref, op) -> + (ref :: refs, vusb_operations_to_string op :: types) + ) + ([], []) current_ops + in + let format x = Printf.sprintf "{%s}" (String.concat "; " x) in + let concurrent_op_refs = format concurrent_op_refs in + let concurrent_op_types = format concurrent_op_types in + set_errors Api_errors.other_operation_in_progress + ["VUSB"; _ref; concurrent_op_types; concurrent_op_refs] + all_ops ) ; let vm = Db.VUSB.get_VM ~__context ~self:_ref' in let power_state = Db.VM.get_power_state ~__context ~self:vm in diff --git a/quality-gate.sh b/quality-gate.sh index 7591e3c4ff4..6f3a72b30a1 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=279 + N=274 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages"