<commit_before>(*
 * Copyright (C) 2006-2009 Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)
(** Helper functions relating to VM lifecycle operations.
 * @group Virtual-Machine Management
*)

open Stdext
open Listext

module D = Debug.Make(struct let name="xapi" end)
open D

module Rrdd = Rrd_client.Client

let all_vm_operations =
  [ `assert_operation_valid
  ; `awaiting_memory_live
  ; `call_plugin
  ; `changing_VCPUs
  ; `changing_VCPUs_live
  ; `changing_dynamic_range
  ; `changing_memory_limits
  ; `changing_memory_live
  ; `changing_shadow_memory
  ; `changing_shadow_memory_live
  ; `changing_static_range
  ; `checkpoint
  ; `clean_reboot
  ; `clean_shutdown
  ; `clone
  ; `copy
  ; `create_template
  ; `csvm
  ; `data_source_op
  ; `destroy
  ; `export
  ; `get_boot_record
  ; `hard_reboot
  ; `hard_shutdown
  ; `import
  ; `make_into_template
  ; `metadata_export
  ; `migrate_send
  ; `pause
  ; `pool_migrate
  ; `power_state_reset
  ; `provision
  ; `query_services
  ; `resume
  ; `resume_on
  ; `revert
  ; `reverting
  ; `send_sysrq
  ; `send_trigger
  ; `shutdown
  ; `snapshot
  ; `snapshot_with_quiesce
  ; `start
  ; `start_on
  ; `suspend
  ; `unpause
  ; `update_allowed_operations
  ]

let assoc_opt key assocs = Opt.of_exception (fun () -> List.assoc key assocs)
let bool_of_assoc key assocs = match assoc_opt key assocs with
  | Some v -> v = "1" || String.lowercase v = "true"
  | _ -> false

(** Given an operation, [allowed_power_states] returns all the possible power state for
    	wich this operation can be performed. *)
let allowed_power_states ~__context ~vmr ~(op:API.vm_operations) =
  let all_power_states =
    [`Halted; `Paused; `Suspended; `Running] in
  match op with
  (* a VM.import is done on file and not on VMs, so there is not power-state there! *)
  | `import
    -> []
  | `changing_VCPUs
  | `changing_static_range
  | `changing_memory_limits       -> `Halted :: (if vmr.Db_actions.vM_is_control_domain then [`Running] else [])
  | `changing_shadow_memory
  | `make_into_template
  | `provision
  | `start
  | `start_on
    -> [`Halted]
  | `unpause
    -> [`Paused]
  | `csvm
  | `resume
  | `resume_on
    -> [`Suspended]
  | `awaiting_memory_live
  | `call_plugin
  | `clean_reboot
  | `clean_shutdown
  | `changing_memory_live
  | `changing_shadow_memory_live
  | `changing_VCPUs_live
  | `data_source_op
  | `pause
  | `pool_migrate
  | `send_sysrq
  | `send_trigger
  | `snapshot_with_quiesce
  | `suspend
    -> [`Running]
  | `changing_dynamic_range
    -> [`Halted; `Running]
  | `clone
  | `copy
    -> `Halted :: (if vmr.Db_actions.vM_is_a_snapshot || Helpers.clone_suspended_vm_enabled ~__context then [`Suspended] else [])
  | `create_template (* Don't touch until XMLRPC unmarshal code is able to pre-blank fields on input. *)
  | `destroy
  | `export
    -> [`Halted; `Suspended]
  | `hard_reboot
    -> [`Paused; `Running]
  | `checkpoint
  | `get_boot_record
  | `shutdown
  | `hard_shutdown
    -> [`Paused; `Suspended; `Running]
  | `migrate_send
    -> [`Halted; `Suspended; `Running]
  | `assert_operation_valid
  | `metadata_export
  | `power_state_reset
  | `revert
  | `reverting
  | `snapshot
  | `update_allowed_operations
  | `query_services
    -> all_power_states

(** check if [op] can be done when [vmr] is in [power_state], when no other operation is in progress *)
let is_allowed_sequentially ~__context ~vmr ~power_state ~op =
  List.mem power_state (allowed_power_states ~__context ~vmr ~op)

(**	check if [op] can be done while [current_ops] are already in progress.
   	Remark: we do not test whether the power-state is valid. *)
let is_allowed_concurrently ~(op:API.vm_operations) ~current_ops =
  (* declare below the non-conflicting concurrent sets. *)
  let long_copies = [`clone; `copy; `export ]
  and boot_record = [`get_boot_record]
  and snapshot    = [`snapshot; `checkpoint]
  and allowed_operations = (* a list of valid state -> operation *)
    [ [`snapshot_with_quiesce], `snapshot;
      [`migrate_send],          `metadata_export;
      [`migrate_send],          `clean_shutdown;
      [`migrate_send],          `clean_reboot;
      [`migrate_send],          `start;
      [`migrate_send],          `start_on;
    ] in
  let state_machine () =
    let current_state = List.map snd current_ops in
    match op with
    | `hard_shutdown
      -> not (List.mem op current_state)
    | `hard_reboot -> not (List.exists
                             (fun o -> List.mem o [`hard_shutdown; `hard_reboot]) current_state)
    | _ -> List.exists (fun (state, transition) ->
        state = current_state && transition = op) allowed_operations
  in
  let aux ops =
    List.mem op ops && List.for_all (fun (_,o) -> List.mem o ops) current_ops
  in
  aux long_copies || aux snapshot || aux boot_record || state_machine ()

(** True iff the vm guest metrics "other" field includes (feature, "1")
    	as a key-value pair. *)
let has_feature ~vmgmr ~feature =
  match vmgmr with
  | None -> false
  | Some gmr ->
    let other = gmr.Db_actions.vM_guest_metrics_other in
    try
      List.assoc feature other = "1"
    with Not_found -> false

(** Return an error iff vmr is an HVM guest and lacks a needed feature.
 *  Note: it turned out that the Windows guest agent does not write "feature-suspend"
 *  on resume (only on startup), so we cannot rely just on that flag. We therefore
 *  add a clause that enables all features when PV drivers are present using the
 *  old-style check.
 *  The "strict" param should be true for determining the allowed_operations list
 *  (which is advisory only) and false (more permissive) when we are potentially about
 *  to perform an operation. This makes a difference for ops that require the guest to
 *  react helpfully. *)
let check_op_for_feature ~__context ~vmr ~vmgmr ~power_state ~op ~ref ~strict =
  if power_state <> `Running ||
     (* PV guests offer support implicitly *)
     not (Helpers.has_booted_hvm_of_record ~__context vmr) ||
     Xapi_pv_driver_version.(has_pv_drivers (of_guest_metrics vmgmr)) (* Full PV drivers imply all features *)
  then None
  else
    let some_err e =
      Some (e, [ Ref.string_of ref ])
    in
    let lack_feature feature =
      not (has_feature ~vmgmr ~feature)
    in
    match op with
    | `clean_shutdown
      when strict && lack_feature "feature-shutdown" && lack_feature "feature-poweroff"
      -> some_err Api_errors.vm_lacks_feature
    | `clean_reboot
      when strict && lack_feature "feature-shutdown" && lack_feature "feature-reboot"
      -> some_err Api_errors.vm_lacks_feature
    | `changing_VCPUs_live
      when lack_feature "feature-vcpu-hotplug"
      -> some_err Api_errors.vm_lacks_feature
    | `suspend | `checkpoint | `pool_migrate | `migrate_send
      when strict && lack_feature "feature-suspend"
      -> some_err Api_errors.vm_lacks_feature
    | _ -> None
(* N.B. In the pattern matching above, "pat1 | pat2 | pat3" counts as
   	 * one pattern, and the whole thing can be guarded by a "when" clause. *)

(* templates support clone operations, destroy and cross-pool migrate (if not default),
   export, provision, and memory settings change *)
let check_template ~vmr ~op ~ref_str =
  let default_template =
    vmr.Db_actions.vM_is_default_template ||
    bool_of_assoc Xapi_globs.default_template_key vmr.Db_actions.vM_other_config in
  let allowed_operations = [
    `changing_dynamic_range;
    `changing_static_range;
    `changing_memory_limits;
    `changing_shadow_memory;
    `changing_VCPUs;
    `clone;
    `copy;
    `export;
    `metadata_export;
    `provision;
  ] in
  if false
  || List.mem op allowed_operations
  || ((op = `destroy || op = `migrate_send) && not default_template)
  then None
  else Some (Api_errors.vm_is_template, [ref_str; Record_util.vm_operation_to_string op])

let check_snapshot ~vmr ~op ~ref_str =
  let allowed = [`revert; `clone; `copy; `export; `destroy; `hard_shutdown; `metadata_export] in
  if List.mem op allowed
  then None
  else Some (Api_errors.vm_is_snapshot, [ref_str; Record_util.vm_operation_to_string op])

(* report a power_state/operation error *)
let report_power_state_error ~__context ~vmr ~power_state ~op ~ref_str =
  let expected = allowed_power_states ~__context ~vmr ~op in
  let expected = String.concat ", " (List.map Record_util.power_to_string expected) in
  let actual = Record_util.power_to_string power_state in
  Some (Api_errors.vm_bad_power_state, [ref_str; expected; actual])

let report_concurrent_operations_error ~current_ops ~ref_str =
  let current_ops_str =
    match current_ops with
    | [] -> failwith "No concurrent operation to report"
    | [_,cop] -> Record_util.vm_operation_to_string cop
    | l -> "{" ^ (String.concat "," (List.map Record_util.vm_operation_to_string (List.map snd l))) ^ "}"
  in
  Some (Api_errors.other_operation_in_progress,["VM." ^ current_ops_str; ref_str])

(* Suspending, checkpointing and live-migrating are not (yet) allowed if a PCI device is passed through *)
let check_pci ~op ~ref_str =
  match op with
  | `suspend | `checkpoint | `pool_migrate | `migrate_send -> Some (Api_errors.vm_has_pci_attached, [ref_str])
  | _ -> None

let check_vgpu ~__context ~op ~ref_str ~vgpus =
  match op with
  | `suspend | `pool_migrate -> begin
      let all_nvidia_vgpus =
        List.fold_left
          (fun acc vgpu ->
             let vgpu_type = Db.VGPU.get_type ~__context ~self:vgpu in
             let implementation =
               Db.VGPU_type.get_implementation ~__context ~self:vgpu_type in
             acc && (implementation = `nvidia))
          true vgpus
      in
      if all_nvidia_vgpus && (Xapi_fist.allow_nvidia_vgpu_migration ())
      then None
      else Some (Api_errors.vm_has_vgpu, [ref_str])
    end
  | `checkpoint | `migrate_send -> Some (Api_errors.vm_has_vgpu, [ref_str])
  | _ -> None

(* VM cannot be converted into a template while it is a member of an appliance. *)
let check_appliance ~vmr ~op ~ref_str =
  match op with
  | `make_into_template -> Some (Api_errors.vm_is_part_of_an_appliance,
                                 [ref_str; Ref.string_of vmr.Db_actions.vM_appliance])
  | _ -> None

(* VM cannot be converted into a template while it is assigned to a protection policy. *)
let check_protection_policy ~vmr ~op ~ref_str =
  match op with
  | `make_into_template -> Some (Api_errors.vm_assigned_to_protection_policy,
                                 [ref_str; Ref.string_of vmr.Db_actions.vM_protection_policy])
  | _ -> None

(* VM cannot be converted into a template while it is assigned to a snapshot schedule. *)
let check_snapshot_schedule ~vmr ~ref_str = function
  | `make_into_template -> Some (Api_errors.vm_assigned_to_snapshot_schedule,
                                 [ref_str; Ref.string_of vmr.Db_actions.vM_snapshot_schedule])
  | _ -> None

(** Some VMs can't migrate. The predicate [is_mobile] is true, if and
 * only if a VM is mobile.
 *
 * A VM is not mobile if any following values are true:
 * [platform:nomigrate] or [platform:nested-virt].  A VM can always
 * migrate if strict=false.
 *
 * The values of [platform:nomigrate] and [platform:nested-virt] are
 * captured by Xenopsd when a VM starts, reported to Xapi, and kept in
 * the VM_metrics data model.
 *
 * If the VM_metrics object does not exist, it implies the VM is not
 * running - in which case we use the current values from the database.
 **)

let nomigrate ~__context vm metrics =
  try
    Db.VM_metrics.get_nomigrate ~__context ~self:metrics
  with _ ->
    let platformdata = Db.VM.get_platform ~__context ~self:vm in
    let key = "nomigrate" in
    Vm_platform.is_true ~key ~platformdata ~default:false

let nested_virt ~__context vm metrics =
  try
    Db.VM_metrics.get_nested_virt ~__context ~self:metrics
  with _ ->
    let platformdata = Db.VM.get_platform ~__context ~self:vm in
    let key = "nested-virt" in
    Vm_platform.is_true ~key ~platformdata ~default:false

let is_mobile ~__context vm strict =
  let metrics = Db.VM.get_metrics ~__context ~self:vm in
  (not @@ nomigrate ~__context vm metrics
   && not @@ nested_virt ~__context vm metrics)
  || not strict

let maybe_get_guest_metrics ~__context ~ref =
  if Db.is_valid_ref __context ref
  then Some (Db.VM_guest_metrics.get_record_internal ~__context ~self:ref)
  else None

(** Take an internal VM record and a proposed operation. Return None iff the operation
    would be acceptable; otherwise Some (Api_errors.<something>, [list of strings])
    corresponding to the first error found. Checking stops at the first error.
    The "strict" param sets whether we require feature-flags for ops that need guest
    support: ops in the suspend-like and shutdown-like categories. *)
let check_operation_error ~__context ~ref =
  let vmr = Db.VM.get_record_internal ~__context ~self:ref in
  let vmgmr = maybe_get_guest_metrics ~__context ~ref:(vmr.Db_actions.vM_guest_metrics) in
  let ref_str = Ref.string_of ref in
  let power_state = vmr.Db_actions.vM_power_state in
  let is_template = vmr.Db_actions.vM_is_a_template in
  let is_snapshot = vmr.Db_actions.vM_is_a_snapshot in
  let vdis = List.filter_map (fun vbd -> try Some (Db.VBD.get_VDI ~__context ~self:vbd) with _ -> None) vmr.Db_actions.vM_VBDs |> List.filter (Db.is_valid_ref __context) in

  (fun ~op ~strict ->

  (* Check if the operation has been explicitly blocked by the/a user *)
  let current_error = None in

  let check c f = match c with | Some e -> Some e | None -> f () in

  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 ~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
      | `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<commit_msg>CA-269596: Restrict vm checkpoint operation<commit_after>(*
 * Copyright (C) 2006-2009 Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)
(** Helper functions relating to VM lifecycle operations.
 * @group Virtual-Machine Management
*)

open Stdext
open Listext

module D = Debug.Make(struct let name="xapi" end)
open D

module Rrdd = Rrd_client.Client

let all_vm_operations =
  [ `assert_operation_valid
  ; `awaiting_memory_live
  ; `call_plugin
  ; `changing_VCPUs
  ; `changing_VCPUs_live
  ; `changing_dynamic_range
  ; `changing_memory_limits
  ; `changing_memory_live
  ; `changing_shadow_memory
  ; `changing_shadow_memory_live
  ; `changing_static_range
  ; `checkpoint
  ; `clean_reboot
  ; `clean_shutdown
  ; `clone
  ; `copy
  ; `create_template
  ; `csvm
  ; `data_source_op
  ; `destroy
  ; `export
  ; `get_boot_record
  ; `hard_reboot
  ; `hard_shutdown
  ; `import
  ; `make_into_template
  ; `metadata_export
  ; `migrate_send
  ; `pause
  ; `pool_migrate
  ; `power_state_reset
  ; `provision
  ; `query_services
  ; `resume
  ; `resume_on
  ; `revert
  ; `reverting
  ; `send_sysrq
  ; `send_trigger
  ; `shutdown
  ; `snapshot
  ; `snapshot_with_quiesce
  ; `start
  ; `start_on
  ; `suspend
  ; `unpause
  ; `update_allowed_operations
  ]

let assoc_opt key assocs = Opt.of_exception (fun () -> List.assoc key assocs)
let bool_of_assoc key assocs = match assoc_opt key assocs with
  | Some v -> v = "1" || String.lowercase v = "true"
  | _ -> false

(** Given an operation, [allowed_power_states] returns all the possible power state for
    	wich this operation can be performed. *)
let allowed_power_states ~__context ~vmr ~(op:API.vm_operations) =
  let all_power_states =
    [`Halted; `Paused; `Suspended; `Running] in
  match op with
  (* a VM.import is done on file and not on VMs, so there is not power-state there! *)
  | `import
    -> []
  | `changing_VCPUs
  | `changing_static_range
  | `changing_memory_limits       -> `Halted :: (if vmr.Db_actions.vM_is_control_domain then [`Running] else [])
  | `changing_shadow_memory
  | `make_into_template
  | `provision
  | `start
  | `start_on
    -> [`Halted]
  | `unpause
    -> [`Paused]
  | `csvm
  | `resume
  | `resume_on
    -> [`Suspended]
  | `awaiting_memory_live
  | `call_plugin
  | `clean_reboot
  | `clean_shutdown
  | `changing_memory_live
  | `changing_shadow_memory_live
  | `changing_VCPUs_live
  | `data_source_op
  | `pause
  | `pool_migrate
  | `send_sysrq
  | `send_trigger
  | `snapshot_with_quiesce
  | `suspend
    -> [`Running]
  | `changing_dynamic_range
    -> [`Halted; `Running]
  | `clone
  | `copy
    -> `Halted :: (if vmr.Db_actions.vM_is_a_snapshot || Helpers.clone_suspended_vm_enabled ~__context then [`Suspended] else [])
  | `create_template (* Don't touch until XMLRPC unmarshal code is able to pre-blank fields on input. *)
  | `destroy
  | `export
    -> [`Halted; `Suspended]
  | `hard_reboot
    -> [`Paused; `Running]
  | `checkpoint
  | `get_boot_record
  | `shutdown
  | `hard_shutdown
    -> [`Paused; `Suspended; `Running]
  | `migrate_send
    -> [`Halted; `Suspended; `Running]
  | `assert_operation_valid
  | `metadata_export
  | `power_state_reset
  | `revert
  | `reverting
  | `snapshot
  | `update_allowed_operations
  | `query_services
    -> all_power_states

(** check if [op] can be done when [vmr] is in [power_state], when no other operation is in progress *)
let is_allowed_sequentially ~__context ~vmr ~power_state ~op =
  List.mem power_state (allowed_power_states ~__context ~vmr ~op)

(**	check if [op] can be done while [current_ops] are already in progress.
   	Remark: we do not test whether the power-state is valid. *)
let is_allowed_concurrently ~(op:API.vm_operations) ~current_ops =
  (* declare below the non-conflicting concurrent sets. *)
  let long_copies = [`clone; `copy; `export ]
  and boot_record = [`get_boot_record]
  and snapshot    = [`snapshot; `checkpoint]
  and allowed_operations = (* a list of valid state -> operation *)
    [ [`snapshot_with_quiesce], `snapshot;
      [`migrate_send],          `metadata_export;
      [`migrate_send],          `clean_shutdown;
      [`migrate_send],          `clean_reboot;
      [`migrate_send],          `start;
      [`migrate_send],          `start_on;
    ] in
  let state_machine () =
    let current_state = List.map snd current_ops in
    match op with
    | `hard_shutdown
      -> not (List.mem op current_state)
    | `hard_reboot -> not (List.exists
                             (fun o -> List.mem o [`hard_shutdown; `hard_reboot]) current_state)
    | _ -> List.exists (fun (state, transition) ->
        state = current_state && transition = op) allowed_operations
  in
  let aux ops =
    List.mem op ops && List.for_all (fun (_,o) -> List.mem o ops) current_ops
  in
  aux long_copies || aux snapshot || aux boot_record || state_machine ()

(** True iff the vm guest metrics "other" field includes (feature, "1")
    	as a key-value pair. *)
let has_feature ~vmgmr ~feature =
  match vmgmr with
  | None -> false
  | Some gmr ->
    let other = gmr.Db_actions.vM_guest_metrics_other in
    try
      List.assoc feature other = "1"
    with Not_found -> false

(** Return an error iff vmr is an HVM guest and lacks a needed feature.
 *  Note: it turned out that the Windows guest agent does not write "feature-suspend"
 *  on resume (only on startup), so we cannot rely just on that flag. We therefore
 *  add a clause that enables all features when PV drivers are present using the
 *  old-style check.
 *  The "strict" param should be true for determining the allowed_operations list
 *  (which is advisory only) and false (more permissive) when we are potentially about
 *  to perform an operation. This makes a difference for ops that require the guest to
 *  react helpfully. *)
let check_op_for_feature ~__context ~vmr ~vmgmr ~power_state ~op ~ref ~strict =
  if power_state <> `Running ||
     (* PV guests offer support implicitly *)
     not (Helpers.has_booted_hvm_of_record ~__context vmr) ||
     Xapi_pv_driver_version.(has_pv_drivers (of_guest_metrics vmgmr)) (* Full PV drivers imply all features *)
  then None
  else
    let some_err e =
      Some (e, [ Ref.string_of ref ])
    in
    let lack_feature feature =
      not (has_feature ~vmgmr ~feature)
    in
    match op with
    | `clean_shutdown
      when strict && lack_feature "feature-shutdown" && lack_feature "feature-poweroff"
      -> some_err Api_errors.vm_lacks_feature
    | `clean_reboot
      when strict && lack_feature "feature-shutdown" && lack_feature "feature-reboot"
      -> some_err Api_errors.vm_lacks_feature
    | `changing_VCPUs_live
      when lack_feature "feature-vcpu-hotplug"
      -> some_err Api_errors.vm_lacks_feature
    | `suspend | `checkpoint | `pool_migrate | `migrate_send
      when strict && lack_feature "feature-suspend"
      -> some_err Api_errors.vm_lacks_feature
    | _ -> None
(* N.B. In the pattern matching above, "pat1 | pat2 | pat3" counts as
   	 * one pattern, and the whole thing can be guarded by a "when" clause. *)

(* templates support clone operations, destroy and cross-pool migrate (if not default),
   export, provision, and memory settings change *)
let check_template ~vmr ~op ~ref_str =
  let default_template =
    vmr.Db_actions.vM_is_default_template ||
    bool_of_assoc Xapi_globs.default_template_key vmr.Db_actions.vM_other_config in
  let allowed_operations = [
    `changing_dynamic_range;
    `changing_static_range;
    `changing_memory_limits;
    `changing_shadow_memory;
    `changing_VCPUs;
    `clone;
    `copy;
    `export;
    `metadata_export;
    `provision;
  ] in
  if false
  || List.mem op allowed_operations
  || ((op = `destroy || op = `migrate_send) && not default_template)
  then None
  else Some (Api_errors.vm_is_template, [ref_str; Record_util.vm_operation_to_string op])

let check_snapshot ~vmr ~op ~ref_str =
  let allowed = [`revert; `clone; `copy; `export; `destroy; `hard_shutdown; `metadata_export] in
  if List.mem op allowed
  then None
  else Some (Api_errors.vm_is_snapshot, [ref_str; Record_util.vm_operation_to_string op])

(* report a power_state/operation error *)
let report_power_state_error ~__context ~vmr ~power_state ~op ~ref_str =
  let expected = allowed_power_states ~__context ~vmr ~op in
  let expected = String.concat ", " (List.map Record_util.power_to_string expected) in
  let actual = Record_util.power_to_string power_state in
  Some (Api_errors.vm_bad_power_state, [ref_str; expected; actual])

let report_concurrent_operations_error ~current_ops ~ref_str =
  let current_ops_str =
    match current_ops with
    | [] -> failwith "No concurrent operation to report"
    | [_,cop] -> Record_util.vm_operation_to_string cop
    | l -> "{" ^ (String.concat "," (List.map Record_util.vm_operation_to_string (List.map snd l))) ^ "}"
  in
  Some (Api_errors.other_operation_in_progress,["VM." ^ current_ops_str; ref_str])

(* Suspending, checkpointing and live-migrating are not (yet) allowed if a PCI device is passed through *)
let check_pci ~op ~ref_str =
  match op with
  | `suspend | `checkpoint | `pool_migrate | `migrate_send -> Some (Api_errors.vm_has_pci_attached, [ref_str])
  | _ -> None

let check_vgpu ~__context ~op ~ref_str ~vgpus =
  match op with
  | `suspend | `pool_migrate -> begin
      let all_nvidia_vgpus =
        List.fold_left
          (fun acc vgpu ->
             let vgpu_type = Db.VGPU.get_type ~__context ~self:vgpu in
             let implementation =
               Db.VGPU_type.get_implementation ~__context ~self:vgpu_type in
             acc && (implementation = `nvidia))
          true vgpus
      in
      if all_nvidia_vgpus && (Xapi_fist.allow_nvidia_vgpu_migration ())
      then None
      else Some (Api_errors.vm_has_vgpu, [ref_str])
    end
  | `checkpoint | `migrate_send -> Some (Api_errors.vm_has_vgpu, [ref_str])
  | _ -> None

(* VM cannot be converted into a template while it is a member of an appliance. *)
let check_appliance ~vmr ~op ~ref_str =
  match op with
  | `make_into_template -> Some (Api_errors.vm_is_part_of_an_appliance,
                                 [ref_str; Ref.string_of vmr.Db_actions.vM_appliance])
  | _ -> None

(* VM cannot be converted into a template while it is assigned to a protection policy. *)
let check_protection_policy ~vmr ~op ~ref_str =
  match op with
  | `make_into_template -> Some (Api_errors.vm_assigned_to_protection_policy,
                                 [ref_str; Ref.string_of vmr.Db_actions.vM_protection_policy])
  | _ -> None

(* VM cannot be converted into a template while it is assigned to a snapshot schedule. *)
let check_snapshot_schedule ~vmr ~ref_str = function
  | `make_into_template -> Some (Api_errors.vm_assigned_to_snapshot_schedule,
                                 [ref_str; Ref.string_of vmr.Db_actions.vM_snapshot_schedule])
  | _ -> None

(** Some VMs can't migrate. The predicate [is_mobile] is true, if and
 * only if a VM is mobile.
 *
 * A VM is not mobile if any following values are true:
 * [platform:nomigrate] or [platform:nested-virt].  A VM can always
 * migrate if strict=false.
 *
 * The values of [platform:nomigrate] and [platform:nested-virt] are
 * captured by Xenopsd when a VM starts, reported to Xapi, and kept in
 * the VM_metrics data model.
 *
 * If the VM_metrics object does not exist, it implies the VM is not
 * running - in which case we use the current values from the database.
 **)

let nomigrate ~__context vm metrics =
  try
    Db.VM_metrics.get_nomigrate ~__context ~self:metrics
  with _ ->
    let platformdata = Db.VM.get_platform ~__context ~self:vm in
    let key = "nomigrate" in
    Vm_platform.is_true ~key ~platformdata ~default:false

let nested_virt ~__context vm metrics =
  try
    Db.VM_metrics.get_nested_virt ~__context ~self:metrics
  with _ ->
    let platformdata = Db.VM.get_platform ~__context ~self:vm in
    let key = "nested-virt" in
    Vm_platform.is_true ~key ~platformdata ~default:false

let is_mobile ~__context vm strict =
  let metrics = Db.VM.get_metrics ~__context ~self:vm in
  (not @@ nomigrate ~__context vm metrics
   && not @@ nested_virt ~__context vm metrics)
  || not strict

let maybe_get_guest_metrics ~__context ~ref =
  if Db.is_valid_ref __context ref
  then Some (Db.VM_guest_metrics.get_record_internal ~__context ~self:ref)
  else None

(** Take an internal VM record and a proposed operation. Return None iff the operation
    would be acceptable; otherwise Some (Api_errors.<something>, [list of strings])
    corresponding to the first error found. Checking stops at the first error.
    The "strict" param sets whether we require feature-flags for ops that need guest
    support: ops in the suspend-like and shutdown-like categories. *)
let check_operation_error ~__context ~ref =
  let vmr = Db.VM.get_record_internal ~__context ~self:ref in
  let vmgmr = maybe_get_guest_metrics ~__context ~ref:(vmr.Db_actions.vM_guest_metrics) in
  let ref_str = Ref.string_of ref in
  let power_state = vmr.Db_actions.vM_power_state in
  let is_template = vmr.Db_actions.vM_is_a_template in
  let is_snapshot = vmr.Db_actions.vM_is_a_snapshot in
  let vdis = List.filter_map (fun vbd -> try Some (Db.VBD.get_VDI ~__context ~self:vbd) with _ -> None) vmr.Db_actions.vM_VBDs |> List.filter (Db.is_valid_ref __context) in

  (fun ~op ~strict ->

  (* Check if the operation has been explicitly blocked by the/a user *)
  let current_error = None in

  let check c f = match c with | Some e -> Some e | None -> f () in

  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 ~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
{'fraction_non_alphanumeric': 0.09445764437763662, 'fraction_numerical': 0.0010667701110410707, 'mean_word_length': 3.2876299376299376, 'pattern_counts': {'":': 0, '<': 37, '<?xml version=': 0, '>': 203, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1532734', 'n_tokens_mistral': 13425, 'n_tokens_neox': 13280, 'n_words': 4010}