From 938bdb4d03fd2a991cb9ba1263005e283772a0bb Mon Sep 17 00:00:00 2001 From: Lin Liu Date: Fri, 21 Mar 2025 02:20:53 +0000 Subject: [PATCH 01/23] CA-408550: XSI-1834: Host netbios name should be added to local hosts file to avoid DNS lookup Without adding netbios name into /etc/hosts, a DNS query for localhost name is performed when talks to Domain Controller. This waste resources, especially when XenServer is monitorred by ControllUP, who perform external auth very frequently Adding netbios name into /etc/hosts to avoid the DNS query and keep consistent with PBIS Signed-off-by: Lin Liu --- ocaml/tests/test_extauth_plugin_ADwinbind.ml | 104 ++++++++++ ocaml/xapi/extauth_plugin_ADwinbind.ml | 204 +++++++++++++------ ocaml/xapi/extauth_plugin_ADwinbind.mli | 12 ++ ocaml/xapi/helpers.ml | 23 +++ 4 files changed, 281 insertions(+), 62 deletions(-) diff --git a/ocaml/tests/test_extauth_plugin_ADwinbind.ml b/ocaml/tests/test_extauth_plugin_ADwinbind.ml index a0180ee5e25..6babeda140c 100644 --- a/ocaml/tests/test_extauth_plugin_ADwinbind.ml +++ b/ocaml/tests/test_extauth_plugin_ADwinbind.ml @@ -499,6 +499,101 @@ let test_wbinfo_exception_of_stderr = in matrix |> List.map @@ fun (inp, exp) -> ("", `Quick, check inp exp) +let test_add_ipv4_localhost_to_hosts = + let open Extauth_plugin_ADwinbind in + let check inp exp () = + let msg = + Printf.sprintf "%s -> %s" (String.concat "\n" inp) (String.concat "\n" exp) + in + let actual = HostsConfIPv4.join "hostname" "domain" inp in + Alcotest.(check @@ list string) msg exp actual + in + let matrix = + [ + ( [ + "127.0.0.1 localhost localhost.localdomain localhost4 \ + localhost4.localdomain4" + ] + , [ + "127.0.0.1 localhost localhost.localdomain localhost4 \ + localhost4.localdomain4 hostname hostname.domain" + ] + ) + ; ( ["127.0.0.1 localhost hostname hostname.domain localhost.localdomain"] + , ["127.0.0.1 localhost localhost.localdomain hostname hostname.domain"] + ) + ; ( ["192.168.0.1 some_host"] + , ["127.0.0.1 hostname hostname.domain"; "192.168.0.1 some_host"] + ) + ; ([], ["127.0.0.1 hostname hostname.domain"]) + ] + in + matrix |> List.map @@ fun (inp, exp) -> ("", `Quick, check inp exp) + +let test_add_ipv4_and_ipv6_localhost_to_hosts = + let open Extauth_plugin_ADwinbind in + let check inp exp () = + let msg = + Printf.sprintf "%s -> %s" (String.concat "\n" inp) (String.concat "\n" exp) + in + let actual = + HostsConfIPv6.join "hostname" "domain" inp |> fun lines -> + HostsConfIPv4.join ~name:"hostname" ~domain:"domain" ~lines + in + Alcotest.(check @@ list string) msg exp actual + in + let matrix = + [ + ( ["127.0.0.1 localhost"] + , [ + "::1 hostname hostname.domain" + ; "127.0.0.1 localhost hostname hostname.domain" + ] + ) + ; ( ["127.0.0.1 localhost"; "::1 localhost"] + , [ + "127.0.0.1 localhost hostname hostname.domain" + ; "::1 localhost hostname hostname.domain" + ] + ) + ; ( [] + , ["127.0.0.1 hostname hostname.domain"; "::1 hostname hostname.domain"] + ) + ] + in + matrix |> List.map @@ fun (inp, exp) -> ("", `Quick, check inp exp) + +let test_remove_ipv4_localhost_from_hosts = + let open Extauth_plugin_ADwinbind in + let check inp exp () = + let msg = + Printf.sprintf "%s -> %s" (String.concat "\n" inp) (String.concat "\n" exp) + in + let actual = HostsConfIPv4.leave "hostname" "domain" inp in + Alcotest.(check @@ list string) msg exp actual + in + let matrix = + [ + ( [ + "127.0.0.1 localhost localhost.localdomain localhost4 \ + localhost4.localdomain4" + ] + , [ + "127.0.0.1 localhost localhost.localdomain localhost4 \ + localhost4.localdomain4" + ] + ) + ; ( ["127.0.0.1 localhost hostname hostname.domain localhost.localdomain"] + , ["127.0.0.1 localhost localhost.localdomain"] + ) + ; (["127.0.0.1 hostname hostname.domain"], []) + ; ( ["192.168.0.1 some_host"; "127.0.0.1 localhost hostname"] + , ["192.168.0.1 some_host"; "127.0.0.1 localhost"] + ) + ] + in + matrix |> List.map @@ fun (inp, exp) -> ("", `Quick, check inp exp) + let tests = [ ("ADwinbind:extract_ou_config", ExtractOuConfig.tests) @@ -512,4 +607,13 @@ let tests = ; ( "ADwinbind:test_wbinfo_exception_of_stderr" , test_wbinfo_exception_of_stderr ) + ; ( "ADwinbind:test_add_ipv4_localhost_to_hosts" + , test_add_ipv4_localhost_to_hosts + ) + ; ( "ADwinbind:test_remove_ipv4_localhost_from_hosts" + , test_remove_ipv4_localhost_from_hosts + ) + ; ( "ADwinbind:test_add_ipv4_and_ipv6_localhost_to_hosts" + , test_add_ipv4_and_ipv6_localhost_to_hosts + ) ] diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index 6f51eea9cc5..efc6ac9f1a0 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -828,48 +828,39 @@ let config_winbind_daemon ~workgroup ~netbios_name ~domain = let conf_contents = match (workgroup, netbios_name, domain) with | Some wkgroup, Some netbios, Some dom -> - String.concat "\n" - [ - "# auto-generated by xapi" - ; "[global]" - ; "kerberos method = secrets and keytab" - ; Printf.sprintf "realm = %s" dom - ; "security = ADS" - ; "template shell = /bin/bash" - ; "winbind refresh tickets = yes" - ; "winbind enum groups = no" - ; "winbind enum users = no" - ; "winbind scan trusted domains = yes" - ; "winbind use krb5 enterprise principals = yes" - ; Printf.sprintf "winbind cache time = %d" - !Xapi_globs.winbind_cache_time - ; Printf.sprintf "machine password timeout = 0" - ; Printf.sprintf "kerberos encryption types = %s" - (Kerberos_encryption_types.Winbind.to_string - !Xapi_globs.winbind_kerberos_encryption_type - ) - ; Printf.sprintf "workgroup = %s" wkgroup - ; Printf.sprintf "netbios name = %s" netbios - ; "idmap config * : range = 3000000-3999999" - ; Printf.sprintf "idmap config %s: backend = rid" dom - ; Printf.sprintf "idmap config %s: range = 2000000-2999999" dom - ; Printf.sprintf "log level = %s" (debug_level ()) - ; Printf.sprintf "allow kerberos auth fallback = %s" allow_fallback - ; "idmap config * : backend = tdb" - ; "" (* Empty line at the end *) - ] + [ + "# autogenerated by xapi" + ; "[global]" + ; "kerberos method = secrets and keytab" + ; Printf.sprintf "realm = %s" dom + ; "security = ADS" + ; "template shell = /bin/bash" + ; "winbind refresh tickets = yes" + ; "winbind enum groups = no" + ; "winbind enum users = no" + ; "winbind scan trusted domains = yes" + ; "winbind use krb5 enterprise principals = yes" + ; Printf.sprintf "winbind cache time = %d" + !Xapi_globs.winbind_cache_time + ; Printf.sprintf "machine password timeout = 0" + ; Printf.sprintf "kerberos encryption types = %s" + (Kerberos_encryption_types.Winbind.to_string + !Xapi_globs.winbind_kerberos_encryption_type + ) + ; Printf.sprintf "workgroup = %s" wkgroup + ; Printf.sprintf "netbios name = %s" netbios + ; "idmap config * : range = 3000000-3999999" + ; Printf.sprintf "idmap config %s: backend = rid" dom + ; Printf.sprintf "idmap config %s: range = 2000000-2999999" dom + ; Printf.sprintf "log level = %s" (debug_level ()) + ; Printf.sprintf "allow kerberos auth fallback = %s" allow_fallback + ; "idmap config * : backend = tdb" + ; "" (* Empty line at the end *) + ] | _ -> - String.concat "\n" - [ - "# autogenerated by xapi"; "[global]"; "" (* Empty line at the end *) - ] + ["# autogenerated by xapi"; "[global]"; "" (* Empty line at the end *)] in - - let len = String.length conf_contents in - Unixext.atomic_write_to_file smb_config 0o0644 (fun fd -> - let (_ : int) = Unix.single_write_substring fd conf_contents 0 len in - Unix.fsync fd - ) + Helpers.ListFile.to_path smb_config conf_contents let clear_winbind_config () = (* Keep the winbind configuration if xapi config file specified explictly, @@ -1222,27 +1213,21 @@ module RotateMachinePassword = struct in let conf_contents = - String.concat "\n" - ([ - "# auto-generated by xapi" - ; "[libdefaults]" - ; Printf.sprintf "default_realm = %s" realm - ; "[realms]" - ; Printf.sprintf "%s={" realm - ; Printf.sprintf "kpasswd_server=%s" kdc_fqdn - ; Printf.sprintf "kdc=%s" kdc_fqdn - ; "}" (* include winbind generated configure if exists *) - ] - @ include_item - @ [""] (* Empty line at the end *) - ) + [ + "# autogenerated by xapi" + ; "[libdefaults]" + ; Printf.sprintf "default_realm = %s" realm + ; "[realms]" + ; Printf.sprintf "%s={" realm + ; Printf.sprintf "kpasswd_server=%s" kdc_fqdn + ; Printf.sprintf "kdc=%s" kdc_fqdn + ; "}" (* include winbind generated configure if exists *) + ] + @ include_item + @ [""] + (* Empty line at the end *) in - - let len = String.length conf_contents in - Unixext.atomic_write_to_file tmp_krb5_conf 0o0644 (fun fd -> - let (_ : int) = Unix.single_write_substring fd conf_contents 0 len in - Unix.fsync fd - ) + Helpers.ListFile.to_path tmp_krb5_conf conf_contents let clear_tmp_krb5_conf () = if !Xapi_globs.winbind_keep_configuration then @@ -1307,6 +1292,83 @@ module RotateMachinePassword = struct let stop_rotate () = Scheduler.remove_from_queue task_name end +module type LocalHostTag = sig + val local_ip : string +end + +module HostsConfTagIPv4 : LocalHostTag = struct let local_ip = "127.0.0.1" end + +module HostsConfTagIPv6 : LocalHostTag = struct let local_ip = "::1" end + +module type HostsConf = sig + (* add the domain info into conf*) + val join : name:string -> domain:string -> lines:string list -> string list + + (* remove the domain info from conf*) + val leave : name:string -> domain:string -> lines:string list -> string list +end + +module HostsConfFunc (T : LocalHostTag) : HostsConf = struct + let sep = ' ' + + let sep_str = String.make 1 sep + + type t = Add | Remove + + let interest line = String.starts_with ~prefix:T.local_ip line + + let handle op name domain line = + let line = String.lowercase_ascii line in + let name = String.lowercase_ascii name in + let domain = String.lowercase_ascii domain in + let fqdn = Printf.sprintf "%s.%s" name domain in + match interest line with + | false -> + line + | true -> + String.split_on_char sep line + |> List.filter (fun x -> x <> name && x <> fqdn) + |> (fun x -> match op with Add -> x @ [name; fqdn] | Remove -> x) + |> String.concat sep_str + + let leave ~name ~domain ~lines = + List.map (fun line -> handle Remove name domain line) lines + (* If no name for local ip left, just remove it *) + |> List.filter (fun x -> String.trim x <> T.local_ip) + + let join ~name ~domain ~lines = + List.map (fun line -> handle Add name domain line) lines |> fun x -> + match List.exists (fun l -> interest l) x with + | true -> + x + | false -> + (* Does not found and updated the conf, then add one *) + [ + Printf.sprintf "%s%s%s%s%s.%s" T.local_ip sep_str name sep_str name + domain + ] + @ x +end + +module HostsConfIPv4 = HostsConfFunc (HostsConfTagIPv4) +module HostsConfIPv6 = HostsConfFunc (HostsConfTagIPv6) + +module ConfigHosts = struct + let path = "/etc/hosts" + + let join ~name ~domain = + Helpers.ListFile.of_path path + |> HostsConfIPv4.join ~name ~domain + |> HostsConfIPv6.join ~name ~domain + |> Helpers.ListFile.to_path path + + let leave ~name ~domain = + Helpers.ListFile.of_path path + |> HostsConfIPv4.leave ~name ~domain + |> HostsConfIPv6.leave ~name ~domain + |> Helpers.ListFile.to_path path +end + let build_netbios_name ~config_params = let key = "netbios-name" in match List.assoc_opt key config_params with @@ -1628,18 +1690,21 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct ~netbios_name:(Some netbios_name) ; ClosestKdc.trigger_update ~start:0. ; RotateMachinePassword.trigger_rotate ~start:0. ; + ConfigHosts.join ~domain:service_name ~name:netbios_name ; (* Trigger right now *) debug "Succeed to join domain %s" service_name with | Forkhelpers.Spawn_internal_error (_, stdout, _) -> error "Join domain: %s error: %s" service_name stdout ; clear_winbind_config () ; + ConfigHosts.leave ~domain:service_name ~name:netbios_name ; (* The configure is kept for debug purpose with max level *) raise (Auth_service_error (stdout |> tag_from_err_msg, stdout)) | Xapi_systemctl.Systemctl_fail _ -> let msg = Printf.sprintf "Failed to start %s" Winbind.name in error "Start daemon error: %s" msg ; config_winbind_daemon ~domain:None ~workgroup:None ~netbios_name:None ; + ConfigHosts.leave ~domain:service_name ~name:netbios_name ; raise (Auth_service_error (E_GENERIC, msg)) | e -> let msg = @@ -1650,6 +1715,7 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct in error "Enable extauth error: %s" msg ; clear_winbind_config () ; + ConfigHosts.leave ~domain:service_name ~name:netbios_name ; raise (Auth_service_error (E_GENERIC, msg)) (* unit on_disable() @@ -1663,7 +1729,14 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct let@ __context = Context.with_tracing ~__context __FUNCTION__ in let user = List.assoc_opt "user" config_params in let pass = List.assoc_opt "pass" config_params in - let {service_name; _} = get_domain_info_from_db () in + let {service_name; workgroup; netbios_name; _} = + get_domain_info_from_db () + in + ( if Option.is_some netbios_name then + Option.get netbios_name |> fun name -> + ConfigHosts.leave ~domain:service_name ~name + ) ; + (* Clean extauth config *) persist_extauth_config ~domain:None ~user:None ~ou_conf:[] ~workgroup:None ~machine_pwd_last_change_time:None ~netbios_name:None ; @@ -1688,7 +1761,14 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct Winbind.start ~timeout:5. ~wait_until_success:true ; ClosestKdc.trigger_update ~start:ClosestKdc.startup_delay ; RotateMachinePassword.trigger_rotate ~start:5. ; - Winbind.check_ready_to_serve ~timeout:300. + Winbind.check_ready_to_serve ~timeout:300. ; + + let {service_name; workgroup; netbios_name; _} = + get_domain_info_from_db () + in + if Option.is_some netbios_name then + Option.get netbios_name |> fun name -> + ConfigHosts.join ~domain:service_name ~name (* unit on_xapi_exit() diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.mli b/ocaml/xapi/extauth_plugin_ADwinbind.mli index 0c9137d5f54..dab3963fa1a 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.mli +++ b/ocaml/xapi/extauth_plugin_ADwinbind.mli @@ -75,3 +75,15 @@ module Migrate_from_pbis : sig val parse_value_from_pbis : string -> string end + +module type HostsConf = sig + (* add the domain info into conf*) + val join : name:string -> domain:string -> lines:string list -> string list + + (* remove the domain info from conf*) + val leave : name:string -> domain:string -> lines:string list -> string list +end + +module HostsConfIPv4 : HostsConf + +module HostsConfIPv6 : HostsConf diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 2ef16112053..b5c810d76c3 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -2360,3 +2360,26 @@ module AuthenticationCache = struct None end end + +module ListFile = struct + (* Read/Write List to/from file, line by line *) + let of_path path = + let ic = open_in path in + finally + (fun () -> + let rec read_lines acc = + try + let line = input_line ic in + read_lines (acc @ [line]) + with End_of_file -> acc + in + read_lines [] + ) + (fun () -> close_in ic) + + let to_path ?(perm = 0o0644) path contents = + String.concat "\n" contents |> fun x -> + Unixext.atomic_write_to_file path perm @@ fun fd -> + Unixext.really_write_string fd x |> ignore ; + Unix.fsync fd +end From f352a5629651bf427d8883952d62faf377f04d4b Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 11:11:08 +0000 Subject: [PATCH 02/23] CP-54020: Split the mux policy from storage_mux This split is so that this part can be used by storage_migrate later on for its own multiplexing logic, to avoid dependency cycle. Signed-off-by: Vincent Liu --- ocaml/tests/test_vdi_cbt.ml | 2 +- ocaml/xapi/storage_access.ml | 4 +- ocaml/xapi/storage_mux.ml | 108 ++--------------------------- ocaml/xapi/storage_mux_reg.ml | 120 +++++++++++++++++++++++++++++++++ ocaml/xapi/storage_mux_reg.mli | 57 ++++++++++++++++ 5 files changed, 186 insertions(+), 105 deletions(-) create mode 100644 ocaml/xapi/storage_mux_reg.ml create mode 100644 ocaml/xapi/storage_mux_reg.mli diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index 3137e0485cb..3253f21311a 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -33,7 +33,7 @@ let register_smapiv2_server (module S : Storage_interface.Server_impl) sr_ref = } in - Storage_mux.register sr_ref rpc "" dummy_query_result + Storage_mux_reg.register sr_ref rpc "" dummy_query_result let make_smapiv2_storage_server ?vdi_enable_cbt ?vdi_disable_cbt ?vdi_list_changed_blocks ?vdi_data_destroy ?vdi_snapshot ?vdi_clone:_ () = diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index d38cab783b5..65fa54fe73b 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -264,7 +264,7 @@ let bind ~__context ~pbd = let service = make_service uuid ty in System_domains.register_service service queue_name ; let info = Client.Query.query dbg in - Storage_mux.register (Storage_interface.Sr.of_string sr_uuid) rpc uuid info ; + Storage_mux_reg.register (Storage_interface.Sr.of_string sr_uuid) rpc uuid info ; info with e -> error @@ -281,7 +281,7 @@ let unbind ~__context ~pbd = let ty = Db.SR.get_type ~__context ~self:sr in let sr = Db.SR.get_uuid ~__context ~self:sr in info "SR %s will nolonger be implemented by VM %s" sr (Ref.string_of driver) ; - Storage_mux.unregister (Storage_interface.Sr.of_string sr) ; + Storage_mux_reg.unregister (Storage_interface.Sr.of_string sr) ; let service = make_service uuid ty in System_domains.unregister_service service diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 7acba0c8823..e502666f4a2 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -17,113 +17,17 @@ module Unixext = Xapi_stdext_unix.Unixext module D = Debug.Make (struct let name = "mux" end) open D - -let with_dbg ~name ~dbg f = - Debug_info.with_dbg ~with_thread:true ~module_name:"SMAPIv2" ~name ~dbg f - -type processor = Rpc.call -> Rpc.response - -let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute - open Storage_interface +open Storage_mux_reg -let s_of_sr = Sr.string_of - -let s_of_vdi = Vdi.string_of - -let s_of_vm = Vm.string_of - -type plugin = { - processor: processor - ; backend_domain: string - ; query_result: query_result - ; features: Smint.Feature.t list -} - -let plugins : (sr, plugin) Hashtbl.t = Hashtbl.create 10 - -let m = Mutex.create () - -let debug_printer rpc call = - (* debug "Rpc.call = %s" (Xmlrpc.string_of_call call); *) - let result = rpc call in - (* debug "Rpc.response = %s" (Xmlrpc.string_of_response result); *) - result - -let register sr rpc d info = - with_lock m (fun () -> - let features = - Smint.Feature.parse_capability_int64 info.Storage_interface.features - in - Hashtbl.replace plugins sr - { - processor= debug_printer rpc - ; backend_domain= d - ; query_result= info - ; features - } ; - debug "register SR %s (currently-registered = [ %s ])" (s_of_sr sr) - (String.concat ", " - (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) - ) - ) - -let unregister sr = - with_lock m (fun () -> - Hashtbl.remove plugins sr ; - debug "unregister SR %s (currently-registered = [ %s ])" (s_of_sr sr) - (String.concat ", " - (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) - ) - ) - -(* This function is entirely unused, but I am not sure if it should be - deleted or not *) -let query_result_of_sr sr = - with_lock m (fun () -> - Option.map (fun x -> x.query_result) (Hashtbl.find_opt plugins sr) - ) +let s_of_sr = Storage_interface.Sr.string_of -let sr_has_capability sr capability = - with_lock m (fun () -> - match Hashtbl.find_opt plugins sr with - | Some x -> - Smint.Feature.has_capability capability x.features - | None -> - false - ) +let s_of_vdi = Storage_interface.Vdi.string_of -(* This is the policy: *) -let of_sr sr = - with_lock m (fun () -> - match Hashtbl.find_opt plugins sr with - | Some x -> - x.processor - | None -> - error "No storage plugin for SR: %s (currently-registered = [ %s ])" - (s_of_sr sr) - (String.concat ", " - (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) - ) ; - raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) - ) - -type 'a sm_result = SMSuccess of 'a | SMFailure of exn - -let multicast f = - Hashtbl.fold - (fun sr plugin acc -> - (sr, try SMSuccess (f sr plugin.processor) with e -> SMFailure e) :: acc - ) - plugins [] +let s_of_vm = Storage_interface.Vm.string_of -let success = function SMSuccess _ -> true | _ -> false - -let string_of_sm_result f = function - | SMSuccess x -> - Printf.sprintf "Success: %s" (f x) - | SMFailure e -> - Printf.sprintf "Failure: %s" (Printexc.to_string e) +let with_dbg ~name ~dbg f = + Debug_info.with_dbg ~with_thread:true ~module_name:"SMAPIv2" ~name ~dbg f let partition l = List.partition (fun (_, x) -> success x) l diff --git a/ocaml/xapi/storage_mux_reg.ml b/ocaml/xapi/storage_mux_reg.ml new file mode 100644 index 00000000000..c3b13494c33 --- /dev/null +++ b/ocaml/xapi/storage_mux_reg.ml @@ -0,0 +1,120 @@ +(* + * Copyright (c) Cloud Software Group + * + * 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. + *) + +(** This module contains the code for registering storage plugins (SMAPIv1 and SMAPIv3) +and multiplexing between them according to the sr type *) + +module D = Debug.Make (struct let name = __MODULE__ end) + +open D + +type processor = Rpc.call -> Rpc.response + +let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute + +open Storage_interface + +let s_of_sr = Storage_interface.Sr.string_of + +type plugin = { + processor: processor + ; backend_domain: string + ; query_result: query_result + ; features: Smint.Feature.t list +} + +let plugins : (sr, plugin) Hashtbl.t = Hashtbl.create 10 + +let m = Mutex.create () + +let debug_printer rpc call = + (* debug "Rpc.call = %s" (Xmlrpc.string_of_call call); *) + let result = rpc call in + (* debug "Rpc.response = %s" (Xmlrpc.string_of_response result); *) + result + +let register sr rpc d info = + with_lock m (fun () -> + let features = + Smint.Feature.parse_capability_int64 info.Storage_interface.features + in + Hashtbl.replace plugins sr + { + processor= debug_printer rpc + ; backend_domain= d + ; query_result= info + ; features + } ; + debug "register SR %s (currently-registered = [ %s ])" (s_of_sr sr) + (String.concat ", " + (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) + ) + ) + +let unregister sr = + with_lock m (fun () -> + Hashtbl.remove plugins sr ; + debug "unregister SR %s (currently-registered = [ %s ])" (s_of_sr sr) + (String.concat ", " + (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) + ) + ) + +(* This function is entirely unused, but I am not sure if it should be + deleted or not *) +let query_result_of_sr sr = + with_lock m (fun () -> + Option.map (fun x -> x.query_result) (Hashtbl.find_opt plugins sr) + ) + +let sr_has_capability sr capability = + with_lock m (fun () -> + match Hashtbl.find_opt plugins sr with + | Some x -> + Smint.Feature.has_capability capability x.features + | None -> + false + ) + +(* This is the policy: *) +let of_sr sr = + with_lock m (fun () -> + match Hashtbl.find_opt plugins sr with + | Some x -> + x.processor + | None -> + error "No storage plugin for SR: %s (currently-registered = [ %s ])" + (s_of_sr sr) + (String.concat ", " + (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) + ) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) + ) + +type 'a sm_result = SMSuccess of 'a | SMFailure of exn + +let string_of_sm_result f = function + | SMSuccess x -> + Printf.sprintf "Success: %s" (f x) + | SMFailure e -> + Printf.sprintf "Failure: %s" (Printexc.to_string e) + +let success = function SMSuccess _ -> true | _ -> false + +let multicast f = + Hashtbl.fold + (fun sr plugin acc -> + (sr, try SMSuccess (f sr plugin.processor) with e -> SMFailure e) :: acc + ) + plugins [] diff --git a/ocaml/xapi/storage_mux_reg.mli b/ocaml/xapi/storage_mux_reg.mli new file mode 100644 index 00000000000..218cd5f96b3 --- /dev/null +++ b/ocaml/xapi/storage_mux_reg.mli @@ -0,0 +1,57 @@ +(* + * Copyright (c) Cloud Software Group + * + * 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. + *) + +type processor = Rpc.call -> Rpc.response + +val with_lock : Mutex.t -> (unit -> 'a) -> 'a + +type plugin = { + processor: processor + ; backend_domain: string + ; query_result: Storage_interface.query_result + ; features: Smint.Feature.t list +} + +val plugins : (Storage_interface.sr, plugin) Hashtbl.t + +val debug_printer : ('a -> 'b) -> 'a -> 'b + +val register : + Storage_interface.sr + -> (Rpc.call -> Rpc.response) + -> string + -> Storage_interface.query_result + -> unit + +val unregister : Storage_interface.sr -> unit + +val query_result_of_sr : + Storage_interface.sr -> Storage_interface.query_result option + +val sr_has_capability : Storage_interface.sr -> Smint.Feature.capability -> bool + +val of_sr : Storage_interface.sr -> processor + +val smapi_version_of_sr : + Storage_interface.sr -> Storage_interface.smapi_version + +type 'a sm_result = SMSuccess of 'a | SMFailure of exn + +val string_of_sm_result : ('a -> string) -> 'a sm_result -> string + +val success : 'a sm_result -> bool + +val multicast : + (Storage_interface.sr -> processor -> 'a) + -> (Storage_interface.sr * 'a sm_result) list From 4d9bc8caa70c3c0c5b346e7c73fa5274b2100ae2 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 11:22:38 +0000 Subject: [PATCH 03/23] CP-54020: Introduce `smapi_version` in query result This is then used later for storage_migrate to multiplex based on the SMAPI version. Signed-off-by: Vincent Liu --- ocaml/tests/test_sm_features.ml | 1 + ocaml/tests/test_vdi_cbt.ml | 1 + ocaml/xapi-idl/storage/storage_interface.ml | 4 ++++ ocaml/xapi-storage-script/main.ml | 1 + ocaml/xapi/sm_exec.ml | 1 + ocaml/xapi/smint.ml | 2 ++ ocaml/xapi/storage_access.ml | 4 +++- ocaml/xapi/storage_mux.ml | 1 + ocaml/xapi/storage_mux_reg.ml | 14 ++++++++++++++ ocaml/xapi/storage_smapiv1.ml | 1 + ocaml/xapi/xapi_services.ml | 1 + 11 files changed, 30 insertions(+), 1 deletion(-) diff --git a/ocaml/tests/test_sm_features.ml b/ocaml/tests/test_sm_features.ml index d7a63008882..6b7ef99502d 100644 --- a/ocaml/tests/test_sm_features.ml +++ b/ocaml/tests/test_sm_features.ml @@ -249,6 +249,7 @@ module CreateSMObject = Generic.MakeStateful (struct ; features ; configuration= [] ; required_cluster_stack= [] + ; smapi_version= SMAPIv2 } let extract_output __context _ = diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index 3253f21311a..54ae411ac97 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -30,6 +30,7 @@ let register_smapiv2_server (module S : Storage_interface.Server_impl) sr_ref = ; features= [] ; configuration= [] ; required_cluster_stack= [] + ; smapi_version= SMAPIv2 } in diff --git a/ocaml/xapi-idl/storage/storage_interface.ml b/ocaml/xapi-idl/storage/storage_interface.ml index 542312c6448..7dc5a8f82a9 100644 --- a/ocaml/xapi-idl/storage/storage_interface.ml +++ b/ocaml/xapi-idl/storage/storage_interface.ml @@ -404,6 +404,9 @@ let err = ) } +type smapi_version = SMAPIv1 | SMAPIv2 | SMAPIv3 +[@@deriving rpcty, show {with_path= false}] + type query_result = { driver: string ; name: string @@ -415,6 +418,7 @@ type query_result = { ; features: string list ; configuration: (string * string) list ; required_cluster_stack: string list + ; smapi_version: smapi_version } [@@deriving rpcty] diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 4b678fa72de..5910d65f28f 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -948,6 +948,7 @@ module QueryImpl (M : META) = struct ; configuration= response.Xapi_storage.Plugin.configuration ; required_cluster_stack= response.Xapi_storage.Plugin.required_cluster_stack + ; smapi_version= SMAPIv3 } in wrap th diff --git a/ocaml/xapi/sm_exec.ml b/ocaml/xapi/sm_exec.ml index 1da0c6c7e83..c4e2c46a1a9 100644 --- a/ocaml/xapi/sm_exec.ml +++ b/ocaml/xapi/sm_exec.ml @@ -582,6 +582,7 @@ let parse_sr_get_driver_info driver (xml : Xml.xml) = ; sr_driver_configuration= configuration ; sr_driver_text_features= text_features ; sr_driver_required_cluster_stack= [] + ; sr_smapi_version= SMAPIv1 } let sr_get_driver_info ~dbg driver = diff --git a/ocaml/xapi/smint.ml b/ocaml/xapi/smint.ml index a5809893c5f..e58340b5239 100644 --- a/ocaml/xapi/smint.ml +++ b/ocaml/xapi/smint.ml @@ -192,6 +192,7 @@ type sr_driver_info = { ; sr_driver_text_features: string list ; sr_driver_configuration: (string * string) list ; sr_driver_required_cluster_stack: string list + ; sr_smapi_version: Storage_interface.smapi_version } let query_result_of_sr_driver_info x = @@ -206,6 +207,7 @@ let query_result_of_sr_driver_info x = ; features= x.sr_driver_text_features ; configuration= x.sr_driver_configuration ; required_cluster_stack= x.sr_driver_required_cluster_stack + ; smapi_version= x.sr_smapi_version } type attach_info = { diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 65fa54fe73b..0aeed25125d 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -264,7 +264,9 @@ let bind ~__context ~pbd = let service = make_service uuid ty in System_domains.register_service service queue_name ; let info = Client.Query.query dbg in - Storage_mux_reg.register (Storage_interface.Sr.of_string sr_uuid) rpc uuid info ; + Storage_mux_reg.register + (Storage_interface.Sr.of_string sr_uuid) + rpc uuid info ; info with e -> error diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index e502666f4a2..e99ec3a3634 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -73,6 +73,7 @@ module Mux = struct ; features= [] ; configuration= [] ; required_cluster_stack= [] + ; smapi_version= SMAPIv2 } let diagnostics () ~dbg = diff --git a/ocaml/xapi/storage_mux_reg.ml b/ocaml/xapi/storage_mux_reg.ml index c3b13494c33..f7eff2ab43d 100644 --- a/ocaml/xapi/storage_mux_reg.ml +++ b/ocaml/xapi/storage_mux_reg.ml @@ -102,6 +102,20 @@ let of_sr sr = raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) ) +let smapi_version_of_sr sr = + with_lock m (fun () -> + match Hashtbl.find_opt plugins sr with + | Some x -> + x.query_result.smapi_version + | None -> + error "No storage plugin for SR: %s (currently-registered = [ %s ])" + (s_of_sr sr) + (String.concat ", " + (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) + ) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) + ) + type 'a sm_result = SMSuccess of 'a | SMFailure of exn let string_of_sm_result f = function diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index b71dea3d1c6..96da6ce4122 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -172,6 +172,7 @@ module SMAPIv1 : Server_impl = struct ; features= [] ; configuration= [] ; required_cluster_stack= [] + ; smapi_version= SMAPIv1 } let diagnostics _context ~dbg:_ = diff --git a/ocaml/xapi/xapi_services.ml b/ocaml/xapi/xapi_services.ml index a413e4c3630..21e3b8d0c3b 100644 --- a/ocaml/xapi/xapi_services.ml +++ b/ocaml/xapi/xapi_services.ml @@ -254,6 +254,7 @@ let get_handler (req : Http.Request.t) s _ = ; features= List.map (fun x -> path [_services; x]) [_SM] ; configuration= [] ; required_cluster_stack= [] + ; smapi_version= SMAPIv2 } in respond req (Storage_interface.(rpc_of query_result) q) s From a39009810871d9600cb6c8c7279d8e4d5abec825 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 13:28:35 +0000 Subject: [PATCH 04/23] CP-54020: Factor out the MIRROR module This will be used later on to define the interface a migration module should implement. Signed-off-by: Vincent Liu --- ocaml/xapi-idl/storage/storage_interface.ml | 118 +++++++++----------- ocaml/xapi-idl/storage/storage_skeleton.ml | 2 + ocaml/xapi/storage_mux.ml | 2 + ocaml/xapi/storage_smapiv1.ml | 2 + ocaml/xapi/storage_smapiv1_wrapper.ml | 2 + 5 files changed, 63 insertions(+), 63 deletions(-) diff --git a/ocaml/xapi-idl/storage/storage_interface.ml b/ocaml/xapi-idl/storage/storage_interface.ml index 7dc5a8f82a9..34856e0a57b 100644 --- a/ocaml/xapi-idl/storage/storage_interface.ml +++ b/ocaml/xapi-idl/storage/storage_interface.ml @@ -1161,6 +1161,60 @@ module StorageAPI (R : RPC) = struct end end +module type MIRROR = sig + type context = unit + + val start : + context + -> dbg:debug_info + -> sr:sr + -> vdi:vdi + -> dp:dp + -> mirror_vm:vm + -> copy_vm:vm + -> url:string + -> dest:sr + -> verify_dest:bool + -> Task.id + + val stop : context -> dbg:debug_info -> id:Mirror.id -> unit + + val stat : context -> dbg:debug_info -> id:Mirror.id -> Mirror.t + + val receive_start : + context + -> dbg:debug_info + -> sr:sr + -> vdi_info:vdi_info + -> id:Mirror.id + -> similar:Mirror.similars + -> Mirror.mirror_receive_result + + val receive_start2 : + context + -> dbg:debug_info + -> sr:sr + -> vdi_info:vdi_info + -> id:Mirror.id + -> similar:Mirror.similars + -> vm:vm + -> Mirror.mirror_receive_result + + val receive_finalize : context -> dbg:debug_info -> id:Mirror.id -> unit + + val receive_finalize2 : context -> dbg:debug_info -> id:Mirror.id -> unit + + val receive_cancel : context -> dbg:debug_info -> id:Mirror.id -> unit + + val list : context -> dbg:debug_info -> (Mirror.id * Mirror.t) list + + val import_activate : + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> sock_path + + val get_nbd_server : + context -> dbg:debug_info -> dp:dp -> sr:sr -> vdi:vdi -> vm:vm -> sock_path +end + module type Server_impl = sig type context = unit @@ -1417,69 +1471,7 @@ module type Server_impl = sig -> verify_dest:bool -> Task.id - module MIRROR : sig - val start : - context - -> dbg:debug_info - -> sr:sr - -> vdi:vdi - -> dp:dp - -> mirror_vm:vm - -> copy_vm:vm - -> url:string - -> dest:sr - -> verify_dest:bool - -> Task.id - - val stop : context -> dbg:debug_info -> id:Mirror.id -> unit - - val stat : context -> dbg:debug_info -> id:Mirror.id -> Mirror.t - - val receive_start : - context - -> dbg:debug_info - -> sr:sr - -> vdi_info:vdi_info - -> id:Mirror.id - -> similar:Mirror.similars - -> Mirror.mirror_receive_result - - val receive_start2 : - context - -> dbg:debug_info - -> sr:sr - -> vdi_info:vdi_info - -> id:Mirror.id - -> similar:Mirror.similars - -> vm:vm - -> Mirror.mirror_receive_result - - val receive_finalize : context -> dbg:debug_info -> id:Mirror.id -> unit - - val receive_finalize2 : context -> dbg:debug_info -> id:Mirror.id -> unit - - val receive_cancel : context -> dbg:debug_info -> id:Mirror.id -> unit - - val list : context -> dbg:debug_info -> (Mirror.id * Mirror.t) list - - val import_activate : - context - -> dbg:debug_info - -> dp:dp - -> sr:sr - -> vdi:vdi - -> vm:vm - -> sock_path - - val get_nbd_server : - context - -> dbg:debug_info - -> dp:dp - -> sr:sr - -> vdi:vdi - -> vm:vm - -> sock_path - end + module MIRROR : MIRROR end module Policy : sig diff --git a/ocaml/xapi-idl/storage/storage_skeleton.ml b/ocaml/xapi-idl/storage/storage_skeleton.ml index ab84ed7712e..4b5b23e6973 100644 --- a/ocaml/xapi-idl/storage/storage_skeleton.ml +++ b/ocaml/xapi-idl/storage/storage_skeleton.ml @@ -155,6 +155,8 @@ module DATA = struct let copy ctx ~dbg ~sr ~vdi ~vm ~url ~dest = u "DATA.copy" module MIRROR = struct + type context = unit + (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and writes data synchronously. It returns the id of the VDI.*) let start ctx ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest = diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index e99ec3a3634..2c2ba86d2df 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -740,6 +740,8 @@ module Mux = struct with_dbg ~name:"DATA.copy" ~dbg @@ fun dbg -> Storage_migrate.copy ~dbg module MIRROR = struct + type context = unit + let start () ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest ~verify_dest = with_dbg ~name:"DATA.MIRROR.start" ~dbg @@ fun di -> diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index 96da6ce4122..4373fdaae87 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -1213,6 +1213,8 @@ module SMAPIv1 : Server_impl = struct assert false module MIRROR = struct + type context = unit + let start _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ ~mirror_vm:_ ~copy_vm:_ ~url:_ ~dest:_ ~verify_dest:_ = assert false diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 8d6de8e8e84..f87bb9ffc4f 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -1143,6 +1143,8 @@ functor Impl.DATA.copy context ~dbg ~sr ~vdi ~vm ~url ~dest module MIRROR = struct + type context = unit + let start context ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest = info "DATA.MIRROR.start dbg:%s sr:%s vdi:%s url:%s dest:%s" dbg (s_of_sr sr) (s_of_vdi vdi) url (s_of_sr dest) ; From 6ac37d770a6aaa51a6e21cf6c5b2a0a19c3d6ea9 Mon Sep 17 00:00:00 2001 From: Lin Liu Date: Tue, 25 Mar 2025 03:38:27 +0000 Subject: [PATCH 05/23] CA-408500: Remove ListFile with Xapi_stdext_unix.Unixext Signed-off-by: Lin Liu --- ocaml/tests/test_extauth_plugin_ADwinbind.ml | 11 +- ocaml/xapi/extauth_plugin_ADwinbind.ml | 146 +++++++++---------- ocaml/xapi/helpers.ml | 23 --- 3 files changed, 81 insertions(+), 99 deletions(-) diff --git a/ocaml/tests/test_extauth_plugin_ADwinbind.ml b/ocaml/tests/test_extauth_plugin_ADwinbind.ml index 6babeda140c..5fe5bfc91cd 100644 --- a/ocaml/tests/test_extauth_plugin_ADwinbind.ml +++ b/ocaml/tests/test_extauth_plugin_ADwinbind.ml @@ -505,7 +505,9 @@ let test_add_ipv4_localhost_to_hosts = let msg = Printf.sprintf "%s -> %s" (String.concat "\n" inp) (String.concat "\n" exp) in - let actual = HostsConfIPv4.join "hostname" "domain" inp in + let actual = + HostsConfIPv4.join ~name:"hostname" ~domain:"domain" ~lines:inp + in Alcotest.(check @@ list string) msg exp actual in let matrix = @@ -537,7 +539,8 @@ let test_add_ipv4_and_ipv6_localhost_to_hosts = Printf.sprintf "%s -> %s" (String.concat "\n" inp) (String.concat "\n" exp) in let actual = - HostsConfIPv6.join "hostname" "domain" inp |> fun lines -> + HostsConfIPv6.join ~name:"hostname" ~domain:"domain" ~lines:inp + |> fun lines -> HostsConfIPv4.join ~name:"hostname" ~domain:"domain" ~lines in Alcotest.(check @@ list string) msg exp actual @@ -569,7 +572,9 @@ let test_remove_ipv4_localhost_from_hosts = let msg = Printf.sprintf "%s -> %s" (String.concat "\n" inp) (String.concat "\n" exp) in - let actual = HostsConfIPv4.leave "hostname" "domain" inp in + let actual = + HostsConfIPv4.leave ~name:"hostname" ~domain:"domain" ~lines:inp + in Alcotest.(check @@ list string) msg exp actual in let matrix = diff --git a/ocaml/xapi/extauth_plugin_ADwinbind.ml b/ocaml/xapi/extauth_plugin_ADwinbind.ml index efc6ac9f1a0..f23f1f5447e 100644 --- a/ocaml/xapi/extauth_plugin_ADwinbind.ml +++ b/ocaml/xapi/extauth_plugin_ADwinbind.ml @@ -815,7 +815,6 @@ let query_domain_workgroup ~domain = with _ -> raise (Auth_service_error (E_LOOKUP, err_msg)) let config_winbind_daemon ~workgroup ~netbios_name ~domain = - let open Xapi_stdext_unix in let smb_config = "/etc/samba/smb.conf" in let allow_fallback = (*`allow kerberos auth fallback` depends on our internal samba patch, @@ -825,42 +824,41 @@ let config_winbind_daemon ~workgroup ~netbios_name ~domain = * upgrade to samba packages with this capacity *) if !Xapi_globs.winbind_allow_kerberos_auth_fallback then "yes" else "no" in - let conf_contents = - match (workgroup, netbios_name, domain) with - | Some wkgroup, Some netbios, Some dom -> - [ - "# autogenerated by xapi" - ; "[global]" - ; "kerberos method = secrets and keytab" - ; Printf.sprintf "realm = %s" dom - ; "security = ADS" - ; "template shell = /bin/bash" - ; "winbind refresh tickets = yes" - ; "winbind enum groups = no" - ; "winbind enum users = no" - ; "winbind scan trusted domains = yes" - ; "winbind use krb5 enterprise principals = yes" - ; Printf.sprintf "winbind cache time = %d" - !Xapi_globs.winbind_cache_time - ; Printf.sprintf "machine password timeout = 0" - ; Printf.sprintf "kerberos encryption types = %s" - (Kerberos_encryption_types.Winbind.to_string - !Xapi_globs.winbind_kerberos_encryption_type - ) - ; Printf.sprintf "workgroup = %s" wkgroup - ; Printf.sprintf "netbios name = %s" netbios - ; "idmap config * : range = 3000000-3999999" - ; Printf.sprintf "idmap config %s: backend = rid" dom - ; Printf.sprintf "idmap config %s: range = 2000000-2999999" dom - ; Printf.sprintf "log level = %s" (debug_level ()) - ; Printf.sprintf "allow kerberos auth fallback = %s" allow_fallback - ; "idmap config * : backend = tdb" - ; "" (* Empty line at the end *) - ] - | _ -> - ["# autogenerated by xapi"; "[global]"; "" (* Empty line at the end *)] - in - Helpers.ListFile.to_path smb_config conf_contents + ( match (workgroup, netbios_name, domain) with + | Some wkgroup, Some netbios, Some dom -> + [ + "# autogenerated by xapi" + ; "[global]" + ; "kerberos method = secrets and keytab" + ; Printf.sprintf "realm = %s" dom + ; "security = ADS" + ; "template shell = /bin/bash" + ; "winbind refresh tickets = yes" + ; "winbind enum groups = no" + ; "winbind enum users = no" + ; "winbind scan trusted domains = yes" + ; "winbind use krb5 enterprise principals = yes" + ; Printf.sprintf "winbind cache time = %d" !Xapi_globs.winbind_cache_time + ; Printf.sprintf "machine password timeout = 0" + ; Printf.sprintf "kerberos encryption types = %s" + (Kerberos_encryption_types.Winbind.to_string + !Xapi_globs.winbind_kerberos_encryption_type + ) + ; Printf.sprintf "workgroup = %s" wkgroup + ; Printf.sprintf "netbios name = %s" netbios + ; "idmap config * : range = 3000000-3999999" + ; Printf.sprintf "idmap config %s: backend = rid" dom + ; Printf.sprintf "idmap config %s: range = 2000000-2999999" dom + ; Printf.sprintf "log level = %s" (debug_level ()) + ; Printf.sprintf "allow kerberos auth fallback = %s" allow_fallback + ; "idmap config * : backend = tdb" + ; "" (* Empty line at the end *) + ] + | _ -> + ["# autogenerated by xapi"; "[global]"; "" (* Empty line at the end *)] + ) + |> String.concat "\n" + |> Xapi_stdext_unix.Unixext.write_string_to_file smb_config let clear_winbind_config () = (* Keep the winbind configuration if xapi config file specified explictly, @@ -1198,7 +1196,6 @@ module RotateMachinePassword = struct let generate_krb5_tmp_config ~domain ~kdc_fqdn = (* Configure which server to change the password * https://web.mit.edu/kerberos/krb5-devel/doc/admin/conf_files/krb5_conf.html *) - let open Xapi_stdext_unix in let realm = String.uppercase_ascii domain in let domain_netbios = Wbinfo.domain_name_of ~target_name_type:NetbiosName ~from_name:domain @@ -1212,22 +1209,21 @@ module RotateMachinePassword = struct [] in - let conf_contents = - [ - "# autogenerated by xapi" - ; "[libdefaults]" - ; Printf.sprintf "default_realm = %s" realm - ; "[realms]" - ; Printf.sprintf "%s={" realm - ; Printf.sprintf "kpasswd_server=%s" kdc_fqdn - ; Printf.sprintf "kdc=%s" kdc_fqdn - ; "}" (* include winbind generated configure if exists *) - ] - @ include_item - @ [""] - (* Empty line at the end *) - in - Helpers.ListFile.to_path tmp_krb5_conf conf_contents + [ + "# autogenerated by xapi" + ; "[libdefaults]" + ; Printf.sprintf "default_realm = %s" realm + ; "[realms]" + ; Printf.sprintf "%s={" realm + ; Printf.sprintf "kpasswd_server=%s" kdc_fqdn + ; Printf.sprintf "kdc=%s" kdc_fqdn + ; "}" (* include winbind generated configure if exists *) + ] + @ include_item + @ [""] + (* Empty line at the end *) + |> String.concat "\n" + |> Xapi_stdext_unix.Unixext.write_string_to_file tmp_krb5_conf let clear_tmp_krb5_conf () = if !Xapi_globs.winbind_keep_configuration then @@ -1354,19 +1350,23 @@ module HostsConfIPv4 = HostsConfFunc (HostsConfTagIPv4) module HostsConfIPv6 = HostsConfFunc (HostsConfTagIPv6) module ConfigHosts = struct + open Xapi_stdext_unix.Unixext + let path = "/etc/hosts" let join ~name ~domain = - Helpers.ListFile.of_path path - |> HostsConfIPv4.join ~name ~domain - |> HostsConfIPv6.join ~name ~domain - |> Helpers.ListFile.to_path path + read_lines ~path |> fun lines -> + HostsConfIPv4.join ~name ~domain ~lines |> fun lines -> + HostsConfIPv6.join ~name ~domain ~lines + |> String.concat "\n" + |> write_string_to_file path let leave ~name ~domain = - Helpers.ListFile.of_path path - |> HostsConfIPv4.leave ~name ~domain - |> HostsConfIPv6.leave ~name ~domain - |> Helpers.ListFile.to_path path + read_lines ~path |> fun lines -> + HostsConfIPv4.leave ~name ~domain ~lines |> fun lines -> + HostsConfIPv6.leave ~name ~domain ~lines + |> String.concat "\n" + |> write_string_to_file path end let build_netbios_name ~config_params = @@ -1729,12 +1729,12 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct let@ __context = Context.with_tracing ~__context __FUNCTION__ in let user = List.assoc_opt "user" config_params in let pass = List.assoc_opt "pass" config_params in - let {service_name; workgroup; netbios_name; _} = - get_domain_info_from_db () - in - ( if Option.is_some netbios_name then - Option.get netbios_name |> fun name -> + let {service_name; netbios_name; _} = get_domain_info_from_db () in + ( match netbios_name with + | Some name -> ConfigHosts.leave ~domain:service_name ~name + | _ -> + () ) ; (* Clean extauth config *) @@ -1763,12 +1763,12 @@ module AuthADWinbind : Auth_signature.AUTH_MODULE = struct RotateMachinePassword.trigger_rotate ~start:5. ; Winbind.check_ready_to_serve ~timeout:300. ; - let {service_name; workgroup; netbios_name; _} = - get_domain_info_from_db () - in - if Option.is_some netbios_name then - Option.get netbios_name |> fun name -> - ConfigHosts.join ~domain:service_name ~name + let {service_name; netbios_name; _} = get_domain_info_from_db () in + match netbios_name with + | Some name -> + ConfigHosts.join ~domain:service_name ~name + | _ -> + () (* unit on_xapi_exit() diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index b5c810d76c3..2ef16112053 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -2360,26 +2360,3 @@ module AuthenticationCache = struct None end end - -module ListFile = struct - (* Read/Write List to/from file, line by line *) - let of_path path = - let ic = open_in path in - finally - (fun () -> - let rec read_lines acc = - try - let line = input_line ic in - read_lines (acc @ [line]) - with End_of_file -> acc - in - read_lines [] - ) - (fun () -> close_in ic) - - let to_path ?(perm = 0o0644) path contents = - String.concat "\n" contents |> fun x -> - Unixext.atomic_write_to_file path perm @@ fun fd -> - Unixext.really_write_string fd x |> ignore ; - Unix.fsync fd -end From 4a1b6570f566b8b2a49ccf99ee554ac7083145eb Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 14:43:57 +0000 Subject: [PATCH 06/23] CP-54020: Factor out sxm state tracking logic Signed-off-by: Vincent Liu --- ocaml/tests/test_storage_migrate_state.ml | 16 +- ocaml/xapi/dune | 4 +- ocaml/xapi/storage_migrate.ml | 307 +------------------- ocaml/xapi/storage_migrate_helper.ml | 328 ++++++++++++++++++++++ ocaml/xapi/storage_migrate_helper.mli | 249 ++++++++++++++++ ocaml/xapi/xapi_vm_migrate.ml | 2 +- 6 files changed, 589 insertions(+), 317 deletions(-) create mode 100644 ocaml/xapi/storage_migrate_helper.ml create mode 100644 ocaml/xapi/storage_migrate_helper.mli diff --git a/ocaml/tests/test_storage_migrate_state.ml b/ocaml/tests/test_storage_migrate_state.ml index 42087887995..498d9995548 100644 --- a/ocaml/tests/test_storage_migrate_state.ml +++ b/ocaml/tests/test_storage_migrate_state.ml @@ -17,11 +17,11 @@ open Test_highlevel module StorageMigrateState = struct type state_t = unit - let create_default_state () = Storage_migrate.State.clear () + let create_default_state () = Storage_migrate_helper.State.clear () end let sample_send_state = - Storage_migrate.State.Send_state. + Storage_migrate_helper.State.Send_state. { url= "url" ; dest_sr= Storage_interface.Sr.of_string "dest_sr" @@ -45,7 +45,7 @@ let sample_send_state = let sample_receive_state = let open Storage_interface in - Storage_migrate.State.Receive_state. + Storage_migrate_helper.State.Receive_state. { sr= Sr.of_string "my_sr" ; dummy_vdi= Vdi.of_string "dummy_vdi" @@ -57,7 +57,7 @@ let sample_receive_state = } let sample_copy_state = - Storage_migrate.State.Copy_state. + Storage_migrate_helper.State.Copy_state. { base_dp= "base_dp" ; leaf_dp= "leaf_dp" @@ -70,7 +70,7 @@ let sample_copy_state = module MapOf = Generic.MakeStateful (struct module Io = struct - open Storage_migrate.State + open Storage_migrate_helper.State type input_t = (string * osend operation) option @@ -88,7 +88,7 @@ module MapOf = Generic.MakeStateful (struct end module State = StorageMigrateState - open Storage_migrate.State + open Storage_migrate_helper.State let load_input () (send, recv, copy) = Option.iter (fun (id, send) -> add id send) send ; @@ -116,7 +116,7 @@ module MapOf = Generic.MakeStateful (struct end) let test_clear () = - let open Storage_migrate.State in + let open Storage_migrate_helper.State in clear () ; add "foo" (Send_op sample_send_state) ; add "bar" (Recv_op sample_receive_state) ; @@ -130,5 +130,5 @@ let test_clear () = let test = [("clear", `Quick, test_clear)] let tests = - Storage_migrate.State.persist_root := Test_common.working_area ; + Storage_migrate_helper.State.persist_root := Test_common.working_area ; [("storage_migrate_state_map_of", MapOf.tests)] diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index b74a1ecc16d..fde7a267003 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -217,8 +217,8 @@ ((pps ppx_deriving.ord) Xapi_observer_components) ((pps ppx_deriving_rpc) Config_file_sync Extauth_plugin_ADwinbind Importexport Sparse_dd_wrapper - Storage_migrate Storage_mux Storage_smapiv1_wrapper Stream_vdi - System_domains Xapi_psr Xapi_services Xapi_udhcpd))) + Storage_migrate Storage_migrate_helper Storage_mux Storage_smapiv1_wrapper + Stream_vdi System_domains Xapi_psr Xapi_services Xapi_udhcpd))) ) (library diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index 37ec703709a..cfc005d97fe 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -15,308 +15,13 @@ module D = Debug.Make (struct let name = "storage_migrate" end) open D - -(** As SXM is such a long running process, we dedicate this to log important - milestones during the SXM process *) -module SXM = Debug.Make (struct - let name = "SXM" -end) - module Listext = Xapi_stdext_std.Listext open Xapi_stdext_pervasives.Pervasiveext module Unixext = Xapi_stdext_unix.Unixext open Xmlrpc_client open Storage_interface open Storage_task - -module State = struct - module Receive_state = struct - type t = { - sr: Sr.t - ; dummy_vdi: Vdi.t - ; leaf_vdi: Vdi.t - ; leaf_dp: dp - ; parent_vdi: Vdi.t - ; remote_vdi: Vdi.t - ; mirror_vm: Vm.t - } - [@@deriving rpcty] - - let rpc_of_t = Rpcmarshal.marshal t.Rpc.Types.ty - - let t_of_rpc x = - match Rpcmarshal.unmarshal t.Rpc.Types.ty x with - | Ok y -> - y - | Error (`Msg m) -> - failwith (Printf.sprintf "Failed to unmarshal Receive_state.t: %s" m) - end - - module Send_state = struct - type remote_info = { - dp: dp - ; vdi: Vdi.t - ; url: string - ; verify_dest: bool [@default false] - } - [@@deriving rpcty] - - type tapdev = Tapctl.tapdev - - let typ_of_tapdev = - Rpc.Types.( - Abstract - { - aname= "tapdev" - ; test_data= [] - ; rpc_of= Tapctl.rpc_of_tapdev - ; of_rpc= (fun x -> Ok (Tapctl.tapdev_of_rpc x)) - } - ) - - type handle = Scheduler.handle - - let typ_of_handle = - Rpc.Types.( - Abstract - { - aname= "handle" - ; test_data= [] - ; rpc_of= Scheduler.rpc_of_handle - ; of_rpc= (fun x -> Ok (Scheduler.handle_of_rpc x)) - } - ) - - type t = { - url: string - ; dest_sr: Sr.t - ; remote_info: remote_info option - ; local_dp: dp - ; tapdev: tapdev option - ; mutable failed: bool - ; mutable watchdog: handle option - } - [@@deriving rpcty] - - let rpc_of_t = Rpcmarshal.marshal t.Rpc.Types.ty - - let t_of_rpc x = - match Rpcmarshal.unmarshal t.Rpc.Types.ty x with - | Ok y -> - y - | Error (`Msg m) -> - failwith (Printf.sprintf "Failed to unmarshal Send_state.t: %s" m) - end - - module Copy_state = struct - type t = { - base_dp: dp - ; leaf_dp: dp - ; remote_dp: dp - ; dest_sr: Sr.t - ; copy_vdi: Vdi.t - ; remote_url: string - ; verify_dest: bool [@default false] - } - [@@deriving rpcty] - - let rpc_of_t = Rpcmarshal.marshal t.Rpc.Types.ty - - let t_of_rpc x = - match Rpcmarshal.unmarshal t.Rpc.Types.ty x with - | Ok y -> - y - | Error (`Msg m) -> - failwith (Printf.sprintf "Failed to unmarshal Copy_state.t: %s" m) - end - - let loaded = ref false - - let mutex = Mutex.create () - - type send_table = (string, Send_state.t) Hashtbl.t - - type recv_table = (string, Receive_state.t) Hashtbl.t - - type copy_table = (string, Copy_state.t) Hashtbl.t - - type osend - - type orecv - - type ocopy - - type _ operation = - | Send_op : Send_state.t -> osend operation - | Recv_op : Receive_state.t -> orecv operation - | Copy_op : Copy_state.t -> ocopy operation - - type _ table = - | Send_table : send_table -> osend table - | Recv_table : recv_table -> orecv table - | Copy_table : copy_table -> ocopy table - - let active_send : send_table = Hashtbl.create 10 - - let active_recv : recv_table = Hashtbl.create 10 - - let active_copy : copy_table = Hashtbl.create 10 - - let table_of_op : type a. a operation -> a table = function - | Send_op _ -> - Send_table active_send - | Recv_op _ -> - Recv_table active_recv - | Copy_op _ -> - Copy_table active_copy - - let persist_root = ref "/var/run/nonpersistent" - - let path_of_table : type a. a table -> string = function - | Send_table _ -> - Filename.concat !persist_root "storage_mirrors_send.json" - | Recv_table _ -> - Filename.concat !persist_root "storage_mirrors_recv.json" - | Copy_table _ -> - Filename.concat !persist_root "storage_mirrors_copy.json" - - let rpc_of_table : type a. a table -> Rpc.t = - let open Rpc_std_helpers in - function - | Send_table send_table -> - rpc_of_hashtbl ~rpc_of:Send_state.rpc_of_t send_table - | Recv_table recv_table -> - rpc_of_hashtbl ~rpc_of:Receive_state.rpc_of_t recv_table - | Copy_table copy_table -> - rpc_of_hashtbl ~rpc_of:Copy_state.rpc_of_t copy_table - - let to_string : type a. a table -> string = - fun table -> rpc_of_table table |> Jsonrpc.to_string - - let rpc_of_path path = Unixext.string_of_file path |> Jsonrpc.of_string - - let load_one : type a. a table -> unit = - fun table -> - let rpc = path_of_table table |> rpc_of_path in - let open Rpc_std_helpers in - match table with - | Send_table table -> - Hashtbl.iter (Hashtbl.replace table) - (hashtbl_of_rpc ~of_rpc:Send_state.t_of_rpc rpc) - | Recv_table table -> - Hashtbl.iter (Hashtbl.replace table) - (hashtbl_of_rpc ~of_rpc:Receive_state.t_of_rpc rpc) - | Copy_table table -> - Hashtbl.iter (Hashtbl.replace table) - (hashtbl_of_rpc ~of_rpc:Copy_state.t_of_rpc rpc) - - let load () = - ignore_exn (fun () -> load_one (Send_table active_send)) ; - ignore_exn (fun () -> load_one (Recv_table active_recv)) ; - ignore_exn (fun () -> load_one (Copy_table active_copy)) ; - loaded := true - - let save_one : type a. a table -> unit = - fun table -> - to_string table |> Unixext.write_string_to_file (path_of_table table) - - let save () = - Unixext.mkdir_rec !persist_root 0o700 ; - save_one (Send_table active_send) ; - save_one (Recv_table active_recv) ; - save_one (Copy_table active_copy) - - let access_table ~save_after f table = - Xapi_stdext_threads.Threadext.Mutex.execute mutex (fun () -> - if not !loaded then load () ; - let result = f table in - if save_after then save () ; - result - ) - - let map_of () = - let contents_of table = - Hashtbl.fold (fun k v acc -> (k, v) :: acc) table [] - in - let send_ops = access_table ~save_after:false contents_of active_send in - let recv_ops = access_table ~save_after:false contents_of active_recv in - let copy_ops = access_table ~save_after:false contents_of active_copy in - (send_ops, recv_ops, copy_ops) - - let add : type a. string -> a operation -> unit = - fun id op -> - let add' : type a. string -> a operation -> a table -> unit = - fun id op table -> - match (table, op) with - | Send_table table, Send_op op -> - Hashtbl.replace table id op - | Recv_table table, Recv_op op -> - Hashtbl.replace table id op - | Copy_table table, Copy_op op -> - Hashtbl.replace table id op - in - access_table ~save_after:true - (fun table -> add' id op table) - (table_of_op op) - - let find id table = - access_table ~save_after:false - (fun table -> Hashtbl.find_opt table id) - table - - let remove id table = - access_table ~save_after:true (fun table -> Hashtbl.remove table id) table - - let clear () = - access_table ~save_after:true (fun table -> Hashtbl.clear table) active_send ; - access_table ~save_after:true (fun table -> Hashtbl.clear table) active_recv ; - access_table ~save_after:true (fun table -> Hashtbl.clear table) active_copy - - let remove_local_mirror id = remove id active_send - - let remove_receive_mirror id = remove id active_recv - - let remove_copy id = remove id active_copy - - let find_active_local_mirror id = find id active_send - - let find_active_receive_mirror id = find id active_recv - - let find_active_copy id = find id active_copy - - let mirror_id_of (sr, vdi) = - Printf.sprintf "%s/%s" - (Storage_interface.Sr.string_of sr) - (Storage_interface.Vdi.string_of vdi) - - let of_mirror_id id = - match String.split_on_char '/' id with - | sr :: rest -> - Storage_interface. - (Sr.of_string sr, Vdi.of_string (String.concat "/" rest)) - | _ -> - failwith "Bad id" - - let copy_id_of (sr, vdi) = - Printf.sprintf "copy/%s/%s" - (Storage_interface.Sr.string_of sr) - (Storage_interface.Vdi.string_of vdi) - - let of_copy_id id = - match String.split_on_char '/' id with - | op :: sr :: rest when op = "copy" -> - Storage_interface. - (Sr.of_string sr, Vdi.of_string (String.concat "/" rest)) - | _ -> - failwith "Bad id" -end - -let vdi_info x = - match x with - | Some (Vdi_info v) -> - v - | _ -> - failwith "Runtime type error: expecting Vdi_info" +open Storage_migrate_helper module Local = StorageAPI (Idl.Exn.GenClient (struct let rpc call = @@ -443,16 +148,6 @@ let progress_callback start len t y = Storage_task.set_state t (Task.Pending new_progress) ; signal (Storage_task.id_of_handle t) -let remove_from_sm_config vdi_info key = - { - vdi_info with - sm_config= List.filter (fun (k, _) -> k <> key) vdi_info.sm_config - } - -let add_to_sm_config vdi_info key value = - let vdi_info = remove_from_sm_config vdi_info key in - {vdi_info with sm_config= (key, value) :: vdi_info.sm_config} - (** This module [MigrateLocal] consists of the concrete implementations of the migration part of SMAPI. Functions inside this module are sender driven, which means they tend to be executed on the sender side. although there is not a hard rule diff --git a/ocaml/xapi/storage_migrate_helper.ml b/ocaml/xapi/storage_migrate_helper.ml new file mode 100644 index 00000000000..d8182a28e5a --- /dev/null +++ b/ocaml/xapi/storage_migrate_helper.ml @@ -0,0 +1,328 @@ +(* + * Copyright (c) Cloud Software Group + * + * 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. + *) + +(** As SXM is such a long running process, we dedicate this to log important + milestones during the SXM process *) +module SXM = Debug.Make (struct + let name = "SXM" +end) + +module Listext = Xapi_stdext_std.Listext +module Unixext = Xapi_stdext_unix.Unixext +open Storage_interface +open Xapi_stdext_pervasives.Pervasiveext +open Xmlrpc_client + +module State = struct + module Receive_state = struct + type t = { + sr: Sr.t + ; dummy_vdi: Vdi.t + ; leaf_vdi: Vdi.t + ; leaf_dp: dp + ; parent_vdi: Vdi.t + ; remote_vdi: Vdi.t + ; mirror_vm: Vm.t + } + [@@deriving rpcty] + + let rpc_of_t = Rpcmarshal.marshal t.Rpc.Types.ty + + let t_of_rpc x = + match Rpcmarshal.unmarshal t.Rpc.Types.ty x with + | Ok y -> + y + | Error (`Msg m) -> + failwith (Printf.sprintf "Failed to unmarshal Receive_state.t: %s" m) + end + + module Send_state = struct + type remote_info = { + dp: dp + ; vdi: Vdi.t + ; url: string + ; verify_dest: bool [@default false] + } + [@@deriving rpcty] + + type tapdev = Tapctl.tapdev + + let typ_of_tapdev = + Rpc.Types.( + Abstract + { + aname= "tapdev" + ; test_data= [] + ; rpc_of= Tapctl.rpc_of_tapdev + ; of_rpc= (fun x -> Ok (Tapctl.tapdev_of_rpc x)) + } + ) + + type handle = Scheduler.handle + + let typ_of_handle = + Rpc.Types.( + Abstract + { + aname= "handle" + ; test_data= [] + ; rpc_of= Scheduler.rpc_of_handle + ; of_rpc= (fun x -> Ok (Scheduler.handle_of_rpc x)) + } + ) + + type t = { + url: string + ; dest_sr: Sr.t + ; remote_info: remote_info option + ; local_dp: dp + ; tapdev: tapdev option + ; mutable failed: bool + ; mutable watchdog: handle option + } + [@@deriving rpcty] + + let rpc_of_t = Rpcmarshal.marshal t.Rpc.Types.ty + + let t_of_rpc x = + match Rpcmarshal.unmarshal t.Rpc.Types.ty x with + | Ok y -> + y + | Error (`Msg m) -> + failwith (Printf.sprintf "Failed to unmarshal Send_state.t: %s" m) + end + + module Copy_state = struct + type t = { + base_dp: dp + ; leaf_dp: dp + ; remote_dp: dp + ; dest_sr: Sr.t + ; copy_vdi: Vdi.t + ; remote_url: string + ; verify_dest: bool [@default false] + } + [@@deriving rpcty] + + let rpc_of_t = Rpcmarshal.marshal t.Rpc.Types.ty + + let t_of_rpc x = + match Rpcmarshal.unmarshal t.Rpc.Types.ty x with + | Ok y -> + y + | Error (`Msg m) -> + failwith (Printf.sprintf "Failed to unmarshal Copy_state.t: %s" m) + end + + let loaded = ref false + + let mutex = Mutex.create () + + type send_table = (string, Send_state.t) Hashtbl.t + + type recv_table = (string, Receive_state.t) Hashtbl.t + + type copy_table = (string, Copy_state.t) Hashtbl.t + + type osend + + type orecv + + type ocopy + + type _ operation = + | Send_op : Send_state.t -> osend operation + | Recv_op : Receive_state.t -> orecv operation + | Copy_op : Copy_state.t -> ocopy operation + + type _ table = + | Send_table : send_table -> osend table + | Recv_table : recv_table -> orecv table + | Copy_table : copy_table -> ocopy table + + let active_send : send_table = Hashtbl.create 10 + + let active_recv : recv_table = Hashtbl.create 10 + + let active_copy : copy_table = Hashtbl.create 10 + + let table_of_op : type a. a operation -> a table = function + | Send_op _ -> + Send_table active_send + | Recv_op _ -> + Recv_table active_recv + | Copy_op _ -> + Copy_table active_copy + + let persist_root = ref "/var/run/nonpersistent" + + let path_of_table : type a. a table -> string = function + | Send_table _ -> + Filename.concat !persist_root "storage_mirrors_send.json" + | Recv_table _ -> + Filename.concat !persist_root "storage_mirrors_recv.json" + | Copy_table _ -> + Filename.concat !persist_root "storage_mirrors_copy.json" + + let rpc_of_table : type a. a table -> Rpc.t = + let open Rpc_std_helpers in + function + | Send_table send_table -> + rpc_of_hashtbl ~rpc_of:Send_state.rpc_of_t send_table + | Recv_table recv_table -> + rpc_of_hashtbl ~rpc_of:Receive_state.rpc_of_t recv_table + | Copy_table copy_table -> + rpc_of_hashtbl ~rpc_of:Copy_state.rpc_of_t copy_table + + let to_string : type a. a table -> string = + fun table -> rpc_of_table table |> Jsonrpc.to_string + + let rpc_of_path path = Unixext.string_of_file path |> Jsonrpc.of_string + + let load_one : type a. a table -> unit = + fun table -> + let rpc = path_of_table table |> rpc_of_path in + let open Rpc_std_helpers in + match table with + | Send_table table -> + Hashtbl.iter (Hashtbl.replace table) + (hashtbl_of_rpc ~of_rpc:Send_state.t_of_rpc rpc) + | Recv_table table -> + Hashtbl.iter (Hashtbl.replace table) + (hashtbl_of_rpc ~of_rpc:Receive_state.t_of_rpc rpc) + | Copy_table table -> + Hashtbl.iter (Hashtbl.replace table) + (hashtbl_of_rpc ~of_rpc:Copy_state.t_of_rpc rpc) + + let load () = + ignore_exn (fun () -> load_one (Send_table active_send)) ; + ignore_exn (fun () -> load_one (Recv_table active_recv)) ; + ignore_exn (fun () -> load_one (Copy_table active_copy)) ; + loaded := true + + let save_one : type a. a table -> unit = + fun table -> + to_string table |> Unixext.write_string_to_file (path_of_table table) + + let save () = + Unixext.mkdir_rec !persist_root 0o700 ; + save_one (Send_table active_send) ; + save_one (Recv_table active_recv) ; + save_one (Copy_table active_copy) + + let access_table ~save_after f table = + Xapi_stdext_threads.Threadext.Mutex.execute mutex (fun () -> + if not !loaded then load () ; + let result = f table in + if save_after then save () ; + result + ) + + let map_of () = + let contents_of table = + Hashtbl.fold (fun k v acc -> (k, v) :: acc) table [] + in + let send_ops = access_table ~save_after:false contents_of active_send in + let recv_ops = access_table ~save_after:false contents_of active_recv in + let copy_ops = access_table ~save_after:false contents_of active_copy in + (send_ops, recv_ops, copy_ops) + + let add : type a. string -> a operation -> unit = + fun id op -> + let add' : type a. string -> a operation -> a table -> unit = + fun id op table -> + match (table, op) with + | Send_table table, Send_op op -> + Hashtbl.replace table id op + | Recv_table table, Recv_op op -> + Hashtbl.replace table id op + | Copy_table table, Copy_op op -> + Hashtbl.replace table id op + in + access_table ~save_after:true + (fun table -> add' id op table) + (table_of_op op) + + let find id table = + access_table ~save_after:false + (fun table -> Hashtbl.find_opt table id) + table + + let remove id table = + access_table ~save_after:true (fun table -> Hashtbl.remove table id) table + + let clear () = + access_table ~save_after:true (fun table -> Hashtbl.clear table) active_send ; + access_table ~save_after:true (fun table -> Hashtbl.clear table) active_recv ; + access_table ~save_after:true (fun table -> Hashtbl.clear table) active_copy + + let remove_local_mirror id = remove id active_send + + let remove_receive_mirror id = remove id active_recv + + let remove_copy id = remove id active_copy + + let find_active_local_mirror id = find id active_send + + let find_active_receive_mirror id = find id active_recv + + let find_active_copy id = find id active_copy + + let mirror_id_of (sr, vdi) = + Printf.sprintf "%s/%s" + (Storage_interface.Sr.string_of sr) + (Storage_interface.Vdi.string_of vdi) + + let of_mirror_id id = + match String.split_on_char '/' id with + | sr :: rest -> + Storage_interface. + (Sr.of_string sr, Vdi.of_string (String.concat "/" rest)) + | _ -> + failwith "Bad id" + + let copy_id_of (sr, vdi) = + Printf.sprintf "copy/%s/%s" + (Storage_interface.Sr.string_of sr) + (Storage_interface.Vdi.string_of vdi) + + let of_copy_id id = + match String.split_on_char '/' id with + | op :: sr :: rest when op = "copy" -> + Storage_interface. + (Sr.of_string sr, Vdi.of_string (String.concat "/" rest)) + | _ -> + failwith "Bad id" +end + +let vdi_info x = + match x with + | Some (Vdi_info v) -> + v + | _ -> + failwith "Runtime type error: expecting Vdi_info" + +let remove_from_sm_config vdi_info key = + { + vdi_info with + sm_config= List.filter (fun (k, _) -> k <> key) vdi_info.sm_config + } + +let add_to_sm_config vdi_info key value = + let vdi_info = remove_from_sm_config vdi_info key in + {vdi_info with sm_config= (key, value) :: vdi_info.sm_config} + +let with_http request f s = + try Http_client.rpc s request (fun response s -> f (response, s)) + with Unix.Unix_error (Unix.ECONNRESET, _, _) -> raise Connection_reset diff --git a/ocaml/xapi/storage_migrate_helper.mli b/ocaml/xapi/storage_migrate_helper.mli new file mode 100644 index 00000000000..2355a4d3947 --- /dev/null +++ b/ocaml/xapi/storage_migrate_helper.mli @@ -0,0 +1,249 @@ +(* + * Copyright (c) Cloud Software Group + * + * 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. + *) + +module SXM : Debug.DEBUG + +module State : sig + module Receive_state : sig + type t = { + sr: Storage_interface.sr + ; dummy_vdi: Storage_interface.vdi + ; leaf_vdi: Storage_interface.vdi + ; leaf_dp: string + ; parent_vdi: Storage_interface.vdi + ; remote_vdi: Storage_interface.vdi + ; mirror_vm: Storage_interface.vm + } + + val t_sr : (Storage_interface.sr, t) Rpc.Types.field + + val t_dummy_vdi : (Storage_interface.vdi, t) Rpc.Types.field + + val t_leaf_vdi : (Storage_interface.vdi, t) Rpc.Types.field + + val t_leaf_dp : (string, t) Rpc.Types.field + + val t_parent_vdi : (Storage_interface.vdi, t) Rpc.Types.field + + val t_remote_vdi : (Storage_interface.vdi, t) Rpc.Types.field + + val t_mirror_vm : (Storage_interface.vm, t) Rpc.Types.field + + val typ_of : t Rpc.Types.typ + + val t : t Rpc.Types.def + + val rpc_of_t : t -> Rpc.t + + val t_of_rpc : Rpc.t -> t + end + + module Send_state : sig + type remote_info = { + dp: string + ; vdi: Storage_interface.vdi + ; url: string + ; verify_dest: bool + } + + val remote_info_dp : (string, remote_info) Rpc.Types.field + + val remote_info_vdi : (Storage_interface.vdi, remote_info) Rpc.Types.field + + val remote_info_url : (string, remote_info) Rpc.Types.field + + val remote_info_verify_dest : (bool, remote_info) Rpc.Types.field + + val typ_of_remote_info : remote_info Rpc.Types.typ + + val remote_info : remote_info Rpc.Types.def + + type tapdev = Tapctl.tapdev + + val typ_of_tapdev : Tapctl.tapdev Rpc.Types.typ + + type handle = Scheduler.handle + + val typ_of_handle : Scheduler.handle Rpc.Types.typ + + type t = { + url: string + ; dest_sr: Storage_interface.sr + ; remote_info: remote_info option + ; local_dp: string + ; tapdev: tapdev option + ; mutable failed: bool + ; mutable watchdog: handle option + } + + val t_url : (string, t) Rpc.Types.field + + val t_dest_sr : (Storage_interface.sr, t) Rpc.Types.field + + val t_remote_info : (remote_info option, t) Rpc.Types.field + + val t_local_dp : (string, t) Rpc.Types.field + + val t_tapdev : (tapdev option, t) Rpc.Types.field + + val t_failed : (bool, t) Rpc.Types.field + + val t_watchdog : (handle option, t) Rpc.Types.field + + val typ_of : t Rpc.Types.typ + + val t : t Rpc.Types.def + + val rpc_of_t : t -> Rpc.t + + val t_of_rpc : Rpc.t -> t + end + + module Copy_state : sig + type t = { + base_dp: string + ; leaf_dp: string + ; remote_dp: string + ; dest_sr: Storage_interface.sr + ; copy_vdi: Storage_interface.vdi + ; remote_url: string + ; verify_dest: bool + } + + val t_base_dp : (string, t) Rpc.Types.field + + val t_leaf_dp : (string, t) Rpc.Types.field + + val t_remote_dp : (string, t) Rpc.Types.field + + val t_dest_sr : (Storage_interface.sr, t) Rpc.Types.field + + val t_copy_vdi : (Storage_interface.vdi, t) Rpc.Types.field + + val t_remote_url : (string, t) Rpc.Types.field + + val t_verify_dest : (bool, t) Rpc.Types.field + + val typ_of : t Rpc.Types.typ + + val t : t Rpc.Types.def + + val rpc_of_t : t -> Rpc.t + + val t_of_rpc : Rpc.t -> t + end + + val loaded : bool ref + + val mutex : Mutex.t + + type send_table = (string, Send_state.t) Hashtbl.t + + type recv_table = (string, Receive_state.t) Hashtbl.t + + type copy_table = (string, Copy_state.t) Hashtbl.t + + type osend + + type orecv + + type ocopy + + type _ operation = + | Send_op : Send_state.t -> osend operation + | Recv_op : Receive_state.t -> orecv operation + | Copy_op : Copy_state.t -> ocopy operation + + type _ table = + | Send_table : send_table -> osend table + | Recv_table : recv_table -> orecv table + | Copy_table : copy_table -> ocopy table + + val active_send : send_table + + val active_recv : recv_table + + val active_copy : copy_table + + val table_of_op : 'a operation -> 'a table + + val persist_root : string ref + + val path_of_table : 'a table -> string + + val rpc_of_table : 'a table -> Rpc.t + + val to_string : 'a table -> string + + val rpc_of_path : string -> Rpc.t + + val load_one : 'a table -> unit + + val load : unit -> unit + + val save_one : 'a table -> unit + + val save : unit -> unit + + val access_table : save_after:bool -> ('a -> 'b) -> 'a -> 'b + + val map_of : + unit + -> (string * Send_state.t) list + * (string * Receive_state.t) list + * (string * Copy_state.t) list + + val add : string -> 'a operation -> unit + + val find : 'a -> ('a, 'b) Hashtbl.t -> 'b option + + val remove : 'a -> ('a, 'b) Hashtbl.t -> unit + + val clear : unit -> unit + + val remove_local_mirror : string -> unit + + val remove_receive_mirror : string -> unit + + val remove_copy : string -> unit + + val find_active_local_mirror : string -> Send_state.t option + + val find_active_receive_mirror : string -> Receive_state.t option + + val find_active_copy : string -> Copy_state.t option + + val mirror_id_of : Storage_interface.sr * Storage_interface.vdi -> string + + val of_mirror_id : string -> Storage_interface.sr * Storage_interface.vdi + + val copy_id_of : Storage_interface.sr * Storage_interface.vdi -> string + + val of_copy_id : string -> Storage_interface.sr * Storage_interface.vdi +end + +val vdi_info : + Storage_interface.async_result_t option -> Storage_interface.vdi_info + +val remove_from_sm_config : + Storage_interface.vdi_info -> string -> Storage_interface.vdi_info + +val add_to_sm_config : + Storage_interface.vdi_info -> string -> string -> Storage_interface.vdi_info + +val with_http : + Http.Request.t + -> (Http.Response.t * Unix.file_descr -> 'a) + -> Unix.file_descr + -> 'a diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index b0a7d17774d..b09adef7f9d 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -1028,7 +1028,7 @@ let vdi_copy_fun __context dbg vdi_map remote is_intra_pool remote_vdis so_far ) ; SMAPI.VDI.activate3 dbg new_dp vconf.sr vconf.location vconf.mirror_vm ; let id = - Storage_migrate.State.mirror_id_of (vconf.sr, vconf.location) + Storage_migrate_helper.State.mirror_id_of (vconf.sr, vconf.location) in debug "%s mirror_vm is %s copy_vm is %s" __FUNCTION__ (Vm.string_of vconf.mirror_vm) From 1044120faff4d7292435f4f820ff3d732f799a32 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 14:45:27 +0000 Subject: [PATCH 07/23] CP-54020: Factor out module creation logic Use first class modules to generate modules for the remote SMAPIv2 calls to avoid code duplication. Signed-off-by: Vincent Liu --- ocaml/xapi/storage_migrate.ml | 65 +++++---------------------- ocaml/xapi/storage_migrate_helper.ml | 17 +++++++ ocaml/xapi/storage_migrate_helper.mli | 13 ++++++ 3 files changed, 42 insertions(+), 53 deletions(-) diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index cfc005d97fe..8952f947993 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -23,13 +23,6 @@ open Storage_interface open Storage_task open Storage_migrate_helper -module Local = StorageAPI (Idl.Exn.GenClient (struct - let rpc call = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"smapiv2" - (Storage_utils.localhost_connection_args ()) - call -end)) - let tapdisk_of_attach_info (backend : Storage_interface.backend) = let _, blockdevices, _, nbds = Storage_interface.implementations_of_backend backend @@ -155,11 +148,7 @@ on what is executed on the sender side, this provides some heuristics. *) module MigrateLocal = struct (** [copy_into_vdi] is similar to [copy_into_sr] but requires a [dest_vdi] parameter *) let copy_into_vdi ~task ~dbg ~sr ~vdi ~vm ~url ~dest ~dest_vdi ~verify_dest = - let remote_url = Storage_utils.connection_args_of_uri ~verify_dest url in - let module Remote = StorageAPI (Idl.Exn.GenClient (struct - let rpc = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" remote_url - end)) in + let (module Remote) = get_remote_backend url verify_dest in debug "copy local=%s/%s url=%s remote=%s/%s verify_dest=%B" (Storage_interface.Sr.string_of sr) (Storage_interface.Vdi.string_of vdi) @@ -321,11 +310,7 @@ module MigrateLocal = struct url (Storage_interface.Sr.string_of dest) verify_dest ; - let remote_url = Storage_utils.connection_args_of_uri ~verify_dest url in - let module Remote = StorageAPI (Idl.Exn.GenClient (struct - let rpc = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" remote_url - end)) in + let (module Remote) = get_remote_backend url verify_dest in (* Find the local VDI *) try let vdis = Local.SR.scan dbg sr in @@ -430,12 +415,9 @@ module MigrateLocal = struct url (Storage_interface.Sr.string_of dest) verify_dest ; + let remote_url = Http.Url.of_string url in - let module Remote = StorageAPI (Idl.Exn.GenClient (struct - let rpc = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" - (Storage_utils.connection_args_of_uri ~verify_dest url) - end)) in + let (module Remote) = get_remote_backend url verify_dest in (* Find the local VDI *) let vdis = Local.SR.scan dbg sr in let local_vdi = @@ -676,16 +658,10 @@ module MigrateLocal = struct | None -> debug "Snapshot VDI already cleaned up" ) ; - let remote_url = - Storage_utils.connection_args_of_uri - ~verify_dest:remote_info.State.Send_state.verify_dest - remote_info.State.Send_state.url + + let (module Remote) = + get_remote_backend remote_info.url remote_info.verify_dest in - let module Remote = StorageAPI (Idl.Exn.GenClient (struct - let rpc = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" - remote_url - end)) in try Remote.DATA.MIRROR.receive_cancel dbg id with _ -> () ) | None -> @@ -773,7 +749,7 @@ module MigrateLocal = struct ) send_ops ; List.iter - (fun (id, copy_state) -> + (fun (id, (copy_state : State.Copy_state.t)) -> debug "Copy in progress: %s" id ; List.iter log_and_ignore_exn [ @@ -784,15 +760,9 @@ module MigrateLocal = struct Local.DP.destroy dbg copy_state.State.Copy_state.base_dp true ) ] ; - let remote_url = - Storage_utils.connection_args_of_uri - ~verify_dest:copy_state.State.Copy_state.verify_dest - copy_state.State.Copy_state.remote_url + let (module Remote) = + get_remote_backend copy_state.remote_url copy_state.verify_dest in - let module Remote = StorageAPI (Idl.Exn.GenClient (struct - let rpc = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" remote_url - end)) in List.iter log_and_ignore_exn [ (fun () -> @@ -1025,14 +995,7 @@ let post_deactivate_hook ~sr ~vdi ~dp:_ = ~some:(fun ri -> ri.verify_dest) r.remote_info in - let remote_url = - Storage_utils.connection_args_of_uri ~verify_dest r.url - in - let module Remote = StorageAPI (Idl.Exn.GenClient (struct - let rpc = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" - remote_url - end)) in + let (module Remote) = get_remote_backend r.url verify_dest in debug "Calling receive_finalize2" ; log_and_ignore_exn (fun () -> Remote.DATA.MIRROR.receive_finalize2 "Mirror-cleanup" id @@ -1170,11 +1133,7 @@ let receive_cancel = MigrateRemote.receive_cancel * to SMAPI. *) let update_snapshot_info_src ~dbg ~sr ~vdi ~url ~dest ~dest_vdi ~snapshot_pairs ~verify_dest = - let remote_url = Storage_utils.connection_args_of_uri ~verify_dest url in - let module Remote = StorageAPI (Idl.Exn.GenClient (struct - let rpc = - Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" remote_url - end)) in + let (module Remote) = get_remote_backend url verify_dest in let local_vdis = Local.SR.scan dbg sr in let find_vdi ~vdi ~vdi_info_list = try List.find (fun x -> x.vdi = vdi) vdi_info_list diff --git a/ocaml/xapi/storage_migrate_helper.ml b/ocaml/xapi/storage_migrate_helper.ml index d8182a28e5a..19660598620 100644 --- a/ocaml/xapi/storage_migrate_helper.ml +++ b/ocaml/xapi/storage_migrate_helper.ml @@ -326,3 +326,20 @@ let add_to_sm_config vdi_info key value = let with_http request f s = try Http_client.rpc s request (fun response s -> f (response, s)) with Unix.Unix_error (Unix.ECONNRESET, _, _) -> raise Connection_reset + +module Local = StorageAPI (Idl.Exn.GenClient (struct + let rpc call = + Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"smapiv2" + (Storage_utils.localhost_connection_args ()) + call +end)) + +module type SMAPIv2 = module type of Local + +let get_remote_backend url verify_dest = + let remote_url = Storage_utils.connection_args_of_uri ~verify_dest url in + let module Remote = StorageAPI (Idl.Exn.GenClient (struct + let rpc = + Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"dst_smapiv2" remote_url + end)) in + (module Remote : SMAPIv2) diff --git a/ocaml/xapi/storage_migrate_helper.mli b/ocaml/xapi/storage_migrate_helper.mli index 2355a4d3947..7af4f39ed39 100644 --- a/ocaml/xapi/storage_migrate_helper.mli +++ b/ocaml/xapi/storage_migrate_helper.mli @@ -247,3 +247,16 @@ val with_http : -> (Http.Response.t * Unix.file_descr -> 'a) -> Unix.file_descr -> 'a + +module type SMAPIv2 = sig + include module type of Storage_interface.StorageAPI (Idl.Exn.GenClient (struct + let rpc call = + Storage_utils.rpc ~srcstr:"smapiv2" ~dststr:"smapiv2" + (Storage_utils.localhost_connection_args ()) + call + end)) +end + +module Local : SMAPIv2 + +val get_remote_backend : string -> bool -> (module SMAPIv2) From 7f349f3c8c5748935db524072b65cd2d68dc7788 Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 15:47:28 +0000 Subject: [PATCH 08/23] Delete unused `query_result_of_sr` function Signed-off-by: Vincent Liu --- ocaml/xapi/storage_mux_reg.ml | 7 ------- ocaml/xapi/storage_mux_reg.mli | 3 --- 2 files changed, 10 deletions(-) diff --git a/ocaml/xapi/storage_mux_reg.ml b/ocaml/xapi/storage_mux_reg.ml index f7eff2ab43d..0bad2d28c96 100644 --- a/ocaml/xapi/storage_mux_reg.ml +++ b/ocaml/xapi/storage_mux_reg.ml @@ -71,13 +71,6 @@ let unregister sr = ) ) -(* This function is entirely unused, but I am not sure if it should be - deleted or not *) -let query_result_of_sr sr = - with_lock m (fun () -> - Option.map (fun x -> x.query_result) (Hashtbl.find_opt plugins sr) - ) - let sr_has_capability sr capability = with_lock m (fun () -> match Hashtbl.find_opt plugins sr with diff --git a/ocaml/xapi/storage_mux_reg.mli b/ocaml/xapi/storage_mux_reg.mli index 218cd5f96b3..623a6eb7c1f 100644 --- a/ocaml/xapi/storage_mux_reg.mli +++ b/ocaml/xapi/storage_mux_reg.mli @@ -36,9 +36,6 @@ val register : val unregister : Storage_interface.sr -> unit -val query_result_of_sr : - Storage_interface.sr -> Storage_interface.query_result option - val sr_has_capability : Storage_interface.sr -> Smint.Feature.capability -> bool val of_sr : Storage_interface.sr -> processor From 112ef69fe414717a9a2949986b144c4a3e91255b Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Fri, 21 Mar 2025 11:29:35 +0000 Subject: [PATCH 09/23] style: Some coding style improvements Signed-off-by: Vincent Liu --- ocaml/xapi/storage_migrate_helper.ml | 30 ++++++++++++++------------- ocaml/xapi/storage_migrate_helper.mli | 4 ---- ocaml/xapi/storage_mux.ml | 2 +- ocaml/xapi/storage_mux_reg.ml | 12 +++++------ ocaml/xapi/storage_mux_reg.mli | 2 +- 5 files changed, 23 insertions(+), 27 deletions(-) diff --git a/ocaml/xapi/storage_migrate_helper.ml b/ocaml/xapi/storage_migrate_helper.ml index 19660598620..b7b1eb6c6f9 100644 --- a/ocaml/xapi/storage_migrate_helper.ml +++ b/ocaml/xapi/storage_migrate_helper.ml @@ -25,6 +25,8 @@ open Xapi_stdext_pervasives.Pervasiveext open Xmlrpc_client module State = struct + let failwith_fmt fmt = Printf.ksprintf failwith fmt + module Receive_state = struct type t = { sr: Sr.t @@ -44,7 +46,7 @@ module State = struct | Ok y -> y | Error (`Msg m) -> - failwith (Printf.sprintf "Failed to unmarshal Receive_state.t: %s" m) + failwith_fmt "Failed to unmarshal Receive_state.t: %s" m end module Send_state = struct @@ -100,7 +102,7 @@ module State = struct | Ok y -> y | Error (`Msg m) -> - failwith (Printf.sprintf "Failed to unmarshal Send_state.t: %s" m) + failwith_fmt "Failed to unmarshal Send_state.t: %s" m end module Copy_state = struct @@ -122,7 +124,7 @@ module State = struct | Ok y -> y | Error (`Msg m) -> - failwith (Printf.sprintf "Failed to unmarshal Copy_state.t: %s" m) + failwith_fmt "Failed to unmarshal Copy_state.t: %s" m end let loaded = ref false @@ -205,12 +207,6 @@ module State = struct Hashtbl.iter (Hashtbl.replace table) (hashtbl_of_rpc ~of_rpc:Copy_state.t_of_rpc rpc) - let load () = - ignore_exn (fun () -> load_one (Send_table active_send)) ; - ignore_exn (fun () -> load_one (Recv_table active_recv)) ; - ignore_exn (fun () -> load_one (Copy_table active_copy)) ; - loaded := true - let save_one : type a. a table -> unit = fun table -> to_string table |> Unixext.write_string_to_file (path_of_table table) @@ -222,6 +218,12 @@ module State = struct save_one (Copy_table active_copy) let access_table ~save_after f table = + let load () = + ignore_exn (fun () -> load_one (Send_table active_send)) ; + ignore_exn (fun () -> load_one (Recv_table active_recv)) ; + ignore_exn (fun () -> load_one (Copy_table active_copy)) ; + loaded := true + in Xapi_stdext_threads.Threadext.Mutex.execute mutex (fun () -> if not !loaded then load () ; let result = f table in @@ -263,9 +265,10 @@ module State = struct access_table ~save_after:true (fun table -> Hashtbl.remove table id) table let clear () = - access_table ~save_after:true (fun table -> Hashtbl.clear table) active_send ; - access_table ~save_after:true (fun table -> Hashtbl.clear table) active_recv ; - access_table ~save_after:true (fun table -> Hashtbl.clear table) active_copy + let clear_one (type a) (tbl : (string, a) Hashtbl.t) : unit = + access_table ~save_after:true Hashtbl.clear tbl + in + clear_one active_send ; clear_one active_recv ; clear_one active_copy let remove_local_mirror id = remove id active_send @@ -306,8 +309,7 @@ module State = struct failwith "Bad id" end -let vdi_info x = - match x with +let vdi_info = function | Some (Vdi_info v) -> v | _ -> diff --git a/ocaml/xapi/storage_migrate_helper.mli b/ocaml/xapi/storage_migrate_helper.mli index 7af4f39ed39..29753436c78 100644 --- a/ocaml/xapi/storage_migrate_helper.mli +++ b/ocaml/xapi/storage_migrate_helper.mli @@ -188,10 +188,6 @@ module State : sig val rpc_of_path : string -> Rpc.t - val load_one : 'a table -> unit - - val load : unit -> unit - val save_one : 'a table -> unit val save : unit -> unit diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 2c2ba86d2df..9b071b86187 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -50,7 +50,7 @@ module Mux = struct List.fold_left (fun acc (sr, result) -> Printf.sprintf "For SR: %s" (s_of_sr sr) - :: string_of_sm_result (fun s -> s) result + :: s_of_sm_result (fun s -> s) result :: acc ) [] results diff --git a/ocaml/xapi/storage_mux_reg.ml b/ocaml/xapi/storage_mux_reg.ml index 0bad2d28c96..488fcd9aa89 100644 --- a/ocaml/xapi/storage_mux_reg.ml +++ b/ocaml/xapi/storage_mux_reg.ml @@ -17,8 +17,6 @@ and multiplexing between them according to the sr type *) module D = Debug.Make (struct let name = __MODULE__ end) -open D - type processor = Rpc.call -> Rpc.response let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute @@ -56,7 +54,7 @@ let register sr rpc d info = ; query_result= info ; features } ; - debug "register SR %s (currently-registered = [ %s ])" (s_of_sr sr) + D.debug "register SR %s (currently-registered = [ %s ])" (s_of_sr sr) (String.concat ", " (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) ) @@ -65,7 +63,7 @@ let register sr rpc d info = let unregister sr = with_lock m (fun () -> Hashtbl.remove plugins sr ; - debug "unregister SR %s (currently-registered = [ %s ])" (s_of_sr sr) + D.debug "unregister SR %s (currently-registered = [ %s ])" (s_of_sr sr) (String.concat ", " (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) ) @@ -87,7 +85,7 @@ let of_sr sr = | Some x -> x.processor | None -> - error "No storage plugin for SR: %s (currently-registered = [ %s ])" + D.error "No storage plugin for SR: %s (currently-registered = [ %s ])" (s_of_sr sr) (String.concat ", " (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) @@ -101,7 +99,7 @@ let smapi_version_of_sr sr = | Some x -> x.query_result.smapi_version | None -> - error "No storage plugin for SR: %s (currently-registered = [ %s ])" + D.error "No storage plugin for SR: %s (currently-registered = [ %s ])" (s_of_sr sr) (String.concat ", " (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) @@ -111,7 +109,7 @@ let smapi_version_of_sr sr = type 'a sm_result = SMSuccess of 'a | SMFailure of exn -let string_of_sm_result f = function +let s_of_sm_result f = function | SMSuccess x -> Printf.sprintf "Success: %s" (f x) | SMFailure e -> diff --git a/ocaml/xapi/storage_mux_reg.mli b/ocaml/xapi/storage_mux_reg.mli index 623a6eb7c1f..7d4eee95214 100644 --- a/ocaml/xapi/storage_mux_reg.mli +++ b/ocaml/xapi/storage_mux_reg.mli @@ -45,7 +45,7 @@ val smapi_version_of_sr : type 'a sm_result = SMSuccess of 'a | SMFailure of exn -val string_of_sm_result : ('a -> string) -> 'a sm_result -> string +val s_of_sm_result : ('a -> string) -> 'a sm_result -> string val success : 'a sm_result -> bool From 71ce0082d7ee8c9b3837182baab4e0b14280de32 Mon Sep 17 00:00:00 2001 From: Steven Woods Date: Fri, 28 Mar 2025 11:02:37 +0000 Subject: [PATCH 10/23] CP-53472: Create parent for add_module spans This keeps them contained, allowing them to easily be hidden in Jaeger Signed-off-by: Steven Woods --- python3/packages/observer.py | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/python3/packages/observer.py b/python3/packages/observer.py index cf2ebf32226..df53f5f0f1f 100644 --- a/python3/packages/observer.py +++ b/python3/packages/observer.py @@ -266,7 +266,7 @@ def bugtool_filenamer(): tracers = list(map(create_tracer_from_config, configs)) debug("tracers=%s", tracers) - def span_of_tracers(wrapped=None, span_name_prefix=""): + def span_of_tracers(wrapped=None, span_name_prefix="", parent_context=None): """ Public decorator that creates a trace around a function. @@ -289,7 +289,7 @@ def span_of_tracers(wrapped=None, span_name_prefix=""): that the function is decorated properly on the second pass. """ if wrapped is None: # handle decorators with parameters - return functools.partial(span_of_tracers, span_name_prefix=span_name_prefix) + return functools.partial(span_of_tracers, span_name_prefix=span_name_prefix, parent_context=parent_context) @wrapt.decorator def instrument_function(wrapped, _, args, kwargs): @@ -352,11 +352,10 @@ def autoinstrument_class(aclass): traceback.format_exc(), ) - def autoinstrument_module(amodule): """Autoinstrument the classes and functions in a module.""" - with tracers[0].start_as_current_span(f"auto_instrumentation.add_module: {amodule}"): + with tracers[0].start_as_current_span(f"auto_instrumentation.add_module: {amodule}", context=parent_context): # Instrument the methods of the classes in the module for _, aclass in inspect.getmembers(amodule, inspect.isclass): try: @@ -373,14 +372,15 @@ def autoinstrument_module(amodule): return instrument_function(wrapped) - def _patch_module(module_name): + def _patch_module(module_name, parent_context=None): wrapt.importer.discover_post_import_hooks(module_name) wrapt.importer.when_imported(module_name)( - lambda hook: span_of_tracers(wrapped=hook) + lambda hook: span_of_tracers(wrapped=hook, parent_context=parent_context) ) - for m in module_names: - _patch_module(m) + def _patch_modules(parent_context): + for m in module_names: + _patch_module(m, parent_context=parent_context) # Create spans to track observer.py's setup duration t = tracers[0] @@ -388,6 +388,10 @@ def _patch_module(module_name): import_span = t.start_span("observer.py:imports", start_time=import_ts_start) import_span.end(end_time=import_ts_end) + # Set a parent span in the add_module spans' context so that they are kept together + with t.start_span("auto_instrumentation") as aspan: + _patch_modules(trace.set_span_in_context(aspan)) + return span_of_tracers, _patch_module From 5c387c4ceee6ef799da4101e95f25f71b7657d91 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Mar 2025 18:08:40 +0000 Subject: [PATCH 11/23] libs: resources tests add logs dependency, necessary for future versions of logs Signed-off-by: Pau Ruiz Safont --- ocaml/libs/resources/test/dune | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/libs/resources/test/dune b/ocaml/libs/resources/test/dune index 2bc052f2e63..15a20f0bfa3 100644 --- a/ocaml/libs/resources/test/dune +++ b/ocaml/libs/resources/test/dune @@ -4,6 +4,7 @@ (action (run %{test} -e)) (libraries safe-resources + logs logs.fmt alcotest ) From f2f72dc94ffa376be7eee91c2f0d0a97b2fb11fc Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Mar 2025 18:11:46 +0000 Subject: [PATCH 12/23] xapi-stdext-threads, test: use stable testing interface Alcotest changed how match_raises to actually be reasonable instead of failing when the mathing function returns true (note how is_oob expects a string with two spaces) This also highlights why matching strings in exception is a bad idea. Instead raise a non-stringy exception and use polymorphic compare. Signed-off-by: Pau Ruiz Safont --- ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.ml | 4 +++- ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.mli | 2 ++ .../libs/xapi-stdext/lib/xapi-stdext-threads/ipq_test.ml | 9 ++------- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.ml index 7293ae625e1..45bbd93622c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.ml @@ -19,6 +19,8 @@ type 'a t = {default: 'a event; mutable size: int; mutable data: 'a event array} exception EmptyHeap +exception OutOfBounds of int + let create n default = if n <= 0 then invalid_arg "create" @@ -61,7 +63,7 @@ let maximum h = let remove h s = if h.size <= 0 then raise EmptyHeap ; if s < 0 || s >= h.size then - invalid_arg (Printf.sprintf "%s: index %d out of bounds" __FUNCTION__ s) ; + raise (OutOfBounds s) ; let n = h.size - 1 in let d = h.data in let x = d.(n) in diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.mli index 19f8bf1e33f..b542ef9d65d 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq.mli @@ -18,6 +18,8 @@ type 'a t exception EmptyHeap +exception OutOfBounds of int + val create : int -> 'a -> 'a t (** [create n default] creates an empty Imperative priority queue. The queue initially is initialized to store [n] elements. diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq_test.ml index a9cc2611da8..aab499da74a 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-threads/ipq_test.ml @@ -18,14 +18,9 @@ module Ipq = Xapi_stdext_threads_scheduler.Ipq let test_out_of_index () = let q = Ipq.create 10 0 in Ipq.add q {Ipq.ev= 123; Ipq.time= Mtime_clock.elapsed ()} ; - let is_oob = function - | Invalid_argument s when String.ends_with ~suffix:" out of bounds" s -> - true - | _ -> - false - in let oob_check n = - (Alcotest.match_raises "out of bound" is_oob @@ fun () -> Ipq.remove q n) ; + let oob = Ipq.OutOfBounds n in + (Alcotest.check_raises "out of bound" oob @@ fun () -> Ipq.remove q n) ; Alcotest.(check bool) "same value" false (Ipq.is_empty q) in oob_check 10 ; From 4ee32f2fa6ffde149eec128fd9e8cf1d054e5f21 Mon Sep 17 00:00:00 2001 From: Andrii Sultanov Date: Mon, 31 Mar 2025 07:40:58 +0100 Subject: [PATCH 13/23] CA-408841 rrd: don't update rrds when ds_update is called with an empty datasource array Several assumptions in the ds_update function expect at least one element to be present in the array, and will raise Invalid_argument("index out of bounds") otherwise. This could be triggered by disabling all datasources for a particular plugin/owner combination, for example. Signed-off-by: Andrii Sultanov --- ocaml/libs/xapi-rrd/lib/rrd.ml | 203 +++++++++++++++++---------------- 1 file changed, 103 insertions(+), 100 deletions(-) diff --git a/ocaml/libs/xapi-rrd/lib/rrd.ml b/ocaml/libs/xapi-rrd/lib/rrd.ml index 126442db986..b4c827705c9 100644 --- a/ocaml/libs/xapi-rrd/lib/rrd.ml +++ b/ocaml/libs/xapi-rrd/lib/rrd.ml @@ -379,121 +379,124 @@ let process_ds_value ds value interval new_rrd = rate let ds_update rrd timestamp valuesandtransforms new_rrd = - (* Interval is the time between this and the last update - - Currently ds_update is called with datasources that belong to a single - plugin, correspondingly they all have the same timestamp. - Further refactoring is needed if timestamps per measurement are to be - introduced. *) - let first_ds_index, _ = valuesandtransforms.(0) in - let last_updated = rrd.rrd_dss.(first_ds_index).ds_last_updated in - let interval = timestamp -. last_updated in - (* Work around the clock going backwards *) - let interval = if interval < 0. then 5. else interval in - - (* start time (st) and age of the last processed pdp and the currently occupied one *) - let proc_pdp_st, _proc_pdp_age = get_times last_updated rrd.timestep in - let occu_pdp_st, occu_pdp_age = get_times timestamp rrd.timestep in - - (* The number of pdps that should result from this update *) - let elapsed_pdp_st = - Int64.to_int ((occu_pdp_st --- proc_pdp_st) /// rrd.timestep) - in - - (* if we're due one or more PDPs, pre_int is the amount of the - current update interval that will be used in calculating them, and - post_int is the amount left over - this step. If a PDP isn't post is what's left over *) - let pre_int, post_int = - if elapsed_pdp_st > 0 then - let pre = interval -. occu_pdp_age in - (pre, occu_pdp_age) - else - (interval, 0.0) - in - - (* We're now done with the last_updated value, so update it *) - rrd.last_updated <- timestamp ; + (* CA-408841 - don't update the rrd at all if list of datasources is empty *) + if valuesandtransforms <> [||] then ( + (* Interval is the time between this and the last update + + Currently ds_update is called with datasources that belong to a single + plugin, correspondingly they all have the same timestamp. + Further refactoring is needed if timestamps per measurement are to be + introduced. *) + let first_ds_index, _ = valuesandtransforms.(0) in + let last_updated = rrd.rrd_dss.(first_ds_index).ds_last_updated in + let interval = timestamp -. last_updated in + (* Work around the clock going backwards *) + let interval = if interval < 0. then 5. else interval in + + (* start time (st) and age of the last processed pdp and the currently occupied one *) + let proc_pdp_st, _proc_pdp_age = get_times last_updated rrd.timestep in + let occu_pdp_st, occu_pdp_age = get_times timestamp rrd.timestep in + + (* The number of pdps that should result from this update *) + let elapsed_pdp_st = + Int64.to_int ((occu_pdp_st --- proc_pdp_st) /// rrd.timestep) + in - (* Calculate the values we're going to store based on the input data and the type of the DS *) - let v2s = - Array.map - (fun (i, {value; _}) -> - let v = process_ds_value rrd.rrd_dss.(i) value interval new_rrd in - rrd.rrd_dss.(i).ds_last_updated <- timestamp ; - (i, v) - ) - valuesandtransforms - in - (* Update the PDP accumulators up until the most recent PDP *) - Array.iter - (fun (i, value) -> - let ds = rrd.rrd_dss.(i) in - if Utils.isnan value then - ds.ds_unknown_sec <- pre_int + (* if we're due one or more PDPs, pre_int is the amount of the + current update interval that will be used in calculating them, and + post_int is the amount left over + this step. If a PDP isn't post is what's left over *) + let pre_int, post_int = + if elapsed_pdp_st > 0 then + let pre = interval -. occu_pdp_age in + (pre, occu_pdp_age) else - (* CA-404597 - Gauge and Absolute values should be passed as-is, - without being involved in time-based calculations at all. - This applies to calculations below as well *) - match ds.ds_ty with - | Gauge | Absolute -> - ds.ds_value <- value - | Derive -> - ds.ds_value <- ds.ds_value +. (pre_int *. value /. interval) - ) - v2s ; + (interval, 0.0) + in + + (* We're now done with the last_updated value, so update it *) + rrd.last_updated <- timestamp ; - (* If we've passed a PDP point, we need to update the RRAs *) - if elapsed_pdp_st > 0 then ( - (* Calculate the PDPs for each DS *) - let pdps = + (* Calculate the values we're going to store based on the input data and the type of the DS *) + let v2s = Array.map - (fun (i, {transform; _}) -> - let ds = rrd.rrd_dss.(i) in - if interval > ds.ds_mrhb then - (i, nan) - else - let raw = - let proc_pdp_st = get_float_time last_updated rrd.timestep in - let occu_pdp_st = get_float_time timestamp rrd.timestep in - - match ds.ds_ty with - | Gauge | Absolute -> - ds.ds_value - | Derive -> - ds.ds_value - /. (occu_pdp_st -. proc_pdp_st -. ds.ds_unknown_sec) - in - (* Apply the transform after the raw value has been calculated *) - let raw = apply_transform_function transform raw in - (* Make sure the values are not out of bounds after all the processing *) - if raw < ds.ds_min || raw > ds.ds_max then - (i, nan) - else - (i, raw) + (fun (i, {value; _}) -> + let v = process_ds_value rrd.rrd_dss.(i) value interval new_rrd in + rrd.rrd_dss.(i).ds_last_updated <- timestamp ; + (i, v) ) valuesandtransforms in - - rra_update rrd proc_pdp_st elapsed_pdp_st pdps ; - - (* Reset the PDP accumulators *) + (* Update the PDP accumulators up until the most recent PDP *) Array.iter (fun (i, value) -> let ds = rrd.rrd_dss.(i) in - if Utils.isnan value then ( - ds.ds_value <- 0.0 ; - ds.ds_unknown_sec <- post_int - ) else ( - ds.ds_unknown_sec <- 0.0 ; + if Utils.isnan value then + ds.ds_unknown_sec <- pre_int + else + (* CA-404597 - Gauge and Absolute values should be passed as-is, + without being involved in time-based calculations at all. + This applies to calculations below as well *) match ds.ds_ty with | Gauge | Absolute -> ds.ds_value <- value | Derive -> - ds.ds_value <- post_int *. value /. interval - ) + ds.ds_value <- ds.ds_value +. (pre_int *. value /. interval) ) - v2s + v2s ; + + (* If we've passed a PDP point, we need to update the RRAs *) + if elapsed_pdp_st > 0 then ( + (* Calculate the PDPs for each DS *) + let pdps = + Array.map + (fun (i, {transform; _}) -> + let ds = rrd.rrd_dss.(i) in + if interval > ds.ds_mrhb then + (i, nan) + else + let raw = + let proc_pdp_st = get_float_time last_updated rrd.timestep in + let occu_pdp_st = get_float_time timestamp rrd.timestep in + + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value + | Derive -> + ds.ds_value + /. (occu_pdp_st -. proc_pdp_st -. ds.ds_unknown_sec) + in + (* Apply the transform after the raw value has been calculated *) + let raw = apply_transform_function transform raw in + (* Make sure the values are not out of bounds after all the processing *) + if raw < ds.ds_min || raw > ds.ds_max then + (i, nan) + else + (i, raw) + ) + valuesandtransforms + in + + rra_update rrd proc_pdp_st elapsed_pdp_st pdps ; + + (* Reset the PDP accumulators *) + Array.iter + (fun (i, value) -> + let ds = rrd.rrd_dss.(i) in + if Utils.isnan value then ( + ds.ds_value <- 0.0 ; + ds.ds_unknown_sec <- post_int + ) else ( + ds.ds_unknown_sec <- 0.0 ; + match ds.ds_ty with + | Gauge | Absolute -> + ds.ds_value <- value + | Derive -> + ds.ds_value <- post_int *. value /. interval + ) + ) + v2s + ) ) (** Update the rrd with named values rather than just an ordered array From 7ca0ce2935907e5c283ddae0ff787ffaba488e7d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 31 Mar 2025 14:02:34 +0100 Subject: [PATCH 14/23] Remove xapi-stdext-date It's has been replaced by clock Signed-off-by: Pau Ruiz Safont --- Makefile | 2 +- dune-project | 10 -- .../xapi-stdext/lib/xapi-stdext-date/date.ml | 35 ------ .../xapi-stdext/lib/xapi-stdext-date/date.mli | 115 ------------------ .../xapi-stdext/lib/xapi-stdext-date/dune | 6 - xapi-stdext-date.opam | 29 ----- 6 files changed, 1 insertion(+), 196 deletions(-) delete mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml delete mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.mli delete mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune delete mode 100644 xapi-stdext-date.opam diff --git a/Makefile b/Makefile index d6099331c60..7d0677277fa 100644 --- a/Makefile +++ b/Makefile @@ -156,7 +156,7 @@ DUNE_IU_PACKAGES1+=message-switch message-switch-cli message-switch-core message DUNE_IU_PACKAGES1+=message-switch-unix xapi-idl xapi-forkexecd xapi-storage xapi-storage-script xapi-storage-cli DUNE_IU_PACKAGES1+=xapi-nbd varstored-guard xapi-log xapi-open-uri xapi-tracing xapi-tracing-export xapi-expiry-alerts cohttp-posix DUNE_IU_PACKAGES1+=xapi-rrd xapi-inventory clock xapi-sdk -DUNE_IU_PACKAGES1+=xapi-stdext-date xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-tools +DUNE_IU_PACKAGES1+=xapi-stdext-encodings xapi-stdext-pervasives xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xapi-stdext-zerocheck xapi-tools install-dune1: diff --git a/dune-project b/dune-project index 2d8cab13744..a3d6651fc45 100644 --- a/dune-project +++ b/dune-project @@ -669,16 +669,6 @@ This package provides an Lwt compatible interface to the library.") (name xapi-inventory) ) -(package - (name xapi-stdext-date) - (synopsis "Xapi's standard library extension, Dates") - (authors "Jonathan Ludlam") - (depends - (clock (= :version)) - ptime - ) -) - (package (name xapi-stdext-encodings) (synopsis "Xapi's standard library extension, Encodings") diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml deleted file mode 100644 index ef0f98ce13a..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml +++ /dev/null @@ -1,35 +0,0 @@ -(* - * 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. - *) - -include Clock.Date - -let never = epoch - -let of_string = of_iso8601 - -let to_string = to_rfc3339 - -let of_float = of_unix_time - -let to_float = to_unix_time - -let rfc822_of_float = of_unix_time - -let rfc822_to_string = to_rfc822 - -let eq = equal - -type iso8601 = t - -type rfc822 = t diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.mli deleted file mode 100644 index 9af45ab6096..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.mli +++ /dev/null @@ -1,115 +0,0 @@ -(* - * 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. - *) - -(** date-time with support for keeping timezone for ISO 8601 conversion *) -type t = Clock.Date.t - -(** Conversions *) - -val of_ptime : Ptime.t -> t -(** Convert ptime to time in UTC *) - -val to_ptime : t -> Ptime.t -(** Convert date/time to a ptime value: the number of seconds since 00:00:00 - UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) - -val of_unix_time : float -> t -(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC *) - -val to_unix_time : t -> float -(** Convert date/time to a unix timestamp: the number of seconds since - 00:00:00 UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) - -val to_rfc822 : t -> string -(** Convert date/time to email-formatted (RFC 822) string. *) - -val to_rfc3339 : t -> string -(** Convert date/time to an RFC-3339-formatted string. It also complies with - the ISO 8601 format *) - -val of_iso8601 : string -> t -(** Convert ISO 8601 formatted string to a date/time value. Does not accept a - timezone annotated datetime - i.e. string must be UTC, and end with a Z *) - -val epoch : t -(** 00:00:00 UTC, 1 Jan 1970, in UTC *) - -val now : unit -> t -(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) - -val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string -(** exposed for testing *) - -val localtime : unit -> t -(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in local - time *) - -(** Comparisons *) - -val equal : t -> t -> bool -(** [equal a b] returns whether [a] and [b] are equal *) - -val compare : t -> t -> int -(** [compare a b] returns -1 if [a] is earlier than [b], 1 if [a] is later than - [b] or the ordering of the timezone printer *) - -val is_earlier : than:t -> t -> bool -(** [is_earlier ~than a] returns whether the timestamp [a] happens before - [than] *) - -val is_later : than:t -> t -> bool -(** [is_later ~than a] returns whether the timestamp [a] happens after [than] - *) - -val diff : t -> t -> Ptime.Span.t -(** [diff a b] returns the span of time corresponding to [a - b] *) - -(** Deprecated bindings, these will be removed in a future release: *) - -val eq : t -> t -> bool -[@@deprecated "Use Date.equal"] -(** [eq a b] returns whether [a] and [b] are equal *) - -val rfc822_to_string : t -> string -[@@deprecated "Use Date.to_rfc822"] -(** Same as {!to_rfc822} *) - -val rfc822_of_float : float -> t -[@@deprecated "Use Date.of_unix_time"] -(** Same as {!of_unix_time} *) - -val of_float : float -> t -[@@deprecated "Use Date.of_unix_time"] -(** Same as {!of_unix_time} *) - -val to_float : t -> float -[@@deprecated "Use Date.to_unix_time"] -(** Same as {!to_unix_time} *) - -val to_string : t -> string -[@@deprecated "Use Date.to_rfc3339"] -(** Same as {!to_rfc3339} *) - -val of_string : string -> t -[@@deprecated "Use Date.of_iso8601"] -(** Same as {!of_iso8601} *) - -val never : t [@@deprecated "Use Date.epoch"] -(** Same as {!epoch} *) - -(** Deprecated alias for {!t} *) -type iso8601 = t [@@deprecated "Use Date.t"] - -(** Deprecated alias for {!t} *) -type rfc822 = t [@@deprecated "Use Date.t"] diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune deleted file mode 100644 index 8566d86e12c..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name xapi_stdext_date) - (public_name xapi-stdext-date) - (modules :standard) - (libraries clock ptime) -) diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam deleted file mode 100644 index 06021447900..00000000000 --- a/xapi-stdext-date.opam +++ /dev/null @@ -1,29 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -synopsis: "Xapi's standard library extension, Dates" -maintainer: ["Xapi project maintainers"] -authors: ["Jonathan Ludlam"] -license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception" -homepage: "https://xapi-project.github.io/" -bug-reports: "https://github.com/xapi-project/xen-api/issues" -depends: [ - "dune" {>= "3.15"} - "clock" {= version} - "ptime" - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/xapi-project/xen-api.git" From 8442197513e1d70a97e5a63c482d2772f79da2ad Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 2 Apr 2025 14:55:53 +0100 Subject: [PATCH 15/23] opam: move all opam files to the opam subdir This cleans up the root folder Signed-off-by: Pau Ruiz Safont --- dune-project | 1 + clock.opam => opam/clock.opam | 0 cohttp-posix.opam => opam/cohttp-posix.opam | 0 cohttp-posix.opam.template => opam/cohttp-posix.opam.template | 0 ezxenstore.opam => opam/ezxenstore.opam | 0 ezxenstore.opam.template => opam/ezxenstore.opam.template | 0 forkexec.opam => opam/forkexec.opam | 0 gzip.opam => opam/gzip.opam | 0 gzip.opam.template => opam/gzip.opam.template | 0 http-lib.opam => opam/http-lib.opam | 0 message-switch-cli.opam => opam/message-switch-cli.opam | 0 .../message-switch-cli.opam.template | 0 message-switch-core.opam => opam/message-switch-core.opam | 0 message-switch-lwt.opam => opam/message-switch-lwt.opam | 0 .../message-switch-lwt.opam.template | 0 message-switch-unix.opam => opam/message-switch-unix.opam | 0 message-switch.opam => opam/message-switch.opam | 0 .../message-switch.opam.template | 0 pciutil.opam => opam/pciutil.opam | 0 pciutil.opam.template => opam/pciutil.opam.template | 0 rrd-transport.opam => opam/rrd-transport.opam | 0 rrdd-plugin.opam => opam/rrdd-plugin.opam | 0 safe-resources.opam => opam/safe-resources.opam | 0 .../safe-resources.opam.template | 0 sexpr.opam => opam/sexpr.opam | 0 sexpr.opam.template => opam/sexpr.opam.template | 0 stunnel.opam => opam/stunnel.opam | 0 tgroup.opam => opam/tgroup.opam | 0 uuid.opam => opam/uuid.opam | 0 uuid.opam.template => opam/uuid.opam.template | 0 varstored-guard.opam => opam/varstored-guard.opam | 0 .../varstored-guard.opam.template | 0 vhd-format-lwt.opam => opam/vhd-format-lwt.opam | 0 .../vhd-format-lwt.opam.template | 0 vhd-format.opam => opam/vhd-format.opam | 0 vhd-format.opam.template => opam/vhd-format.opam.template | 0 vhd-tool.opam => opam/vhd-tool.opam | 0 xapi-cli-protocol.opam => opam/xapi-cli-protocol.opam | 0 .../xapi-cli-protocol.opam.template | 0 xapi-client.opam => opam/xapi-client.opam | 0 xapi-client.opam.template => opam/xapi-client.opam.template | 0 xapi-compression.opam => opam/xapi-compression.opam | 0 .../xapi-compression.opam.template | 0 xapi-consts.opam => opam/xapi-consts.opam | 0 xapi-consts.opam.template => opam/xapi-consts.opam.template | 0 xapi-datamodel.opam => opam/xapi-datamodel.opam | 0 .../xapi-datamodel.opam.template | 0 xapi-debug.opam => opam/xapi-debug.opam | 0 xapi-expiry-alerts.opam => opam/xapi-expiry-alerts.opam | 0 .../xapi-expiry-alerts.opam.template | 0 xapi-forkexecd.opam => opam/xapi-forkexecd.opam | 0 xapi-idl.opam => opam/xapi-idl.opam | 0 xapi-idl.opam.template => opam/xapi-idl.opam.template | 0 xapi-inventory.opam => opam/xapi-inventory.opam | 0 .../xapi-inventory.opam.template | 0 xapi-log.opam => opam/xapi-log.opam | 0 xapi-log.opam.template => opam/xapi-log.opam.template | 0 xapi-nbd.opam => opam/xapi-nbd.opam | 0 xapi-nbd.opam.template => opam/xapi-nbd.opam.template | 0 xapi-open-uri.opam => opam/xapi-open-uri.opam | 0 xapi-open-uri.opam.template => opam/xapi-open-uri.opam.template | 0 xapi-rrd.opam => opam/xapi-rrd.opam | 0 xapi-rrd.opam.template => opam/xapi-rrd.opam.template | 0 xapi-schema.opam => opam/xapi-schema.opam | 0 xapi-schema.opam.template => opam/xapi-schema.opam.template | 0 xapi-sdk.opam => opam/xapi-sdk.opam | 0 xapi-stdext-encodings.opam => opam/xapi-stdext-encodings.opam | 0 .../xapi-stdext-encodings.opam.template | 0 xapi-stdext-pervasives.opam => opam/xapi-stdext-pervasives.opam | 0 xapi-stdext-std.opam => opam/xapi-stdext-std.opam | 0 xapi-stdext-threads.opam => opam/xapi-stdext-threads.opam | 0 xapi-stdext-unix.opam => opam/xapi-stdext-unix.opam | 0 .../xapi-stdext-unix.opam.template | 0 xapi-stdext-zerocheck.opam => opam/xapi-stdext-zerocheck.opam | 0 xapi-storage-cli.opam => opam/xapi-storage-cli.opam | 0 .../xapi-storage-cli.opam.template | 0 xapi-storage-script.opam => opam/xapi-storage-script.opam | 0 .../xapi-storage-script.opam.template | 0 xapi-storage.opam => opam/xapi-storage.opam | 0 xapi-storage.opam.template => opam/xapi-storage.opam.template | 0 xapi-tools.opam => opam/xapi-tools.opam | 0 xapi-tools.opam.template => opam/xapi-tools.opam.template | 0 xapi-tracing-export.opam => opam/xapi-tracing-export.opam | 0 .../xapi-tracing-export.opam.template | 0 xapi-tracing.opam => opam/xapi-tracing.opam | 0 xapi-tracing.opam.template => opam/xapi-tracing.opam.template | 0 xapi-types.opam => opam/xapi-types.opam | 0 xapi-types.opam.template => opam/xapi-types.opam.template | 0 xapi.opam => opam/xapi.opam | 0 xapi.opam.template => opam/xapi.opam.template | 0 xe.opam => opam/xe.opam | 0 xe.opam.template => opam/xe.opam.template | 0 xen-api-client-lwt.opam => opam/xen-api-client-lwt.opam | 0 .../xen-api-client-lwt.opam.template | 0 xen-api-client.opam => opam/xen-api-client.opam | 0 xml-light2.opam => opam/xml-light2.opam | 0 xml-light2.opam.template => opam/xml-light2.opam.template | 0 zstd.opam => opam/zstd.opam | 0 zstd.opam.template => opam/zstd.opam.template | 0 99 files changed, 1 insertion(+) rename clock.opam => opam/clock.opam (100%) rename cohttp-posix.opam => opam/cohttp-posix.opam (100%) rename cohttp-posix.opam.template => opam/cohttp-posix.opam.template (100%) rename ezxenstore.opam => opam/ezxenstore.opam (100%) rename ezxenstore.opam.template => opam/ezxenstore.opam.template (100%) rename forkexec.opam => opam/forkexec.opam (100%) rename gzip.opam => opam/gzip.opam (100%) rename gzip.opam.template => opam/gzip.opam.template (100%) rename http-lib.opam => opam/http-lib.opam (100%) rename message-switch-cli.opam => opam/message-switch-cli.opam (100%) rename message-switch-cli.opam.template => opam/message-switch-cli.opam.template (100%) rename message-switch-core.opam => opam/message-switch-core.opam (100%) rename message-switch-lwt.opam => opam/message-switch-lwt.opam (100%) rename message-switch-lwt.opam.template => opam/message-switch-lwt.opam.template (100%) rename message-switch-unix.opam => opam/message-switch-unix.opam (100%) rename message-switch.opam => opam/message-switch.opam (100%) rename message-switch.opam.template => opam/message-switch.opam.template (100%) rename pciutil.opam => opam/pciutil.opam (100%) rename pciutil.opam.template => opam/pciutil.opam.template (100%) rename rrd-transport.opam => opam/rrd-transport.opam (100%) rename rrdd-plugin.opam => opam/rrdd-plugin.opam (100%) rename safe-resources.opam => opam/safe-resources.opam (100%) rename safe-resources.opam.template => opam/safe-resources.opam.template (100%) rename sexpr.opam => opam/sexpr.opam (100%) rename sexpr.opam.template => opam/sexpr.opam.template (100%) rename stunnel.opam => opam/stunnel.opam (100%) rename tgroup.opam => opam/tgroup.opam (100%) rename uuid.opam => opam/uuid.opam (100%) rename uuid.opam.template => opam/uuid.opam.template (100%) rename varstored-guard.opam => opam/varstored-guard.opam (100%) rename varstored-guard.opam.template => opam/varstored-guard.opam.template (100%) rename vhd-format-lwt.opam => opam/vhd-format-lwt.opam (100%) rename vhd-format-lwt.opam.template => opam/vhd-format-lwt.opam.template (100%) rename vhd-format.opam => opam/vhd-format.opam (100%) rename vhd-format.opam.template => opam/vhd-format.opam.template (100%) rename vhd-tool.opam => opam/vhd-tool.opam (100%) rename xapi-cli-protocol.opam => opam/xapi-cli-protocol.opam (100%) rename xapi-cli-protocol.opam.template => opam/xapi-cli-protocol.opam.template (100%) rename xapi-client.opam => opam/xapi-client.opam (100%) rename xapi-client.opam.template => opam/xapi-client.opam.template (100%) rename xapi-compression.opam => opam/xapi-compression.opam (100%) rename xapi-compression.opam.template => opam/xapi-compression.opam.template (100%) rename xapi-consts.opam => opam/xapi-consts.opam (100%) rename xapi-consts.opam.template => opam/xapi-consts.opam.template (100%) rename xapi-datamodel.opam => opam/xapi-datamodel.opam (100%) rename xapi-datamodel.opam.template => opam/xapi-datamodel.opam.template (100%) rename xapi-debug.opam => opam/xapi-debug.opam (100%) rename xapi-expiry-alerts.opam => opam/xapi-expiry-alerts.opam (100%) rename xapi-expiry-alerts.opam.template => opam/xapi-expiry-alerts.opam.template (100%) rename xapi-forkexecd.opam => opam/xapi-forkexecd.opam (100%) rename xapi-idl.opam => opam/xapi-idl.opam (100%) rename xapi-idl.opam.template => opam/xapi-idl.opam.template (100%) rename xapi-inventory.opam => opam/xapi-inventory.opam (100%) rename xapi-inventory.opam.template => opam/xapi-inventory.opam.template (100%) rename xapi-log.opam => opam/xapi-log.opam (100%) rename xapi-log.opam.template => opam/xapi-log.opam.template (100%) rename xapi-nbd.opam => opam/xapi-nbd.opam (100%) rename xapi-nbd.opam.template => opam/xapi-nbd.opam.template (100%) rename xapi-open-uri.opam => opam/xapi-open-uri.opam (100%) rename xapi-open-uri.opam.template => opam/xapi-open-uri.opam.template (100%) rename xapi-rrd.opam => opam/xapi-rrd.opam (100%) rename xapi-rrd.opam.template => opam/xapi-rrd.opam.template (100%) rename xapi-schema.opam => opam/xapi-schema.opam (100%) rename xapi-schema.opam.template => opam/xapi-schema.opam.template (100%) rename xapi-sdk.opam => opam/xapi-sdk.opam (100%) rename xapi-stdext-encodings.opam => opam/xapi-stdext-encodings.opam (100%) rename xapi-stdext-encodings.opam.template => opam/xapi-stdext-encodings.opam.template (100%) rename xapi-stdext-pervasives.opam => opam/xapi-stdext-pervasives.opam (100%) rename xapi-stdext-std.opam => opam/xapi-stdext-std.opam (100%) rename xapi-stdext-threads.opam => opam/xapi-stdext-threads.opam (100%) rename xapi-stdext-unix.opam => opam/xapi-stdext-unix.opam (100%) rename xapi-stdext-unix.opam.template => opam/xapi-stdext-unix.opam.template (100%) rename xapi-stdext-zerocheck.opam => opam/xapi-stdext-zerocheck.opam (100%) rename xapi-storage-cli.opam => opam/xapi-storage-cli.opam (100%) rename xapi-storage-cli.opam.template => opam/xapi-storage-cli.opam.template (100%) rename xapi-storage-script.opam => opam/xapi-storage-script.opam (100%) rename xapi-storage-script.opam.template => opam/xapi-storage-script.opam.template (100%) rename xapi-storage.opam => opam/xapi-storage.opam (100%) rename xapi-storage.opam.template => opam/xapi-storage.opam.template (100%) rename xapi-tools.opam => opam/xapi-tools.opam (100%) rename xapi-tools.opam.template => opam/xapi-tools.opam.template (100%) rename xapi-tracing-export.opam => opam/xapi-tracing-export.opam (100%) rename xapi-tracing-export.opam.template => opam/xapi-tracing-export.opam.template (100%) rename xapi-tracing.opam => opam/xapi-tracing.opam (100%) rename xapi-tracing.opam.template => opam/xapi-tracing.opam.template (100%) rename xapi-types.opam => opam/xapi-types.opam (100%) rename xapi-types.opam.template => opam/xapi-types.opam.template (100%) rename xapi.opam => opam/xapi.opam (100%) rename xapi.opam.template => opam/xapi.opam.template (100%) rename xe.opam => opam/xe.opam (100%) rename xe.opam.template => opam/xe.opam.template (100%) rename xen-api-client-lwt.opam => opam/xen-api-client-lwt.opam (100%) rename xen-api-client-lwt.opam.template => opam/xen-api-client-lwt.opam.template (100%) rename xen-api-client.opam => opam/xen-api-client.opam (100%) rename xml-light2.opam => opam/xml-light2.opam (100%) rename xml-light2.opam.template => opam/xml-light2.opam.template (100%) rename zstd.opam => opam/zstd.opam (100%) rename zstd.opam.template => opam/zstd.opam.template (100%) diff --git a/dune-project b/dune-project index a3d6651fc45..1de533b179d 100644 --- a/dune-project +++ b/dune-project @@ -3,6 +3,7 @@ (formatting (enabled_for ocaml)) (using menhir 2.0) (using directory-targets 0.1) +(opam_file_location inside_opam_directory) (cram enable) (implicit_transitive_deps false) diff --git a/clock.opam b/opam/clock.opam similarity index 100% rename from clock.opam rename to opam/clock.opam diff --git a/cohttp-posix.opam b/opam/cohttp-posix.opam similarity index 100% rename from cohttp-posix.opam rename to opam/cohttp-posix.opam diff --git a/cohttp-posix.opam.template b/opam/cohttp-posix.opam.template similarity index 100% rename from cohttp-posix.opam.template rename to opam/cohttp-posix.opam.template diff --git a/ezxenstore.opam b/opam/ezxenstore.opam similarity index 100% rename from ezxenstore.opam rename to opam/ezxenstore.opam diff --git a/ezxenstore.opam.template b/opam/ezxenstore.opam.template similarity index 100% rename from ezxenstore.opam.template rename to opam/ezxenstore.opam.template diff --git a/forkexec.opam b/opam/forkexec.opam similarity index 100% rename from forkexec.opam rename to opam/forkexec.opam diff --git a/gzip.opam b/opam/gzip.opam similarity index 100% rename from gzip.opam rename to opam/gzip.opam diff --git a/gzip.opam.template b/opam/gzip.opam.template similarity index 100% rename from gzip.opam.template rename to opam/gzip.opam.template diff --git a/http-lib.opam b/opam/http-lib.opam similarity index 100% rename from http-lib.opam rename to opam/http-lib.opam diff --git a/message-switch-cli.opam b/opam/message-switch-cli.opam similarity index 100% rename from message-switch-cli.opam rename to opam/message-switch-cli.opam diff --git a/message-switch-cli.opam.template b/opam/message-switch-cli.opam.template similarity index 100% rename from message-switch-cli.opam.template rename to opam/message-switch-cli.opam.template diff --git a/message-switch-core.opam b/opam/message-switch-core.opam similarity index 100% rename from message-switch-core.opam rename to opam/message-switch-core.opam diff --git a/message-switch-lwt.opam b/opam/message-switch-lwt.opam similarity index 100% rename from message-switch-lwt.opam rename to opam/message-switch-lwt.opam diff --git a/message-switch-lwt.opam.template b/opam/message-switch-lwt.opam.template similarity index 100% rename from message-switch-lwt.opam.template rename to opam/message-switch-lwt.opam.template diff --git a/message-switch-unix.opam b/opam/message-switch-unix.opam similarity index 100% rename from message-switch-unix.opam rename to opam/message-switch-unix.opam diff --git a/message-switch.opam b/opam/message-switch.opam similarity index 100% rename from message-switch.opam rename to opam/message-switch.opam diff --git a/message-switch.opam.template b/opam/message-switch.opam.template similarity index 100% rename from message-switch.opam.template rename to opam/message-switch.opam.template diff --git a/pciutil.opam b/opam/pciutil.opam similarity index 100% rename from pciutil.opam rename to opam/pciutil.opam diff --git a/pciutil.opam.template b/opam/pciutil.opam.template similarity index 100% rename from pciutil.opam.template rename to opam/pciutil.opam.template diff --git a/rrd-transport.opam b/opam/rrd-transport.opam similarity index 100% rename from rrd-transport.opam rename to opam/rrd-transport.opam diff --git a/rrdd-plugin.opam b/opam/rrdd-plugin.opam similarity index 100% rename from rrdd-plugin.opam rename to opam/rrdd-plugin.opam diff --git a/safe-resources.opam b/opam/safe-resources.opam similarity index 100% rename from safe-resources.opam rename to opam/safe-resources.opam diff --git a/safe-resources.opam.template b/opam/safe-resources.opam.template similarity index 100% rename from safe-resources.opam.template rename to opam/safe-resources.opam.template diff --git a/sexpr.opam b/opam/sexpr.opam similarity index 100% rename from sexpr.opam rename to opam/sexpr.opam diff --git a/sexpr.opam.template b/opam/sexpr.opam.template similarity index 100% rename from sexpr.opam.template rename to opam/sexpr.opam.template diff --git a/stunnel.opam b/opam/stunnel.opam similarity index 100% rename from stunnel.opam rename to opam/stunnel.opam diff --git a/tgroup.opam b/opam/tgroup.opam similarity index 100% rename from tgroup.opam rename to opam/tgroup.opam diff --git a/uuid.opam b/opam/uuid.opam similarity index 100% rename from uuid.opam rename to opam/uuid.opam diff --git a/uuid.opam.template b/opam/uuid.opam.template similarity index 100% rename from uuid.opam.template rename to opam/uuid.opam.template diff --git a/varstored-guard.opam b/opam/varstored-guard.opam similarity index 100% rename from varstored-guard.opam rename to opam/varstored-guard.opam diff --git a/varstored-guard.opam.template b/opam/varstored-guard.opam.template similarity index 100% rename from varstored-guard.opam.template rename to opam/varstored-guard.opam.template diff --git a/vhd-format-lwt.opam b/opam/vhd-format-lwt.opam similarity index 100% rename from vhd-format-lwt.opam rename to opam/vhd-format-lwt.opam diff --git a/vhd-format-lwt.opam.template b/opam/vhd-format-lwt.opam.template similarity index 100% rename from vhd-format-lwt.opam.template rename to opam/vhd-format-lwt.opam.template diff --git a/vhd-format.opam b/opam/vhd-format.opam similarity index 100% rename from vhd-format.opam rename to opam/vhd-format.opam diff --git a/vhd-format.opam.template b/opam/vhd-format.opam.template similarity index 100% rename from vhd-format.opam.template rename to opam/vhd-format.opam.template diff --git a/vhd-tool.opam b/opam/vhd-tool.opam similarity index 100% rename from vhd-tool.opam rename to opam/vhd-tool.opam diff --git a/xapi-cli-protocol.opam b/opam/xapi-cli-protocol.opam similarity index 100% rename from xapi-cli-protocol.opam rename to opam/xapi-cli-protocol.opam diff --git a/xapi-cli-protocol.opam.template b/opam/xapi-cli-protocol.opam.template similarity index 100% rename from xapi-cli-protocol.opam.template rename to opam/xapi-cli-protocol.opam.template diff --git a/xapi-client.opam b/opam/xapi-client.opam similarity index 100% rename from xapi-client.opam rename to opam/xapi-client.opam diff --git a/xapi-client.opam.template b/opam/xapi-client.opam.template similarity index 100% rename from xapi-client.opam.template rename to opam/xapi-client.opam.template diff --git a/xapi-compression.opam b/opam/xapi-compression.opam similarity index 100% rename from xapi-compression.opam rename to opam/xapi-compression.opam diff --git a/xapi-compression.opam.template b/opam/xapi-compression.opam.template similarity index 100% rename from xapi-compression.opam.template rename to opam/xapi-compression.opam.template diff --git a/xapi-consts.opam b/opam/xapi-consts.opam similarity index 100% rename from xapi-consts.opam rename to opam/xapi-consts.opam diff --git a/xapi-consts.opam.template b/opam/xapi-consts.opam.template similarity index 100% rename from xapi-consts.opam.template rename to opam/xapi-consts.opam.template diff --git a/xapi-datamodel.opam b/opam/xapi-datamodel.opam similarity index 100% rename from xapi-datamodel.opam rename to opam/xapi-datamodel.opam diff --git a/xapi-datamodel.opam.template b/opam/xapi-datamodel.opam.template similarity index 100% rename from xapi-datamodel.opam.template rename to opam/xapi-datamodel.opam.template diff --git a/xapi-debug.opam b/opam/xapi-debug.opam similarity index 100% rename from xapi-debug.opam rename to opam/xapi-debug.opam diff --git a/xapi-expiry-alerts.opam b/opam/xapi-expiry-alerts.opam similarity index 100% rename from xapi-expiry-alerts.opam rename to opam/xapi-expiry-alerts.opam diff --git a/xapi-expiry-alerts.opam.template b/opam/xapi-expiry-alerts.opam.template similarity index 100% rename from xapi-expiry-alerts.opam.template rename to opam/xapi-expiry-alerts.opam.template diff --git a/xapi-forkexecd.opam b/opam/xapi-forkexecd.opam similarity index 100% rename from xapi-forkexecd.opam rename to opam/xapi-forkexecd.opam diff --git a/xapi-idl.opam b/opam/xapi-idl.opam similarity index 100% rename from xapi-idl.opam rename to opam/xapi-idl.opam diff --git a/xapi-idl.opam.template b/opam/xapi-idl.opam.template similarity index 100% rename from xapi-idl.opam.template rename to opam/xapi-idl.opam.template diff --git a/xapi-inventory.opam b/opam/xapi-inventory.opam similarity index 100% rename from xapi-inventory.opam rename to opam/xapi-inventory.opam diff --git a/xapi-inventory.opam.template b/opam/xapi-inventory.opam.template similarity index 100% rename from xapi-inventory.opam.template rename to opam/xapi-inventory.opam.template diff --git a/xapi-log.opam b/opam/xapi-log.opam similarity index 100% rename from xapi-log.opam rename to opam/xapi-log.opam diff --git a/xapi-log.opam.template b/opam/xapi-log.opam.template similarity index 100% rename from xapi-log.opam.template rename to opam/xapi-log.opam.template diff --git a/xapi-nbd.opam b/opam/xapi-nbd.opam similarity index 100% rename from xapi-nbd.opam rename to opam/xapi-nbd.opam diff --git a/xapi-nbd.opam.template b/opam/xapi-nbd.opam.template similarity index 100% rename from xapi-nbd.opam.template rename to opam/xapi-nbd.opam.template diff --git a/xapi-open-uri.opam b/opam/xapi-open-uri.opam similarity index 100% rename from xapi-open-uri.opam rename to opam/xapi-open-uri.opam diff --git a/xapi-open-uri.opam.template b/opam/xapi-open-uri.opam.template similarity index 100% rename from xapi-open-uri.opam.template rename to opam/xapi-open-uri.opam.template diff --git a/xapi-rrd.opam b/opam/xapi-rrd.opam similarity index 100% rename from xapi-rrd.opam rename to opam/xapi-rrd.opam diff --git a/xapi-rrd.opam.template b/opam/xapi-rrd.opam.template similarity index 100% rename from xapi-rrd.opam.template rename to opam/xapi-rrd.opam.template diff --git a/xapi-schema.opam b/opam/xapi-schema.opam similarity index 100% rename from xapi-schema.opam rename to opam/xapi-schema.opam diff --git a/xapi-schema.opam.template b/opam/xapi-schema.opam.template similarity index 100% rename from xapi-schema.opam.template rename to opam/xapi-schema.opam.template diff --git a/xapi-sdk.opam b/opam/xapi-sdk.opam similarity index 100% rename from xapi-sdk.opam rename to opam/xapi-sdk.opam diff --git a/xapi-stdext-encodings.opam b/opam/xapi-stdext-encodings.opam similarity index 100% rename from xapi-stdext-encodings.opam rename to opam/xapi-stdext-encodings.opam diff --git a/xapi-stdext-encodings.opam.template b/opam/xapi-stdext-encodings.opam.template similarity index 100% rename from xapi-stdext-encodings.opam.template rename to opam/xapi-stdext-encodings.opam.template diff --git a/xapi-stdext-pervasives.opam b/opam/xapi-stdext-pervasives.opam similarity index 100% rename from xapi-stdext-pervasives.opam rename to opam/xapi-stdext-pervasives.opam diff --git a/xapi-stdext-std.opam b/opam/xapi-stdext-std.opam similarity index 100% rename from xapi-stdext-std.opam rename to opam/xapi-stdext-std.opam diff --git a/xapi-stdext-threads.opam b/opam/xapi-stdext-threads.opam similarity index 100% rename from xapi-stdext-threads.opam rename to opam/xapi-stdext-threads.opam diff --git a/xapi-stdext-unix.opam b/opam/xapi-stdext-unix.opam similarity index 100% rename from xapi-stdext-unix.opam rename to opam/xapi-stdext-unix.opam diff --git a/xapi-stdext-unix.opam.template b/opam/xapi-stdext-unix.opam.template similarity index 100% rename from xapi-stdext-unix.opam.template rename to opam/xapi-stdext-unix.opam.template diff --git a/xapi-stdext-zerocheck.opam b/opam/xapi-stdext-zerocheck.opam similarity index 100% rename from xapi-stdext-zerocheck.opam rename to opam/xapi-stdext-zerocheck.opam diff --git a/xapi-storage-cli.opam b/opam/xapi-storage-cli.opam similarity index 100% rename from xapi-storage-cli.opam rename to opam/xapi-storage-cli.opam diff --git a/xapi-storage-cli.opam.template b/opam/xapi-storage-cli.opam.template similarity index 100% rename from xapi-storage-cli.opam.template rename to opam/xapi-storage-cli.opam.template diff --git a/xapi-storage-script.opam b/opam/xapi-storage-script.opam similarity index 100% rename from xapi-storage-script.opam rename to opam/xapi-storage-script.opam diff --git a/xapi-storage-script.opam.template b/opam/xapi-storage-script.opam.template similarity index 100% rename from xapi-storage-script.opam.template rename to opam/xapi-storage-script.opam.template diff --git a/xapi-storage.opam b/opam/xapi-storage.opam similarity index 100% rename from xapi-storage.opam rename to opam/xapi-storage.opam diff --git a/xapi-storage.opam.template b/opam/xapi-storage.opam.template similarity index 100% rename from xapi-storage.opam.template rename to opam/xapi-storage.opam.template diff --git a/xapi-tools.opam b/opam/xapi-tools.opam similarity index 100% rename from xapi-tools.opam rename to opam/xapi-tools.opam diff --git a/xapi-tools.opam.template b/opam/xapi-tools.opam.template similarity index 100% rename from xapi-tools.opam.template rename to opam/xapi-tools.opam.template diff --git a/xapi-tracing-export.opam b/opam/xapi-tracing-export.opam similarity index 100% rename from xapi-tracing-export.opam rename to opam/xapi-tracing-export.opam diff --git a/xapi-tracing-export.opam.template b/opam/xapi-tracing-export.opam.template similarity index 100% rename from xapi-tracing-export.opam.template rename to opam/xapi-tracing-export.opam.template diff --git a/xapi-tracing.opam b/opam/xapi-tracing.opam similarity index 100% rename from xapi-tracing.opam rename to opam/xapi-tracing.opam diff --git a/xapi-tracing.opam.template b/opam/xapi-tracing.opam.template similarity index 100% rename from xapi-tracing.opam.template rename to opam/xapi-tracing.opam.template diff --git a/xapi-types.opam b/opam/xapi-types.opam similarity index 100% rename from xapi-types.opam rename to opam/xapi-types.opam diff --git a/xapi-types.opam.template b/opam/xapi-types.opam.template similarity index 100% rename from xapi-types.opam.template rename to opam/xapi-types.opam.template diff --git a/xapi.opam b/opam/xapi.opam similarity index 100% rename from xapi.opam rename to opam/xapi.opam diff --git a/xapi.opam.template b/opam/xapi.opam.template similarity index 100% rename from xapi.opam.template rename to opam/xapi.opam.template diff --git a/xe.opam b/opam/xe.opam similarity index 100% rename from xe.opam rename to opam/xe.opam diff --git a/xe.opam.template b/opam/xe.opam.template similarity index 100% rename from xe.opam.template rename to opam/xe.opam.template diff --git a/xen-api-client-lwt.opam b/opam/xen-api-client-lwt.opam similarity index 100% rename from xen-api-client-lwt.opam rename to opam/xen-api-client-lwt.opam diff --git a/xen-api-client-lwt.opam.template b/opam/xen-api-client-lwt.opam.template similarity index 100% rename from xen-api-client-lwt.opam.template rename to opam/xen-api-client-lwt.opam.template diff --git a/xen-api-client.opam b/opam/xen-api-client.opam similarity index 100% rename from xen-api-client.opam rename to opam/xen-api-client.opam diff --git a/xml-light2.opam b/opam/xml-light2.opam similarity index 100% rename from xml-light2.opam rename to opam/xml-light2.opam diff --git a/xml-light2.opam.template b/opam/xml-light2.opam.template similarity index 100% rename from xml-light2.opam.template rename to opam/xml-light2.opam.template diff --git a/zstd.opam b/opam/zstd.opam similarity index 100% rename from zstd.opam rename to opam/zstd.opam diff --git a/zstd.opam.template b/opam/zstd.opam.template similarity index 100% rename from zstd.opam.template rename to opam/zstd.opam.template From 08fc9cfd11dff35e5f0524007a8df23a2cd0dd50 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 2 Apr 2025 15:17:23 +0100 Subject: [PATCH 16/23] github: update docs workflow to use latest setup-ocaml Signed-off-by: Pau Ruiz Safont --- .github/workflows/docs.yml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index 94c7c1a687e..08d381eeaae 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -31,15 +31,23 @@ jobs: - name: Update Ubuntu repositories run: sudo apt-get update + # We set DUNE_CACHE_STORAGE_MODE, it is required for dune cache to work inside opam for now, + # otherwise it gets EXDEV and considers it a cache miss - name: Use ocaml - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ steps.dotenv.outputs.ocaml_version_full }} opam-repositories: | xs-opam: ${{ steps.dotenv.outputs.repository }} + dune-cache: true + opam-pin: false + cache-prefix: v3-${{ steps.system-info.outputs.name }}-${{ steps.system-info.outputs.release }} + env: + DUNE_CACHE_STORAGE_MODE: copy - name: Install dependencies - run: opam pin list --short | xargs opam install --deps-only -v + shell: bash + run: opam install . --deps-only -v - name: Generate xapi-storage docs run: | From 586921f3a2dd278815da0b05510e3b51b27dd848 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Mar 2025 10:51:15 +0000 Subject: [PATCH 17/23] maintenance: replace most 'maybe' functions Many years ago, 'maybe' used to be a synonym for Option.iter, Option.map and other functions. Use Option.x directly to avoid any misunderstnadings Signed-off-by: Pau Ruiz Safont --- ocaml/xapi-client/event_helper.ml | 96 +++++++++++++++++++++---------- ocaml/xenopsd/xc/domain.ml | 6 +- 2 files changed, 68 insertions(+), 34 deletions(-) diff --git a/ocaml/xapi-client/event_helper.ml b/ocaml/xapi-client/event_helper.ml index 3ec6e7f9236..cbbeb978ba2 100644 --- a/ocaml/xapi-client/event_helper.ml +++ b/ocaml/xapi-client/event_helper.ml @@ -43,96 +43,132 @@ type event_record = | VMPP of [`VMPP] Ref.t * API.vMPP_t option | VMSS of [`VMSS] Ref.t * API.vMSS_t option -let maybe f x = match x with Some x -> Some (f x) | None -> None - let record_of_event ev = let rpc = ev.Event_types.snapshot in match ev.Event_types.ty with | "session" -> Session ( Ref.of_secret_string ev.Event_types.reference - , maybe API.session_t_of_rpc rpc + , Option.map API.session_t_of_rpc rpc ) | "task" -> - Task (Ref.of_string ev.Event_types.reference, maybe API.task_t_of_rpc rpc) + Task + ( Ref.of_string ev.Event_types.reference + , Option.map API.task_t_of_rpc rpc + ) | "event" -> Event - (Ref.of_string ev.Event_types.reference, maybe API.event_t_of_rpc rpc) + ( Ref.of_string ev.Event_types.reference + , Option.map API.event_t_of_rpc rpc + ) | "vm" -> - VM (Ref.of_string ev.Event_types.reference, maybe API.vM_t_of_rpc rpc) + VM (Ref.of_string ev.Event_types.reference, Option.map API.vM_t_of_rpc rpc) | "vm_metrics" -> VM_metrics ( Ref.of_string ev.Event_types.reference - , maybe API.vM_metrics_t_of_rpc rpc + , Option.map API.vM_metrics_t_of_rpc rpc ) | "vm_guest_metrics" -> VM_guest_metrics ( Ref.of_string ev.Event_types.reference - , maybe API.vM_guest_metrics_t_of_rpc rpc + , Option.map API.vM_guest_metrics_t_of_rpc rpc ) | "host" -> - Host (Ref.of_string ev.Event_types.reference, maybe API.host_t_of_rpc rpc) + Host + ( Ref.of_string ev.Event_types.reference + , Option.map API.host_t_of_rpc rpc + ) | "host_metrics" -> Host_metrics ( Ref.of_string ev.Event_types.reference - , maybe API.host_metrics_t_of_rpc rpc + , Option.map API.host_metrics_t_of_rpc rpc ) | "host_cpu" -> Host_cpu - (Ref.of_string ev.Event_types.reference, maybe API.host_cpu_t_of_rpc rpc) + ( Ref.of_string ev.Event_types.reference + , Option.map API.host_cpu_t_of_rpc rpc + ) | "network" -> Network - (Ref.of_string ev.Event_types.reference, maybe API.network_t_of_rpc rpc) + ( Ref.of_string ev.Event_types.reference + , Option.map API.network_t_of_rpc rpc + ) | "vif" -> - VIF (Ref.of_string ev.Event_types.reference, maybe API.vIF_t_of_rpc rpc) + VIF + (Ref.of_string ev.Event_types.reference, Option.map API.vIF_t_of_rpc rpc) | "vif_metrics" -> VIF_metrics ( Ref.of_string ev.Event_types.reference - , maybe API.vIF_metrics_t_of_rpc rpc + , Option.map API.vIF_metrics_t_of_rpc rpc ) | "pif" -> - PIF (Ref.of_string ev.Event_types.reference, maybe API.pIF_t_of_rpc rpc) + PIF + (Ref.of_string ev.Event_types.reference, Option.map API.pIF_t_of_rpc rpc) | "pif_metrics" -> PIF_metrics ( Ref.of_string ev.Event_types.reference - , maybe API.pIF_metrics_t_of_rpc rpc + , Option.map API.pIF_metrics_t_of_rpc rpc ) | "sr" -> - SR (Ref.of_string ev.Event_types.reference, maybe API.sR_t_of_rpc rpc) + SR (Ref.of_string ev.Event_types.reference, Option.map API.sR_t_of_rpc rpc) | "vdi" -> - VDI (Ref.of_string ev.Event_types.reference, maybe API.vDI_t_of_rpc rpc) + VDI + (Ref.of_string ev.Event_types.reference, Option.map API.vDI_t_of_rpc rpc) | "vbd" -> - VBD (Ref.of_string ev.Event_types.reference, maybe API.vBD_t_of_rpc rpc) + VBD + (Ref.of_string ev.Event_types.reference, Option.map API.vBD_t_of_rpc rpc) | "vbd_metrics" -> VBD_metrics ( Ref.of_string ev.Event_types.reference - , maybe API.vBD_metrics_t_of_rpc rpc + , Option.map API.vBD_metrics_t_of_rpc rpc ) | "pbd" -> - PBD (Ref.of_string ev.Event_types.reference, maybe API.pBD_t_of_rpc rpc) + PBD + (Ref.of_string ev.Event_types.reference, Option.map API.pBD_t_of_rpc rpc) | "crashdump" -> Crashdump ( Ref.of_string ev.Event_types.reference - , maybe API.crashdump_t_of_rpc rpc + , Option.map API.crashdump_t_of_rpc rpc ) | "vtpm" -> - VTPM (Ref.of_string ev.Event_types.reference, maybe API.vTPM_t_of_rpc rpc) + VTPM + ( Ref.of_string ev.Event_types.reference + , Option.map API.vTPM_t_of_rpc rpc + ) | "console" -> Console - (Ref.of_string ev.Event_types.reference, maybe API.console_t_of_rpc rpc) + ( Ref.of_string ev.Event_types.reference + , Option.map API.console_t_of_rpc rpc + ) | "user" -> - User (Ref.of_string ev.Event_types.reference, maybe API.user_t_of_rpc rpc) + User + ( Ref.of_string ev.Event_types.reference + , Option.map API.user_t_of_rpc rpc + ) | "pool" -> - Pool (Ref.of_string ev.Event_types.reference, maybe API.pool_t_of_rpc rpc) + Pool + ( Ref.of_string ev.Event_types.reference + , Option.map API.pool_t_of_rpc rpc + ) | "message" -> Message - (Ref.of_string ev.Event_types.reference, maybe API.message_t_of_rpc rpc) + ( Ref.of_string ev.Event_types.reference + , Option.map API.message_t_of_rpc rpc + ) | "secret" -> Secret - (Ref.of_string ev.Event_types.reference, maybe API.secret_t_of_rpc rpc) + ( Ref.of_string ev.Event_types.reference + , Option.map API.secret_t_of_rpc rpc + ) | "vmpp" -> - VMPP (Ref.of_string ev.Event_types.reference, maybe API.vMPP_t_of_rpc rpc) + VMPP + ( Ref.of_string ev.Event_types.reference + , Option.map API.vMPP_t_of_rpc rpc + ) | "vmss" -> - VMSS (Ref.of_string ev.Event_types.reference, maybe API.vMSS_t_of_rpc rpc) + VMSS + ( Ref.of_string ev.Event_types.reference + , Option.map API.vMSS_t_of_rpc rpc + ) | _ -> failwith "unknown event type" diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index 07b1957db8c..a9022f26565 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -204,8 +204,6 @@ let assert_file_is_readable filename = error "Cannot read file %s" filename ; raise (Could_not_read_file filename) -let maybe f = function None -> () | Some x -> f x - (* Recursively iterate over a directory and all its children, calling fn for each *) let rec xenstore_iter t fn path = @@ -931,7 +929,7 @@ let build_pre ~xc ~xs ~vcpus ~memory ~has_hard_affinity domid = error "VM = %s; domid = %d; %s" (Uuidx.to_string uuid) domid err_msg ; raise (Domain_build_pre_failed err_msg) in - maybe + Option.iter (fun mode -> log_reraise (Printf.sprintf "domain_set_timer_mode %d" mode) (fun () -> let xcext = Xenctrlext.get_handle () in @@ -1163,7 +1161,7 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid Memory.Linux.full_config static_max_mib video_mib target_mib vcpus shadow_multiplier in - maybe assert_file_is_readable pvinfo.ramdisk ; + Option.iter assert_file_is_readable pvinfo.ramdisk ; let store_port, console_port = build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity domid in From 3bf9f907bf867a04d686dd9b3b684574aedb314c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 4 Mar 2025 16:34:21 +0000 Subject: [PATCH 18/23] numa: add test binary that prints changes in free memory and domain lifetime Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/xc/dune | 18 ++-- ocaml/xenopsd/xc/numa.ml | 176 ++++++++++++++++++++++++++++++++++++++ ocaml/xenopsd/xc/numa.mli | 0 3 files changed, 188 insertions(+), 6 deletions(-) create mode 100644 ocaml/xenopsd/xc/numa.ml create mode 100644 ocaml/xenopsd/xc/numa.mli diff --git a/ocaml/xenopsd/xc/dune b/ocaml/xenopsd/xc/dune index f04f082d086..1bf73af404f 100644 --- a/ocaml/xenopsd/xc/dune +++ b/ocaml/xenopsd/xc/dune @@ -2,6 +2,7 @@ (name xenopsd_xc) (modes best) (modules :standard \ + numa xenops_xc_main memory_breakdown memory_summary @@ -68,13 +69,18 @@ ) (wrapped false) ) + +(executable + (name numa) + (modules numa) + (libraries fmt logs logs.fmt mtime mtime.clock threads.posix xenctrl xenopsd_xc) +) + (executable (name xenops_xc_main) (modes exe) (modules xenops_xc_main) - (libraries - ezxenstore.core uuid xapi-idl @@ -95,7 +101,7 @@ (libraries astring cmdliner - + ezxenstore.core uuid xapi-idl.memory @@ -112,13 +118,13 @@ (section sbin) (package xapi-tools) ) - + (executable (name memory_summary) (modes exe) (modules memory_summary) (libraries - + clock xapi-stdext-unix xapi_xenopsd @@ -143,7 +149,7 @@ (modules cancel_utils_test) (libraries cmdliner - + ezxenstore.core threads.posix xapi-idl.xen.interface diff --git a/ocaml/xenopsd/xc/numa.ml b/ocaml/xenopsd/xc/numa.ml new file mode 100644 index 00000000000..99f6473e9e4 --- /dev/null +++ b/ocaml/xenopsd/xc/numa.ml @@ -0,0 +1,176 @@ +(* Copyright (C) 2025 Cloud Software Group + + 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. +*) + +(* Monitoring loop that keeps track of per-numa-node memory changes, and prints + the change. Useful to see whether memory scrubbing is seen as used or free + memory by userspace *) +open! Xenctrlext + +let ( let@ ) f x = f x + +let stamp_tag : Mtime.span Logs.Tag.def = + Logs.Tag.def "stamp" ~doc:"Relative monotonic time stamp" Mtime.Span.pp + +let stamp c = Logs.Tag.(empty |> add stamp_tag (Mtime_clock.count c)) + +let xc = get_handle () + +let binary_prefixes = [""; "Ki"; "Mi"; "Gi"; "Ti"; "Pi"] + +let human_readable_bytes quantity = + let unit = "Bs" in + let print prefix q = Printf.sprintf "%Ld %s%s" q prefix unit in + let rec loop acc q = function + | [] -> + acc + | pre :: prefs -> + let quotient = Int64.div q 1024L in + let modulus = Int64.rem q 1024L in + let acc = + if Int64.equal modulus 0L then acc else print pre modulus :: acc + in + loop acc quotient prefs + in + if quantity = 0L then + print "" 0L + else + loop [] quantity binary_prefixes |> String.concat ", " + +let get_memory () = + let {memory; _} = numainfo xc in + memory + +let print_mem c mem = + for i = 0 to Array.length mem - 1 do + let {memfree; memsize} = mem.(i) in + let memfree = human_readable_bytes memfree in + let memsize = human_readable_bytes memsize in + Logs.app (fun m -> + m "\t%d: %s free out of %s" i memfree memsize ~tags:(stamp c) + ) + done + +let print_diff_mem before after = + if before > after then + Printf.sprintf "%s 🢆 " (Int64.sub before after |> human_readable_bytes) + else + Printf.sprintf "%s 🢅 " (Int64.sub after before |> human_readable_bytes) + +let diff c old cur = + let changed_yet = ref false in + for i = 0 to Int.min (Array.length old) (Array.length cur) - 1 do + let {memfree= a_free; _}, {memfree= b_free; _} = (old.(i), cur.(i)) in + if a_free <> b_free then ( + if not !changed_yet then + changed_yet := true ; + let free = human_readable_bytes b_free in + let updown = print_diff_mem a_free b_free in + Logs.app (fun m -> + m "\t%d: %s free (%s)" i free updown ~tags:(stamp (c ())) + ) + ) + done ; + !changed_yet + +let reporter ppf = + let report _src level ~over k msgf = + let k _ = over () ; k () in + let with_stamp h tags k ppf fmt = + let stamp = + match tags with + | None -> + None + | Some tags -> + Logs.Tag.find stamp_tag tags + in + let span_pp s = + match s with + | None -> + "0ns" + | Some s -> + Fmt.to_to_string Mtime.Span.pp s + in + Format.kfprintf k ppf + ("%a[%s] @[" ^^ fmt ^^ "@]@.") + Logs.pp_header (level, h) (span_pp stamp) + in + msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt + in + {Logs.report} + +let memory_changes () = + let max_time = Mtime.Span.(7 * s) in + + let memory = get_memory () in + let c = Mtime_clock.counter () in + print_mem c memory ; + let rec loop since_started since_changed previous = + let current = get_memory () in + + let since_started = ref since_started in + let timer () = + let last_changed = Mtime_clock.count since_changed in + if Mtime.Span.is_longer last_changed ~than:max_time then + since_started := Mtime_clock.counter () ; + !since_started + in + + let changed = diff timer previous current in + + let since_changed = + if changed then + Mtime_clock.counter () + else + !since_started + in + Unix.sleepf 0.01 ; + loop !since_started since_changed current + in + loop c c memory + +module DomainSet = Set.Make (Int) + +let get_domains xc = + Xenctrl.domain_getinfolist xc 0 + |> List.to_seq + |> Seq.map (function Xenctrl.{domid; _} -> domid) + |> DomainSet.of_seq + +let diff_domains c previous current = + let added = DomainSet.diff current previous in + let removed = DomainSet.diff previous current in + DomainSet.iter + (fun id -> Logs.app (fun m -> m "domain %d added" id ~tags:(stamp c))) + added ; + DomainSet.iter + (fun id -> Logs.app (fun m -> m "domain %d removed" id ~tags:(stamp c))) + removed + +let domain_changes xc = + let domains = get_domains xc in + let c = Mtime_clock.counter () in + let rec loop previous = + let current = get_domains xc in + diff_domains c previous current ; + Unix.sleepf 0.01 ; + loop current + in + loop domains + +let () = + Logs.set_reporter (reporter Format.std_formatter) ; + Logs.set_level (Some Logs.Info) ; + + ignore (Thread.create memory_changes () : Thread.t) ; + let@ xc = Xenctrl.with_intf in + domain_changes xc diff --git a/ocaml/xenopsd/xc/numa.mli b/ocaml/xenopsd/xc/numa.mli new file mode 100644 index 00000000000..e69de29bb2d From 6a915a3eb4eb78ab570b28aa41084e1955c9e228 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 10 Mar 2025 11:51:33 +0000 Subject: [PATCH 19/23] CP-53658: adapt claim_pages to new version with numa node parameter Now the numa node needs to be passed. A special value of -1n is used to signify that no node is meant to be used. Since this is arch-dependent, a Nativeint.t is used to encode the value. Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/c_stubs/xenctrlext_stubs.c | 7 ++++--- ocaml/xenopsd/xc/xenctrlext.ml | 15 ++++++++++++++- ocaml/xenopsd/xc/xenctrlext.mli | 11 +++++++++-- 3 files changed, 27 insertions(+), 6 deletions(-) diff --git a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c b/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c index 0e427548ed4..2cdcfe37b3d 100644 --- a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c +++ b/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c @@ -672,16 +672,17 @@ CAMLprim value stub_xenforeignmemory_unmap(value fmem, value mapping) } CAMLprim value stub_xenctrlext_domain_claim_pages(value xch_val, value domid_val, - value nr_pages_val) + value numa_node_val, value nr_pages_val) { - CAMLparam3(xch_val, domid_val, nr_pages_val); + CAMLparam4(xch_val, domid_val, numa_node_val, nr_pages_val); int retval, the_errno; xc_interface* xch = xch_of_val(xch_val); uint32_t domid = Int_val(domid_val); + unsigned int numa_node = Int_val(numa_node_val); unsigned long nr_pages = Long_val(nr_pages_val); caml_release_runtime_system(); - retval = xc_domain_claim_pages(xch, domid, nr_pages); + retval = xc_domain_claim_pages(xch, domid, numa_node, nr_pages); the_errno = errno; caml_acquire_runtime_system(); diff --git a/ocaml/xenopsd/xc/xenctrlext.ml b/ocaml/xenopsd/xc/xenctrlext.ml index 5cea490864a..a0e0c0ed311 100644 --- a/ocaml/xenopsd/xc/xenctrlext.ml +++ b/ocaml/xenopsd/xc/xenctrlext.ml @@ -109,5 +109,18 @@ external combine_cpu_policies : int64 array -> int64 array -> int64 array external policy_is_compatible : int64 array -> int64 array -> string option = "stub_xenctrlext_featuresets_are_compatible" -external domain_claim_pages : handle -> domid -> int -> unit +external stub_domain_claim_pages : handle -> domid -> int -> int -> unit = "stub_xenctrlext_domain_claim_pages" + +module NumaNode = struct + type t = int + + (** Defined as XC_NUMA_NO_NODE in xen.git/tools/include/xenguest.h, it's an + unsigned int (~0U) *) + let none = 0xFFFFFFFF + + let from = Fun.id +end + +let domain_claim_pages handle domid ?(numa_node = NumaNode.none) nr_pages = + stub_domain_claim_pages handle domid numa_node nr_pages diff --git a/ocaml/xenopsd/xc/xenctrlext.mli b/ocaml/xenopsd/xc/xenctrlext.mli index 2a4632780ce..39c6eeff514 100644 --- a/ocaml/xenopsd/xc/xenctrlext.mli +++ b/ocaml/xenopsd/xc/xenctrlext.mli @@ -91,5 +91,12 @@ external combine_cpu_policies : int64 array -> int64 array -> int64 array external policy_is_compatible : int64 array -> int64 array -> string option = "stub_xenctrlext_featuresets_are_compatible" -external domain_claim_pages : handle -> domid -> int -> unit - = "stub_xenctrlext_domain_claim_pages" +module NumaNode : sig + type t + + val none : t + + val from : int -> t +end + +val domain_claim_pages : handle -> domid -> ?numa_node:NumaNode.t -> int -> unit From 33abbd28e18a20a1060eaa7654b0c3120be1b78f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 12 Mar 2025 10:15:38 +0000 Subject: [PATCH 20/23] xenctrl: Don't use numa_node in domain_claim_pages calls This binding is only available in Xen 4.21 (unreleased) Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/c_stubs/xenctrlext_stubs.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c b/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c index 2cdcfe37b3d..d7f3fee8f5e 100644 --- a/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c +++ b/ocaml/xenopsd/c_stubs/xenctrlext_stubs.c @@ -678,11 +678,11 @@ CAMLprim value stub_xenctrlext_domain_claim_pages(value xch_val, value domid_val int retval, the_errno; xc_interface* xch = xch_of_val(xch_val); uint32_t domid = Int_val(domid_val); - unsigned int numa_node = Int_val(numa_node_val); + // unsigned int numa_node = Int_val(numa_node_val); unsigned long nr_pages = Long_val(nr_pages_val); caml_release_runtime_system(); - retval = xc_domain_claim_pages(xch, domid, numa_node, nr_pages); + retval = xc_domain_claim_pages(xch, domid, /*numa_node,*/ nr_pages); the_errno = errno; caml_acquire_runtime_system(); From 687ad1dc2cb63a2d6347e4d53e104c4dde7caf60 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 17 Mar 2025 15:34:33 +0000 Subject: [PATCH 21/23] xenopsd: log_reraise doesn't ignore the result Previously unit was returned every single time, but the result of the inner function will need to be used in the near future. Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/xc/domain.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index a9022f26565..348c5de44bc 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -919,7 +919,7 @@ let build_pre ~xc ~xs ~vcpus ~memory ~has_hard_affinity domid = let timer_mode = int_platform_flag "timer_mode" in let log_reraise call_str f = debug "VM = %s; domid = %d; %s" (Uuidx.to_string uuid) domid call_str ; - try ignore (f ()) + try f () with e -> let bt = Printexc.get_backtrace () in debug "Backtrace: %s" bt ; From 6f6b6386beb89787803d3bf15f564f30afa2a80f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 12 Mar 2025 16:06:03 +0000 Subject: [PATCH 22/23] CP-54065, xenopsd: use domain_claim_pages on a single node, if possible Xen currently supports to modes to claim memory for a domain: without any node in particular, or claim memory in a single NUMA node. When planning a domain, return the nodes that will host the domain, and how much memory. In the case where the domain fits in a single NUMA node, claim pages on that node, otherwise fall back to previous behaviour. The memory claims need to happen while the memory measurements hold valid, that is while no VMs are started, otherwise ENOMEM might be returned. Because the current mode is a best-effort, log when the claim does not work. Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/lib/softaffinity.ml | 11 +- ocaml/xenopsd/lib/softaffinity.mli | 6 +- ocaml/xenopsd/lib/topology.ml | 2 +- ocaml/xenopsd/lib/topology.mli | 5 +- ocaml/xenopsd/test/test_topology.ml | 14 +- ocaml/xenopsd/xc/domain.ml | 217 +++++++++++++++----------- ocaml/xenopsd/xc/xenctrlext.mli | 1 + ocaml/xenopsd/xc/xenops_server_xen.ml | 26 +-- 8 files changed, 165 insertions(+), 117 deletions(-) diff --git a/ocaml/xenopsd/lib/softaffinity.ml b/ocaml/xenopsd/lib/softaffinity.ml index 4e38640dcd1..1e7231506da 100644 --- a/ocaml/xenopsd/lib/softaffinity.ml +++ b/ocaml/xenopsd/lib/softaffinity.ml @@ -26,10 +26,9 @@ let plan host nodes ~vm = (Fmt.to_to_string NUMARequest.pp_dump requested) (Fmt.to_to_string NUMAResource.pp_dump allocated) ; let candidate = nodes.(nodeidx) in - ( NUMAResource.union allocated candidate - , node :: picked - , NUMARequest.shrink requested candidate - ) + (* This is where the memory allocated to the node can be calculated *) + let remaining_request = NUMARequest.shrink requested candidate in + (NUMAResource.union allocated candidate, node :: picked, remaining_request) in let plan_valid (avg, nodes) = let allocated, picked, remaining = @@ -72,8 +71,8 @@ let plan host nodes ~vm = | None -> debug "No allocations possible" ; None - | Some allocated -> + | Some (allocated, nodes) -> debug "Allocated resources: %s" (Fmt.to_to_string NUMAResource.pp_dump allocated) ; assert (NUMARequest.fits vm allocated) ; - Some allocated.NUMAResource.affinity + Some (allocated.NUMAResource.affinity, nodes) diff --git a/ocaml/xenopsd/lib/softaffinity.mli b/ocaml/xenopsd/lib/softaffinity.mli index 7bef2079f89..5b1f550af5b 100644 --- a/ocaml/xenopsd/lib/softaffinity.mli +++ b/ocaml/xenopsd/lib/softaffinity.mli @@ -14,7 +14,11 @@ open Topology -val plan : NUMA.t -> NUMAResource.t array -> vm:NUMARequest.t -> CPUSet.t option +val plan : + NUMA.t + -> NUMAResource.t array + -> vm:NUMARequest.t + -> (Topology.CPUSet.t * Topology.NUMA.node list) option (** [plan host nodes ~vm] returns the CPU soft affinity recommended for [vm], Such that the memory latency between the NUMA nodes of the vCPUs is small, and usage of NUMA nodes is balanced. diff --git a/ocaml/xenopsd/lib/topology.ml b/ocaml/xenopsd/lib/topology.ml index f706f542d5e..a2cd401a0cc 100644 --- a/ocaml/xenopsd/lib/topology.ml +++ b/ocaml/xenopsd/lib/topology.ml @@ -298,7 +298,7 @@ module NUMA = struct None else ( List.iter (fun (Node n) -> t.node_usage.(n) <- t.node_usage.(n) + 1) nodes ; - Some result + Some (result, nodes) ) let pp_dump_node = Fmt.(using (fun (Node x) -> x) int) diff --git a/ocaml/xenopsd/lib/topology.mli b/ocaml/xenopsd/lib/topology.mli index 478a7ac2b64..f1bd6f9f569 100644 --- a/ocaml/xenopsd/lib/topology.mli +++ b/ocaml/xenopsd/lib/topology.mli @@ -150,7 +150,10 @@ module NUMA : sig NUMA nodes > 16 it limits the length of the sequence to [n+65520], to avoid exponential blowup. *) - val choose : t -> (node list * NUMAResource.t) Seq.t -> NUMAResource.t option + val choose : + t + -> (node list * NUMAResource.t) Seq.t + -> (NUMAResource.t * node list) option (** [choose t resources] will choose one NUMA node deterministically, trying to keep the overall NUMA node usage balanced *) diff --git a/ocaml/xenopsd/test/test_topology.ml b/ocaml/xenopsd/test/test_topology.ml index e53640f5054..d9945ed8018 100644 --- a/ocaml/xenopsd/test/test_topology.ml +++ b/ocaml/xenopsd/test/test_topology.ml @@ -210,18 +210,20 @@ let test_allocate ?(mem = default_mem) (expected_cores, h) ~vms () = match Softaffinity.plan h nodes ~vm with | None -> Alcotest.fail "No NUMA plan" - | Some plan -> - D.debug "NUMA allocation succeeded for VM %d: %s" i - (Fmt.to_to_string CPUSet.pp_dump plan) ; + | Some (cpu_plan, mem_plan) -> + D.debug + "NUMA allocation succeeded for VM %d: [CPUS: %s]; [nodes: %s]" i + (Fmt.to_to_string CPUSet.pp_dump cpu_plan) + (Fmt.to_to_string Fmt.(Dump.list NUMA.pp_dump_node) mem_plan) ; let usednodes = - plan + cpu_plan |> CPUSet.elements |> List.map (NUMA.node_of_cpu h) |> List.sort_uniq compare |> List.to_seq in let costs_numa_aware = - vm_access_costs h plans (vm_cores, usednodes, plan) + vm_access_costs h plans (vm_cores, usednodes, cpu_plan) in let costs_default = vm_access_costs h plans (vm_cores, NUMA.nodes h, NUMA.all_cpus h) @@ -229,7 +231,7 @@ let test_allocate ?(mem = default_mem) (expected_cores, h) ~vms () = cost_not_worse ~default:costs_default costs_numa_aware ; ( costs_default :: costs_old , costs_numa_aware :: costs_new - , ((vm_cores, List.of_seq usednodes), plan) :: plans + , ((vm_cores, List.of_seq usednodes), cpu_plan) :: plans ) ) ([], [], []) diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index 348c5de44bc..6ea92ad2ae1 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -860,42 +860,62 @@ let numa_init () = let numa_placement domid ~vcpus ~memory = let open Xenctrlext in let open Topology in - let hint = - with_lock numa_mutex (fun () -> - let ( let* ) = Option.bind in - let xcext = get_handle () in - let* host = Lazy.force numa_hierarchy in - let numa_meminfo = (numainfo xcext).memory |> Array.to_list in - let nodes = - ListLabels.map2 - (NUMA.nodes host |> List.of_seq) - numa_meminfo - ~f:(fun node m -> NUMA.resource host node ~memory:m.memfree) - in - let vm = NUMARequest.make ~memory ~vcpus in - let nodea = - match !numa_resources with - | None -> - Array.of_list nodes - | Some a -> - Array.map2 NUMAResource.min_memory (Array.of_list nodes) a - in - numa_resources := Some nodea ; - Softaffinity.plan ~vm host nodea - ) - in - let xcext = get_handle () in - ( match hint with - | None -> - D.debug "NUMA-aware placement failed for domid %d" domid - | Some soft_affinity -> - let cpua = CPUSet.to_mask soft_affinity in - for i = 0 to vcpus - 1 do - Xenctrlext.vcpu_setaffinity_soft xcext domid i cpua - done - ) ; - let nr_pages = Int64.div memory 4096L |> Int64.to_int in - Xenctrlext.domain_claim_pages xcext domid nr_pages + with_lock numa_mutex (fun () -> + let ( let* ) = Option.bind in + let xcext = get_handle () in + let* host = Lazy.force numa_hierarchy in + let numa_meminfo = (numainfo xcext).memory |> Array.to_list in + let nodes = + ListLabels.map2 + (NUMA.nodes host |> List.of_seq) + numa_meminfo + ~f:(fun node m -> NUMA.resource host node ~memory:m.memfree) + in + let vm = NUMARequest.make ~memory ~vcpus in + let nodea = + match !numa_resources with + | None -> + Array.of_list nodes + | Some a -> + Array.map2 NUMAResource.min_memory (Array.of_list nodes) a + in + numa_resources := Some nodea ; + let memory_plan = + match Softaffinity.plan ~vm host nodea with + | None -> + D.debug "NUMA-aware placement failed for domid %d" domid ; + [] + | Some (cpu_affinity, mem_plan) -> + let cpus = CPUSet.to_mask cpu_affinity in + for i = 0 to vcpus - 1 do + Xenctrlext.vcpu_setaffinity_soft xcext domid i cpus + done ; + mem_plan + in + (* Xen only allows a single node when using memory claims, or none at all. *) + let* numa_node, node = + match memory_plan with + | [Node node] -> + Some (Xenctrlext.NumaNode.from node, node) + | [] | _ :: _ :: _ -> + D.debug + "%s: domain %d can't fit a single NUMA node, falling back to \ + default behaviour" + __FUNCTION__ domid ; + None + in + let nr_pages = Int64.div memory 4096L |> Int64.to_int in + try + Xenctrlext.domain_claim_pages xcext domid ~numa_node nr_pages ; + Some (node, memory) + with Xenctrlext.Unix_error (errno, _) -> + D.info + "%s: unable to claim enough memory, domain %d won't be hosted in a \ + single NUMA node. (error %s)" + __FUNCTION__ domid + Unix.(error_message errno) ; + None + ) let build_pre ~xc ~xs ~vcpus ~memory ~has_hard_affinity domid = let open Memory in @@ -949,42 +969,54 @@ let build_pre ~xc ~xs ~vcpus ~memory ~has_hard_affinity domid = log_reraise (Printf.sprintf "shadow_allocation_set %d MiB" shadow_mib) (fun () -> Xenctrl.shadow_allocation_set xc domid shadow_mib ) ; - let () = + let node_placement = match !Xenops_server.numa_placement with | Any -> - () + None | Best_effort -> log_reraise (Printf.sprintf "NUMA placement") (fun () -> - if has_hard_affinity then - D.debug "VM has hard affinity set, skipping NUMA optimization" - else + if has_hard_affinity then ( + D.debug "VM has hard affinity set, skipping NUMA optimization" ; + None + ) else numa_placement domid ~vcpus ~memory:(Int64.mul memory.xen_max_mib 1048576L) + |> Option.map fst ) in - create_channels ~xc uuid domid + let store_chan, console_chan = create_channels ~xc uuid domid in + (store_chan, console_chan, node_placement) + +let args_numa_placements numa_placement = + Option.fold ~none:[] + ~some:(fun node -> ["-mem_pnode"; Printf.sprintf "%d" node]) + numa_placement let xenguest_args_base ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory = + ~console_domid ~memory ~numa_placement = [ - "-domid" - ; string_of_int domid - ; "-store_port" - ; string_of_int store_port - ; "-store_domid" - ; string_of_int store_domid - ; "-console_port" - ; string_of_int console_port - ; "-console_domid" - ; string_of_int console_domid - ; "-mem_max_mib" - ; Int64.to_string memory.Memory.build_max_mib - ; "-mem_start_mib" - ; Int64.to_string memory.Memory.build_start_mib + [ + "-domid" + ; string_of_int domid + ; "-store_port" + ; string_of_int store_port + ; "-store_domid" + ; string_of_int store_domid + ; "-console_port" + ; string_of_int console_port + ; "-console_domid" + ; string_of_int console_domid + ; "-mem_max_mib" + ; Int64.to_string memory.Memory.build_max_mib + ; "-mem_start_mib" + ; Int64.to_string memory.Memory.build_start_mib + ] + ; args_numa_placements numa_placement ] + |> List.concat let xenguest_args_hvm ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory ~kernel ~vgpus = + ~console_domid ~memory ~kernel ~vgpus ~numa_placement = ["-mode"; "hvm_build"; "-image"; kernel] @ (vgpus |> function | Xenops_interface.Vgpu.{implementation= Nvidia _; _} :: _ -> @@ -993,10 +1025,10 @@ let xenguest_args_hvm ~domid ~store_port ~store_domid ~console_port [] ) @ xenguest_args_base ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory + ~console_domid ~memory ~numa_placement let xenguest_args_pv ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory ~kernel ~cmdline ~ramdisk = + ~console_domid ~memory ~kernel ~cmdline ~ramdisk ~numa_placement = [ "-mode" ; "linux_build" @@ -1012,10 +1044,10 @@ let xenguest_args_pv ~domid ~store_port ~store_domid ~console_port ; "0" ] @ xenguest_args_base ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory + ~console_domid ~memory ~numa_placement let xenguest_args_pvh ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory ~kernel ~cmdline ~modules = + ~console_domid ~memory ~kernel ~cmdline ~modules ~numa_placement = let module_args = List.concat_map (fun (m, c) -> @@ -1037,7 +1069,7 @@ let xenguest_args_pvh ~domid ~store_port ~store_domid ~console_port ] @ module_args @ xenguest_args_base ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory + ~console_domid ~memory ~numa_placement let xenguest task xenguest_path domid uuid args = let line = @@ -1134,13 +1166,13 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid shadow_multiplier in maybe_ca_140252_workaround ~xc ~vcpus domid ; - let store_port, console_port = + let store_port, console_port, numa_placement = build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity domid in let store_mfn, console_mfn = let args = xenguest_args_hvm ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory ~kernel ~vgpus + ~console_domid ~memory ~kernel ~vgpus ~numa_placement @ force_arg @ extras in @@ -1162,14 +1194,14 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid shadow_multiplier in Option.iter assert_file_is_readable pvinfo.ramdisk ; - let store_port, console_port = + let store_port, console_port, numa_placement = build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity domid in let store_mfn, console_mfn = let args = xenguest_args_pv ~domid ~store_port ~store_domid ~console_port ~console_domid ~memory ~kernel ~cmdline:pvinfo.cmdline - ~ramdisk:pvinfo.ramdisk + ~ramdisk:pvinfo.ramdisk ~numa_placement @ force_arg @ extras in @@ -1185,13 +1217,13 @@ let build (task : Xenops_task.task_handle) ~xc ~xs ~store_domid ~console_domid shadow_multiplier in maybe_ca_140252_workaround ~xc ~vcpus domid ; - let store_port, console_port = + let store_port, console_port, numa_placement = build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity domid in let store_mfn, console_mfn = let args = xenguest_args_pvh ~domid ~store_port ~store_domid ~console_port - ~console_domid ~memory ~kernel ~cmdline ~modules + ~console_domid ~memory ~kernel ~cmdline ~modules ~numa_placement @ force_arg @ extras in @@ -1221,8 +1253,8 @@ let dm_flags = [] let with_emu_manager_restore (task : Xenops_task.task_handle) ~domain_type - ~(dm : Device.Profile.t) ~store_port ~console_port ~extras manager_path - domid _uuid main_fd vgpu_fd f = + ~(dm : Device.Profile.t) ~store_port ~console_port ~extras ~numa_placements + manager_path domid _uuid main_fd vgpu_fd f = let mode = match domain_type with `hvm | `pvh -> "hvm_restore" | `pv -> "restore" in @@ -1240,20 +1272,24 @@ let with_emu_manager_restore (task : Xenops_task.task_handle) ~domain_type let fds = [(fd_uuid, main_fd)] @ vgpu_args in let args = [ - "-mode" - ; mode - ; "-domid" - ; string_of_int domid - ; "-fd" - ; fd_uuid - ; "-store_port" - ; string_of_int store_port - ; "-console_port" - ; string_of_int console_port + [ + "-mode" + ; mode + ; "-domid" + ; string_of_int domid + ; "-fd" + ; fd_uuid + ; "-store_port" + ; string_of_int store_port + ; "-console_port" + ; string_of_int console_port + ] + ; args_numa_placements numa_placements + ; dm_flags dm + ; extras + ; vgpu_cmdline ] - @ dm_flags dm - @ extras - @ vgpu_cmdline + |> List.concat in Emu_manager.with_connection task manager_path args fds f @@ -1307,7 +1343,7 @@ let consume_qemu_record fd limit domid uuid = let restore_common (task : Xenops_task.task_handle) ~xc ~xs ~(dm : Device.Profile.t) ~domain_type ~store_port ~store_domid:_ ~console_port ~console_domid:_ ~no_incr_generationid:_ ~vcpus:_ ~extras - ~vtpm manager_path domid main_fd vgpu_fd = + ~vtpm ~numa_placements manager_path domid main_fd vgpu_fd = let module DD = Debug.Make (struct let name = "mig64" end) in let open DD in let uuid = get_uuid ~xc domid in @@ -1320,8 +1356,8 @@ let restore_common (task : Xenops_task.task_handle) ~xc ~xs match with_conversion_script task "Emu_manager" hvm main_fd (fun pipe_r -> with_emu_manager_restore task ~domain_type ~dm ~store_port - ~console_port ~extras manager_path domid uuid pipe_r vgpu_fd - (fun cnx -> restore_libxc_record cnx domid uuid + ~console_port ~extras ~numa_placements manager_path domid uuid + pipe_r vgpu_fd (fun cnx -> restore_libxc_record cnx domid uuid ) ) with @@ -1360,7 +1396,8 @@ let restore_common (task : Xenops_task.task_handle) ~xc ~xs [main_fd] in with_emu_manager_restore task ~domain_type ~dm ~store_port ~console_port - ~extras manager_path domid uuid main_fd vgpu_fd (fun cnx -> + ~extras ~numa_placements manager_path domid uuid main_fd vgpu_fd + (fun cnx -> (* Maintain a list of results returned by emu-manager that are expected by the reader threads. Contains the emu for which a result is wanted plus an event channel for waking up the reader once the @@ -1614,14 +1651,14 @@ let restore (task : Xenops_task.task_handle) ~xc ~xs ~dm ~store_domid maybe_ca_140252_workaround ~xc ~vcpus domid ; (memory, vm_stuff, `pvh) in - let store_port, console_port = + let store_port, console_port, numa_placements = build_pre ~xc ~xs ~memory ~vcpus ~has_hard_affinity:info.has_hard_affinity domid in let store_mfn, console_mfn = restore_common task ~xc ~xs ~dm ~domain_type ~store_port ~store_domid ~console_port ~console_domid ~no_incr_generationid ~vcpus ~extras ~vtpm - manager_path domid fd vgpu_fd + ~numa_placements manager_path domid fd vgpu_fd in let local_stuff = console_keys console_port console_mfn in (* And finish domain's building *) diff --git a/ocaml/xenopsd/xc/xenctrlext.mli b/ocaml/xenopsd/xc/xenctrlext.mli index 39c6eeff514..559842fac75 100644 --- a/ocaml/xenopsd/xc/xenctrlext.mli +++ b/ocaml/xenopsd/xc/xenctrlext.mli @@ -100,3 +100,4 @@ module NumaNode : sig end val domain_claim_pages : handle -> domid -> ?numa_node:NumaNode.t -> int -> unit +(** Raises {Unix_error} if there's not enough memory to claim in the system *) diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index 6c6dd067ef7..3527cbeb63a 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -51,6 +51,8 @@ let _xenguest = "xenguest" let _emu_manager = "emu-manager" +let ( // ) = Filename.concat + let run cmd args = debug "%s %s" cmd (String.concat " " args) ; fst (Forkhelpers.execute_command_get_output cmd args) @@ -58,20 +60,20 @@ let run cmd args = let choose_alternative kind default platformdata = debug "looking for %s in [ %s ]" kind (String.concat "; " (List.map (fun (k, v) -> k ^ " : " ^ v) platformdata)) ; - if List.mem_assoc kind platformdata then - let x = List.assoc kind platformdata in - let dir = Filename.concat !Xc_resources.alternatives kind in - let available = try Array.to_list (Sys.readdir dir) with _ -> [] in + let path_available x = + let dir = !Xc_resources.alternatives // kind in + let available = try Sys.readdir dir with _ -> [||] in (* If x has been put in the directory (by root) then it's safe to use *) - if List.mem x available then - Filename.concat dir x + if Array.mem x available then + Some (dir // x) else ( error "Invalid platform:%s=%s (check execute permissions of %s)" kind x - (Filename.concat dir x) ; - default + (dir // x) ; + None ) - else - default + in + Option.bind (List.assoc_opt kind platformdata) path_available + |> Option.value ~default (* We allow qemu-dm to be overriden via a platform flag *) let choose_qemu_dm x = @@ -2664,8 +2666,8 @@ module VM = struct in let manager_path = choose_emu_manager vm.Vm.platformdata in Domain.restore task ~xc ~xs ~dm:(dm_of ~vm) ~store_domid - ~console_domid ~no_incr_generationid (* XXX progress_callback *) - ~timeoffset ~extras build_info ~manager_path ~vtpm domid fd vgpu_fd + ~console_domid ~no_incr_generationid ~timeoffset ~extras build_info + ~manager_path ~vtpm domid fd vgpu_fd with e -> error "VM %s: restore failed: %s" vm.Vm.id (Printexc.to_string e) ; (* As of xen-unstable.hg 779c0ef9682 libxenguest will destroy From 9e6fb15bb069404a64836dc7c6603d41226cc6bb Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 26 Mar 2025 16:35:29 +0000 Subject: [PATCH 23/23] xenopsd/xc: Do not try to allocate pages to a particular NUMA node Neither xenguest nor emu-manager support passing the parameter just yet, so avoid passing the numa node to create the parameter. On top of that claiming memory conflicts with DMC, so it's better to keep previous behaviour of not claiming any pages before allocating. Signed-off-by: Pau Ruiz Safont --- ocaml/xenopsd/xc/domain.ml | 29 +++++------------------------ 1 file changed, 5 insertions(+), 24 deletions(-) diff --git a/ocaml/xenopsd/xc/domain.ml b/ocaml/xenopsd/xc/domain.ml index 6ea92ad2ae1..19f28e41985 100644 --- a/ocaml/xenopsd/xc/domain.ml +++ b/ocaml/xenopsd/xc/domain.ml @@ -880,7 +880,7 @@ let numa_placement domid ~vcpus ~memory = Array.map2 NUMAResource.min_memory (Array.of_list nodes) a in numa_resources := Some nodea ; - let memory_plan = + let _ = match Softaffinity.plan ~vm host nodea with | None -> D.debug "NUMA-aware placement failed for domid %d" domid ; @@ -892,29 +892,10 @@ let numa_placement domid ~vcpus ~memory = done ; mem_plan in - (* Xen only allows a single node when using memory claims, or none at all. *) - let* numa_node, node = - match memory_plan with - | [Node node] -> - Some (Xenctrlext.NumaNode.from node, node) - | [] | _ :: _ :: _ -> - D.debug - "%s: domain %d can't fit a single NUMA node, falling back to \ - default behaviour" - __FUNCTION__ domid ; - None - in - let nr_pages = Int64.div memory 4096L |> Int64.to_int in - try - Xenctrlext.domain_claim_pages xcext domid ~numa_node nr_pages ; - Some (node, memory) - with Xenctrlext.Unix_error (errno, _) -> - D.info - "%s: unable to claim enough memory, domain %d won't be hosted in a \ - single NUMA node. (error %s)" - __FUNCTION__ domid - Unix.(error_message errno) ; - None + (* Neither xenguest nor emu-manager allow allocating pages to a single + NUMA node, don't return any NUMA in any case. Claiming the memory + would be done here, but it conflicts with DMC. *) + None ) let build_pre ~xc ~xs ~vcpus ~memory ~has_hard_affinity domid =