From f352a5629651bf427d8883952d62faf377f04d4b Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 11:11:08 +0000 Subject: [PATCH 1/7] 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 2/7] 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 3/7] 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 4a1b6570f566b8b2a49ccf99ee554ac7083145eb Mon Sep 17 00:00:00 2001 From: Vincent Liu Date: Thu, 20 Mar 2025 14:43:57 +0000 Subject: [PATCH 4/7] 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 5/7] 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 6/7] 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 7/7] 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