diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 0d85c59c383..dec4839bab6 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -23,6 +23,14 @@ module D = Debug.Make (struct let name = "xenops_server" end) open D +let internal_error fmt = + Printf.kprintf + (fun str -> + error "%s" str ; + raise (Xenopsd_error (Internal_error str)) + ) + fmt + let rpc_of ty x = Rpcmarshal.marshal ty.Rpc.Types.ty x let finally = Xapi_stdext_pervasives.Pervasiveext.finally @@ -89,9 +97,6 @@ let filter_prefix prefix xs = ) xs -let internal_error fmt = - Printf.kprintf (fun msg -> raise (Xenopsd_error (Internal_error msg))) fmt - (* return last/element/in/a/path *) let basename path = match Astring.String.cut ~sep:"/" ~rev:true path with @@ -647,10 +652,7 @@ module VGPU_DB = struct | [a; b] -> (a, b) | _ -> - raise - (Xenopsd_error - (Internal_error ("String cannot be interpreted as vgpu id: " ^ str)) - ) + internal_error "String cannot be interpreted as vgpu id: %s" str let ids vm : Vgpu.id list = list [vm] |> filter_prefix "vgpu." |> List.map (fun id -> (vm, id)) @@ -1879,10 +1881,7 @@ let rec perform_atomic ~progress_callback ?subtask:_ ?result (op : atomic) | Ok x -> Xenopsd_error x | Error (`Msg x) -> - Xenopsd_error - (Internal_error - (Printf.sprintf "Error unmarshalling failure: %s" x) - ) + internal_error "Error unmarshalling failure: %s" x in Some e | None | Some (Task.Pending _) -> @@ -2407,10 +2406,7 @@ let rec immediate_operation dbg _id op = | Ok e -> raise (Xenopsd_error e) | Error (`Msg m) -> - raise - (Xenopsd_error - (Internal_error (Printf.sprintf "Failed to unmarshal error: %s" m)) - ) + internal_error "Failed to unmarshal error: %s" m ) (* At all times we ensure that an operation which partially fails leaves the @@ -2731,10 +2727,9 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) the destination host. even though the destination host failed to respond successfully to our handshake, the VM should still be running correctly *) - error + internal_error "VM.migrate: Failed during Synchronisation point 4. msg: %s" - msg ; - raise (Xenopsd_error (Internal_error msg)) + msg in let save ?vgpu_fd () = let url = make_url "/migrate/mem/" new_dest_id in @@ -3510,10 +3505,7 @@ module VM = struct | Ok e -> Xenopsd_error e | Error (`Msg m) -> - Xenopsd_error - (Internal_error - (Printf.sprintf "Error unmarshalling error: %s" m) - ) + internal_error "Error unmarshalling error: %s" m in raise e | Task.Pending _ -> @@ -3681,12 +3673,7 @@ module VM = struct | Some (_, vgpu_id_str) -> vgpu_id_str | None -> - raise - (Xenopsd_error - (Internal_error - ("Could not retrieve vgpu id from path " ^ path) - ) - ) + internal_error "Could not retrieve vgpu id from path %s" path in let vgpu_id = VGPU_DB.id_of_string vgpu_id_str in debug "VM.receive_vgpu vgpu_id_str = %s" vgpu_id_str ; @@ -3783,12 +3770,7 @@ module VM = struct | Ok md -> md | Error (`Msg m) -> - raise - (Xenopsd_error - (Internal_error - (Printf.sprintf "Unable to unmarshal metadata: %s" m) - ) - ) + internal_error "Unable to unmarshal metadata: %s" m in (md.Metadata.vm.Vm.id, md) diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 31c3f97c42c..a4cdb77686d 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -30,6 +30,14 @@ let finally = Xapi_stdext_pervasives.Pervasiveext.finally let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute +let internal_error fmt = + Printf.kprintf + (fun str -> + error "%s" str ; + raise (Xenopsd_error (Internal_error str)) + ) + fmt + (* libxl_internal.h:DISABLE_UDEV_PATH *) let disable_udev_path = "libxl/disable_udev" @@ -247,14 +255,9 @@ let di_of_uuid ~xc uuid = | possible -> let domid_list = String.concat ", " (List.map domid_of_di possible) in let uuid' = Uuidx.to_string uuid in - let err_msg = - Printf.sprintf "More than one domain with uuid %s: (%s)" uuid' - domid_list - in - error "%s: %s" __FUNCTION__ err_msg ; - raise (Xenopsd_error (Internal_error err_msg)) + internal_error "More than one domain with uuid %s: (%s)" uuid' domid_list | exception Failure r -> - raise (Xenopsd_error (Internal_error r)) + internal_error "%s" r let domid_of_uuid ~xs uuid = (* We don't fully control the domain lifecycle because libxenguest will @@ -296,11 +299,8 @@ let params_of_backend backend = else ("backend-kind", backend_kind) :: xenstore_data | [] -> - let err_msg = - Printf.sprintf "Could not find XenDisk implementation: %s" - (Storage_interface.(rpc_of backend) backend |> Jsonrpc.to_string) - in - raise (Xenopsd_error (Internal_error err_msg)) + internal_error "Could not find XenDisk implementation: %s" + (Storage_interface.(rpc_of backend) backend |> Jsonrpc.to_string) in let params, extra_keys = match (blockdevs, files, nbds, xendisks) with @@ -311,12 +311,9 @@ let params_of_backend backend = | _, _, _, xendisk :: _ -> ("", [("qemu-params", xendisk.Storage_interface.params)]) | _ -> - let err_msg = - Printf.sprintf - "Could not find BlockDevice, File, or Nbd implementation: %s" - (Storage_interface.(rpc_of backend) backend |> Jsonrpc.to_string) - in - raise (Xenopsd_error (Internal_error err_msg)) + internal_error + "Could not find BlockDevice, File, or Nbd implementation: %s" + (Storage_interface.(rpc_of backend) backend |> Jsonrpc.to_string) in (params, xenstore_data, extra_keys) @@ -340,14 +337,11 @@ let create_vbd_frontend ~xc ~xs task frontend_domid vdi = | _, _, nbd :: _ -> Nbd nbd | [], [], [] -> - let err_msg = - Printf.sprintf - "Could not find BlockDevice, File, or Nbd implementation: %s" - (Storage_interface.(rpc_of backend) vdi.attach_info - |> Jsonrpc.to_string - ) - in - raise (Xenopsd_error (Internal_error err_msg)) + internal_error + "Could not find BlockDevice, File, or Nbd implementation: %s" + (Storage_interface.(rpc_of backend) vdi.attach_info + |> Jsonrpc.to_string + ) ) | Some backend_domid -> let params, xenstore_data, extra_keys = @@ -904,16 +898,8 @@ let debug_featuresets name featureset featureset_max = let ours_minus_max = Featureset.diff featureset featureset_max in if not @@ Array.for_all (fun x -> Int64.equal x 0L) ours_minus_max then ( debug "%s (DynamicSet - Max) = %a" name Featureset.pp ours_minus_max ; - error - "Our default policy has CPUID features that are not present in Max \ - policy! (see above)" ; - raise - (Xenopsd_error - (Internal_error - "CPUID default policy has features that are not present in Max \ - policy!" - ) - ) + internal_error + "CPUID default policy has features that are not present in Max policy!" ) ; debug "%s (Max - Default) = %a" name Featureset.pp (Featureset.diff featureset_max featureset) @@ -1899,14 +1885,11 @@ module VM = struct | IGD_passthrough GVT_d, [] -> Device.Dm.GVT_d | Vgpu, [] -> - raise - (Xenopsd_error - (Internal_error "Vgpu mode specified but no vGPUs") - ) + internal_error "Vgpu mode specified but no vGPUs" | Vgpu, vgpus -> Device.Dm.Vgpu vgpus | _ -> - raise (Xenopsd_error (Internal_error "Invalid graphics mode")) + internal_error "Invalid graphics mode" in let memory = (* This is the same as is passed to xenguest at build time, with @@ -2265,27 +2248,15 @@ module VM = struct force with | Bootloader.Bad_sexpr x -> - let m = - Printf.sprintf "VM = %s; domid = %d; Bootloader.Bad_sexpr %s" - vm.Vm.id domid x - in - debug "%s" m ; - raise (Xenopsd_error (Internal_error m)) + internal_error "VM = %s; domid = %d; Bootloader.Bad_sexpr %s" + vm.Vm.id domid x | Bootloader.Bad_error x -> - let m = - Printf.sprintf "VM = %s; domid = %d; Bootloader.Bad_error %s" - vm.Vm.id domid x - in - debug "%s" m ; - raise (Xenopsd_error (Internal_error m)) + internal_error "VM = %s; domid = %d; Bootloader.Bad_error %s" + vm.Vm.id domid x | Bootloader.Unknown_bootloader x -> - let m = - Printf.sprintf - "VM = %s; domid = %d; Bootloader.Unknown_bootloader %s" vm.Vm.id - domid x - in - debug "%s" m ; - raise (Xenopsd_error (Internal_error m)) + internal_error + "VM = %s; domid = %d; Bootloader.Unknown_bootloader %s" vm.Vm.id + domid x | Bootloader.Error_from_bootloader x -> let m = Printf.sprintf @@ -2623,14 +2594,7 @@ module VM = struct | Ok x -> x | Error (`Msg m) -> - raise - (Xenopsd_error - (Internal_error - (Printf.sprintf - "Failed to unmarshal VBD backend: %s" m - ) - ) - ) + internal_error "Failed to unmarshal VBD backend: %s" m in let dp = Device.Generic.get_private_key ~xs device _dp_id in match backend with @@ -3288,12 +3252,7 @@ module VM = struct | Ok p -> p | Error (`Msg m) -> - raise - (Xenopsd_error - (Internal_error - (Printf.sprintf "Failed to unmarshal persistent_t: %s" m) - ) - ) + internal_error "Failed to unmarshal persistent_t: %s" m in (* Don't take the timeoffset from [state] (last boot record). Put back the one from [vm] which came straight from the platform keys. *) @@ -3439,14 +3398,12 @@ module PCI = struct () let dequarantine (pci : Pci.address) = - let fail msg = raise (Xenopsd_error (Internal_error msg)) in let addr = Pci.string_of_address pci in match Device.PCI.dequarantine pci with | true -> debug "PCI %s dequarantine - success" addr | false -> - error "PCI %s dequarantine - failed" addr ; - fail @@ Printf.sprintf "PCI %s dequarantine failed" addr + internal_error "PCI %s dequarantine - failed" addr end let set_active_device path active = @@ -3709,12 +3666,7 @@ module VBD = struct else Device_common.Vbd !Xenopsd.default_vbd_backend_kind | Some (Error (`Msg m)) -> - raise - (Xenopsd_error - (Internal_error - (Printf.sprintf "Error unmarshalling attached_vdi: %s" m) - ) - ) + internal_error "Error unmarshalling attached_vdi: %s" m let vdi_path_of_device ~xs device = Device_common.backend_path_of_device ~xs device ^ "/vdi" @@ -3908,14 +3860,7 @@ module VBD = struct | Ok x -> x | Error (`Msg m) -> - raise - (Xenopsd_error - (Internal_error - (Printf.sprintf "Failed to unmarshal VBD backend: %s" - m - ) - ) - ) + internal_error "Failed to unmarshal VBD backend: %s" m ) in Option.iter @@ -4105,12 +4050,7 @@ module VBD = struct | Ok d -> d | Error (`Msg m) -> - raise - (Xenopsd_error - (Internal_error - (Printf.sprintf "Failed to unmarshal disk: %s" m) - ) - ) + internal_error "Failed to unmarshal disk: %s" m ) in { @@ -4222,13 +4162,8 @@ module VIF = struct in enabled :: address :: gateway | Static4 ([], _) -> - raise - (Xenopsd_error - (Internal_error - "Static IPv4 configuration selected, but no address \ - specified." - ) - ) + internal_error + "Static IPv4 configuration selected, but no address specified." in let ipv6_setting = match vif.ipv6_configuration with @@ -4246,13 +4181,8 @@ module VIF = struct in enabled6 :: address6 :: gateway6 | Static6 ([], _) -> - raise - (Xenopsd_error - (Internal_error - "Static IPv6 configuration selected, but no address \ - specified." - ) - ) + internal_error + "Static IPv6 configuration selected, but no address specified." in let settings = constant_setting @ ipv4_setting @ ipv6_setting in List.map @@ -4638,13 +4568,8 @@ module VIF = struct | Static4 (address :: _, gateway) -> set_ip_static xs xenstore_path "" address gateway | Static4 ([], _) -> - raise - (Xenopsd_error - (Internal_error - "Static IPv4 configuration selected, but no address \ - specified." - ) - ) + internal_error + "Static IPv4 configuration selected, but no address specified." ) let set_ipv6_configuration _task vm vif ipv6_configuration = @@ -4661,13 +4586,8 @@ module VIF = struct | Static6 (address :: _, gateway) -> set_ip_static xs xenstore_path "6" address gateway | Static6 ([], _) -> - raise - (Xenopsd_error - (Internal_error - "Static IPv6 configuration selected, but no address \ - specified." - ) - ) + internal_error + "Static IPv6 configuration selected, but no address specified." ) let set_pvs_proxy _task vm vif proxy =