From d217b3c54e8ef8df1ad1ea65a7e5c764617f14b1 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 28 Nov 2022 16:03:45 +0000 Subject: [PATCH 01/11] Remove unused Storage_access.is_attached Signed-off-by: Rob Hoes --- ocaml/xapi/storage_access.ml | 18 ------------------ ocaml/xapi/storage_access.mli | 4 ---- 2 files changed, 22 deletions(-) diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 51f8e05ba81..9dbcd58b4cf 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -1699,24 +1699,6 @@ let of_vbd ~__context ~vbd ~domid = , Storage_interface.Vdi.of_string location ) -(** [is_attached __context vbd] returns true if the [vbd] has an attached - or activated datapath. *) -let is_attached ~__context ~vbd ~domid = - transform_storage_exn (fun () -> - let rpc, dbg, _dp, sr, vdi = of_vbd ~__context ~vbd ~domid in - let open Vdi_automaton in - let module C = Storage_interface.StorageAPI (Idl.Exn.GenClient (struct - let rpc = rpc - end)) in - try - let x = C.DP.stat_vdi dbg sr vdi () in - x.superstate <> Detached - with e -> - error "Unable to query state of VDI: %s, %s" (s_of_vdi vdi) - (Printexc.to_string e) ; - false - ) - (** [on_vdi __context vbd domid f] calls [f rpc dp sr vdi] which is useful for executing Storage_interface.Client.VDI functions *) let on_vdi ~__context ~vbd ~domid f = diff --git a/ocaml/xapi/storage_access.mli b/ocaml/xapi/storage_access.mli index 7de7633a686..deab895768a 100644 --- a/ocaml/xapi/storage_access.mli +++ b/ocaml/xapi/storage_access.mli @@ -99,10 +99,6 @@ val deactivate_and_detach : (** [deactivate_and_detach __context vbd domid] idempotent function which ensures that any attached or activated VDI gets properly deactivated and detached. *) -val is_attached : __context:Context.t -> vbd:API.ref_VBD -> domid:int -> bool -(** [is_attached __context vbd] returns true if the [vbd] has an attached - or activated datapath. *) - val on_vdi : __context:Context.t -> vbd:API.ref_VBD From 0dccdbbb97f3e58c4c63d49cd33177d2e1ee65ad Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 25 Nov 2022 15:36:27 +0000 Subject: [PATCH 02/11] Push Storage_impl down to only wrap SMAPIv1 calls This affects the entry point for SMAPIv2 calls in xapi, the server module of which is currently defined in storage_mux.ml as module Server = Storage_interface.Server (Storage_impl.Wrapper (Mux)) () The Mux module does nothing other than forwarding the SMAPIv2 calls to either a SMAPIv1 or a SMAPIv3 backend, depending on the SR type. The wrapper in storage_impl.ml contains logic (including a state machine and locking), which is mostly specific to SMAPIv1 backends. The current SMAPIv3 backends also still rely on some of this, but the next generation of SMAPIv3 will instead be incompatible with it. This commit is the first step towards pushing the wrapper down to only cover SMAPIv1 backends, the server module for which is defined in the function `start_smapiv1_servers` in storage_access.ml. The file storage_impl.ml is renamed to storage_smapiv1_wrapper.ml to reflect this change. The Mux module now becomes the SMAPIv2 entry point. There is a module called `Local_domain_socket` in storage_impl.ml, which is unrelated to the wrapper. This is moved to storage_mux.ml. There are a few things in the wrapper that are still needed for SMAPIv3, even in the next generation. The following commits bring these back, either in the Mux, or in the SMAPIv3 module (part of xapi-storage-script). Signed-off-by: Rob Hoes --- ocaml/tests/dune | 6 ++--- ocaml/tests/test_storage_quicktest.ml | 2 +- ...mpl.ml => test_storage_smapiv1_wrapper.ml} | 2 +- ocaml/xapi/storage_access.ml | 7 ++++-- ocaml/xapi/storage_mux.ml | 17 ++++++++++++- ...age_impl.ml => storage_smapiv1_wrapper.ml} | 24 ++++--------------- ocaml/xapi/xapi.ml | 5 +++- ocaml/xapi/xapi_services.ml | 2 +- 8 files changed, 36 insertions(+), 29 deletions(-) rename ocaml/tests/{test_storage_impl.ml => test_storage_smapiv1_wrapper.ml} (99%) rename ocaml/xapi/{storage_impl.ml => storage_smapiv1_wrapper.ml} (98%) diff --git a/ocaml/tests/dune b/ocaml/tests/dune index ef06d7d0d9a..a75a74a986b 100644 --- a/ocaml/tests/dune +++ b/ocaml/tests/dune @@ -5,7 +5,7 @@ (:standard \ test_daemon_manager test_vdi_cbt test_event test_clustering test_cluster_host test_cluster test_pusb test_network_sriov test_vm_placement test_vm_helpers test_repository test_repository_helpers - test_livepatch test_rpm test_updateinfo test_storage_impl test_storage_quicktest)) + test_livepatch test_rpm test_updateinfo test_storage_smapiv1_wrapper test_storage_quicktest)) (libraries alcotest angstrom @@ -91,9 +91,9 @@ (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) ) (test -(name test_storage_impl) +(name test_storage_smapiv1_wrapper) (package xapi) -(modules test_storage_impl) +(modules test_storage_smapiv1_wrapper) (libraries alcotest xapi_internal fmt)) (test diff --git a/ocaml/tests/test_storage_quicktest.ml b/ocaml/tests/test_storage_quicktest.ml index d980324d8ed..c2d60a561a0 100644 --- a/ocaml/tests/test_storage_quicktest.ml +++ b/ocaml/tests/test_storage_quicktest.ml @@ -13,7 +13,7 @@ *) module Cb = Crowbar -open Storage_impl +open Storage_smapiv1_wrapper let dpvs_cb_t = let one_dpvs = diff --git a/ocaml/tests/test_storage_impl.ml b/ocaml/tests/test_storage_smapiv1_wrapper.ml similarity index 99% rename from ocaml/tests/test_storage_impl.ml rename to ocaml/tests/test_storage_smapiv1_wrapper.ml index 15d3f204868..293ab3203f6 100644 --- a/ocaml/tests/test_storage_impl.ml +++ b/ocaml/tests/test_storage_smapiv1_wrapper.ml @@ -12,7 +12,7 @@ * GNU Lesser General Public License for more details. *) -open Storage_impl +open Storage_smapiv1_wrapper open Vdi let state_pp fmt state = diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 9dbcd58b4cf..8d21c7c698b 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -594,7 +594,8 @@ module SMAPIv1 = struct let attach _ = failwith - "We'll never get here: attach is implemented in Storage_impl.Wrapper" + "We'll never get here: attach is implemented in \ + Storage_smapiv1_wrapper.Wrapper" let activate _context ~dbg ~dp ~sr ~vdi = try @@ -1203,7 +1204,9 @@ let start_smapiv1_servers () = (fun ty -> let path = !Storage_interface.default_path ^ ".d/" ^ ty in let queue_name = !Storage_interface.queue_name ^ "." ^ ty in - let module S = Storage_interface.Server (SMAPIv1) () in + let module S = + Storage_interface.Server (Storage_smapiv1_wrapper.Wrapper (SMAPIv1)) () + in let s = Xcp_service.make ~path ~queue_name ~rpc_fn:S.process () in let (_ : Thread.t) = Thread.create (fun () -> Xcp_service.serve_forever s) () diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 06a525cfed6..58669f83894 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -503,4 +503,19 @@ module Mux = struct end end -module Server = Storage_interface.Server (Storage_impl.Wrapper (Mux)) () +module Server = Storage_interface.Server (Mux) () + +module Local_domain_socket = struct + let path = Filename.concat "/var/lib/xcp" "storage" + + (* receives external requests on Constants.sm_uri *) + let xmlrpc_handler process req bio _ = + let body = Http_svr.read_body req bio in + let s = Buf_io.fd_of bio in + let rpc = Xmlrpc.call_of_string body in + (* Printf.fprintf stderr "Request: %s %s\n%!" rpc.Rpc.name (Rpc.to_string (List.hd rpc.Rpc.params)); *) + let result = process rpc in + (* Printf.fprintf stderr "Response: %s\n%!" (Rpc.to_string result.Rpc.contents); *) + let str = Xmlrpc.string_of_response result in + Http_svr.response_str req s str +end diff --git a/ocaml/xapi/storage_impl.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml similarity index 98% rename from ocaml/xapi/storage_impl.ml rename to ocaml/xapi/storage_smapiv1_wrapper.ml index 0a3a405fa9b..29063bc9ea4 100644 --- a/ocaml/xapi/storage_impl.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -1,5 +1,5 @@ (* - * Copyright (C) 2011 Citrix Systems Inc. + * Copyright (C) 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 @@ -436,14 +436,15 @@ functor (Internal_error "Storage_access.No_VDI") as e when op = Vdi_automaton.Deactivate || op = Vdi_automaton.Detach -> error - "Storage_impl: caught exception %s while doing %s . Continuing \ - as if succesful, being optimistic" + "Storage_smapiv1_wrapper: caught exception %s while doing %s . \ + Continuing as if succesful, being optimistic" (Printexc.to_string e) (Vdi_automaton.string_of_op op) ; vdi_t | e -> error - "Storage_impl: dp:%s sr:%s vdi:%s op:%s error:%s backtrace:%s" + "Storage_smapiv1_wrapper: dp:%s sr:%s vdi:%s op:%s error:%s \ + backtrace:%s" dp (s_of_sr sr) (s_of_vdi vdi) (Vdi_automaton.string_of_op op) (Printexc.to_string e) @@ -1320,18 +1321,3 @@ let initialise () = ) else info "No storage state is persisted in %s; creating blank database" !host_state_path - -module Local_domain_socket = struct - let path = Filename.concat "/var/lib/xcp" "storage" - - (* receives external requests on Constants.sm_uri *) - let xmlrpc_handler process req bio _ = - let body = Http_svr.read_body req bio in - let s = Buf_io.fd_of bio in - let rpc = Xmlrpc.call_of_string body in - (* Printf.fprintf stderr "Request: %s %s\n%!" rpc.Rpc.name (Rpc.to_string (List.hd rpc.Rpc.params)); *) - let result = process rpc in - (* Printf.fprintf stderr "Response: %s\n%!" (Rpc.to_string result.Rpc.contents); *) - let str = Xmlrpc.string_of_response result in - Http_svr.response_str req s str -end diff --git a/ocaml/xapi/xapi.ml b/ocaml/xapi/xapi.ml index 6ccdff4ddb4..e039c80992e 100644 --- a/ocaml/xapi/xapi.ml +++ b/ocaml/xapi/xapi.ml @@ -1030,11 +1030,14 @@ let server_init () = ; ("Initialise TLS verification", [], init_tls_verification) ; ("Running startup check", [], startup_check) ; ("Registering SMAPIv1 plugins", [Startup.OnlyMaster], Sm.register) + ; ( "Initialising SMAPIv1 state" + , [] + , Storage_smapiv1_wrapper.initialise + ) ; ( "Starting SMAPIv1 proxies" , [Startup.OnlyMaster] , Storage_access.start_smapiv1_servers ) - ; ("Initialising SM state", [], Storage_impl.initialise) ; ("Starting SM service", [], Storage_access.start) ; ("Starting SM xapi event service", [], Storage_access.events_from_sm) ; ("Killing stray sparse_dd processes", [], Sparse_dd_wrapper.killall) diff --git a/ocaml/xapi/xapi_services.ml b/ocaml/xapi/xapi_services.ml index 955f65f42a0..2841a020615 100644 --- a/ocaml/xapi/xapi_services.ml +++ b/ocaml/xapi/xapi_services.ml @@ -177,7 +177,7 @@ let post_handler (req : Http.Request.t) s _ = | "" :: services :: "plugin" :: name :: _ when services = _services -> http_proxy_to_plugin req s name | [""; services; "SM"] when services = _services -> - Storage_impl.Local_domain_socket.xmlrpc_handler + Storage_mux.Local_domain_socket.xmlrpc_handler Storage_mux.Server.process req (Buf_io.of_fd s) () | _ -> Http_svr.headers s (Http.http_404_missing ~version:"1.0" ()) ; From aeed086508473718a3c12d660f4f5d2943447f4b Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 9 Jan 2023 15:41:30 +0000 Subject: [PATCH 03/11] Add module DP_info to storage mux This module maintains state for storage datapaths, in particular the SR, VDI and VM their relate to, as was previously done in the wrapper in storage_impl.ml, but in a much simplified way. This state is needed to implement the functions in the DP module of SMAPIv2. The state is persisted in a new file in /var/run/nonpersistent/xapi. This is mainly to allow DP.destroy to be implemented. Signed-off-by: Rob Hoes --- ocaml/xapi/storage_mux.ml | 45 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 58669f83894..79c005b202f 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -12,6 +12,8 @@ * GNU Lesser General Public License for more details. *) +module Unixext = Xapi_stdext_unix.Unixext + module D = Debug.Make (struct let name = "mux" end) open D @@ -151,6 +153,49 @@ module Mux = struct ) end + module DP_info = struct + type t = {sr: Sr.t; vdi: Vdi.t; vm: Vm.t} [@@deriving rpcty] + + let storage_dp_path = "/var/run/nonpersistent/xapi/storage-dps" + + let m = Mutex.create () + + let filename_of dp = Xapi_stdext_std.Xstringext.String.replace "/" "-" dp + + let write dp info = + let filename = filename_of dp in + let data = Rpcmarshal.marshal t.Rpc.Types.ty info |> Jsonrpc.to_string in + with_lock m (fun () -> + Unixext.mkdir_rec storage_dp_path 0o600 ; + Unixext.write_string_to_file + (Filename.concat storage_dp_path filename) + data + ) + + let read dp : t option = + try + with_lock m (fun () -> + let x = + let path = Filename.concat storage_dp_path (filename_of dp) in + path |> Unixext.string_of_file |> Jsonrpc.of_string + in + match Rpcmarshal.unmarshal t.Rpc.Types.ty x with + | Ok x -> + Some x + | Error (`Msg m) -> + failwith (Printf.sprintf "Failed to unmarshal: %s" m) + ) + with _ -> None + + let delete dp = + try + with_lock m (fun () -> + let path = Filename.concat storage_dp_path (filename_of dp) in + Unix.unlink path + ) + with _ -> () + end + module DP = struct (* We'll never get here, because DP is implemented in Storage_impl.Wrapper(Impl), and it never calls Impl.DP *) From 05759159ba5e438dca9f6ee8a40ce0bc9d3c1fbe Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Mon, 9 Jan 2023 15:41:49 +0000 Subject: [PATCH 04/11] Implement DP.destroy, VDI.attach and SR.reset in mux A datapath is added to DP_info when the VDI is attached, and removed when the VDI is detached or the datapath destroyed. VDI.attach and attach2 are implemented in terms of attach3, as was done in the old wrapper. SR.reset just forwards to the backend. Also some debug messages are copied from the wrapper, to improve traceability. Signed-off-by: Rob Hoes --- ocaml/xapi/storage_mux.ml | 87 +++++++++++++++++++++++++++++++++++---- 1 file changed, 78 insertions(+), 9 deletions(-) diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 79c005b202f..9744cde4421 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -28,6 +28,8 @@ 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 @@ -197,9 +199,21 @@ module Mux = struct end module DP = struct - (* We'll never get here, because DP is implemented in - Storage_impl.Wrapper(Impl), and it never calls Impl.DP *) include Storage_skeleton.DP + + let create _context ~dbg:_ ~id = id + + let destroy _context ~dbg ~dp ~allow_leak = + info "DP.destroy dbg:%s dp:%s allow_leak:%b" dbg dp allow_leak ; + let sr : Sr.t = + let open DP_info in + match read dp with Some x -> x.sr | None -> failwith "DP not found" + in + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + C.DP.destroy dbg dp allow_leak ; + DP_info.delete dp end module SR = struct @@ -268,7 +282,12 @@ module Mux = struct ) ) - let reset () ~dbg:_ ~sr:_ = assert false + let reset () ~dbg ~sr = + info "SR.reset dbg:%s sr:%s" dbg (s_of_sr sr) ; + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + C.SR.reset dbg sr let update_snapshot_info_src () = Storage_migrate.update_snapshot_info_src @@ -357,30 +376,79 @@ module Mux = struct end)) in C.VDI.epoch_begin dbg sr vdi vm persistent - (* We need to include this to satisfy the SMAPIv2 signature *) - let attach () ~dbg:_ ~dp:_ ~sr:_ ~vdi:_ ~read_write:_ = - failwith - "We'll never get here: attach is implemented in Storage_impl.Wrapper" + let attach () ~dbg ~dp ~sr ~vdi ~read_write = + let module C = StorageAPI (Idl.Exn.GenClient (struct + let rpc = of_sr sr + end)) in + let vm = Vm.of_string "0" in + DP_info.write dp DP_info.{sr; vdi; vm} ; + let backend = C.VDI.attach3 dbg dp sr vdi vm read_write in + (* VDI.attach2 should be used instead, VDI.attach is only kept for + backwards-compatibility, because older xapis call Remote.VDI.attach during SXM. + However, they ignore the return value, so in practice it does not matter what + we return from here. *) + let xendisks, blockdevs, files, _nbds = + Storage_interface.implementations_of_backend backend + in + let response params = + (* We've thrown o_direct info away from the SMAPIv1 info during the conversion to SMAPIv3 attach info *) + (* The removal of these fields does not break read caching info propagation for SMAPIv1 + * (REQ-49), because we put this information into the VDI's sm_config elsewhere, + * and XenCenter looks at the relevant sm_config keys. *) + {params; xenstore_data= []; o_direct= true; o_direct_reason= ""} + in + (* If Nbd is returned, then XenDisk must also be returned from attach2 *) + match (xendisks, files, blockdevs) with + | xendisk :: _, _, _ -> + response xendisk.Storage_interface.params + | _, file :: _, _ -> + response file.Storage_interface.path + | _, _, blockdev :: _ -> + response blockdev.Storage_interface.path + | [], [], [] -> + raise + (Storage_interface.Storage_error + (Backend_error + ( Api_errors.internal_error + , [ + "No File, BlockDev, or XenDisk implementation in \ + Datapath.attach response: " + ^ (Storage_interface.(rpc_of backend) backend + |> Jsonrpc.to_string + ) + ] + ) + ) + ) let attach2 () ~dbg ~dp ~sr ~vdi ~read_write = let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.attach2 dbg dp sr vdi read_write + let vm = Vm.of_string "0" in + DP_info.write dp DP_info.{sr; vdi; vm} ; + C.VDI.attach3 dbg dp sr vdi vm read_write let attach3 () ~dbg ~dp ~sr ~vdi ~vm ~read_write = + info "VDI.attach3 dbg:%s dp:%s sr:%s vdi:%s vm:%s read_write:%b" dbg dp + (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) read_write ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in + DP_info.write dp DP_info.{sr; vdi; vm} ; C.VDI.attach3 dbg dp sr vdi vm read_write let activate () ~dbg ~dp ~sr ~vdi = + info "VDI.activate dbg:%s dp:%s sr:%s vdi:%s " dbg dp (s_of_sr sr) + (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.activate dbg dp sr vdi let activate3 () ~dbg ~dp ~sr ~vdi ~vm = + info "VDI.activate3 dbg:%s dp:%s sr:%s vdi:%s vm:%s" dbg dp (s_of_sr sr) + (s_of_vdi vdi) (s_of_vm vm) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in @@ -396,7 +464,8 @@ module Mux = struct let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.VDI.detach dbg dp sr vdi vm + C.VDI.detach dbg dp sr vdi vm ; + DP_info.delete dp let epoch_end () ~dbg ~sr ~vdi ~vm = let module C = StorageAPI (Idl.Exn.GenClient (struct From 2faa765a74ae2f71580f387e134111b0dc5b37f5 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 10 Jan 2023 15:04:45 +0000 Subject: [PATCH 05/11] More logging in mux Add some more debug messages are copied from the wrapper, to improve traceability. Signed-off-by: Rob Hoes --- ocaml/xapi/storage_mux.ml | 118 +++++++++++++++++++++++++++++++++++++- 1 file changed, 117 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 9744cde4421..440124862aa 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -219,56 +219,93 @@ module Mux = struct module SR = struct include Storage_skeleton.SR + let device_config_str device_config = + let censor_key = ["password"] in + String.concat "; " + (List.map + (fun (k, v) -> + let v' = + if + List.exists + (fun censored -> Astring.String.is_infix ~affix:censored k) + censor_key + then + "(omitted)" + else + v + in + k ^ ":" ^ v' + ) + device_config + ) + let create () ~dbg ~sr ~name_label ~name_description ~device_config ~physical_size = + info + "SR.create dbg:%s sr:%s name_label:%s name_description:%s \ + device_config:[%s] physical_size:%Ld" + dbg (s_of_sr sr) name_label name_description + (device_config_str device_config) + physical_size ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.create dbg sr name_label name_description device_config physical_size let attach () ~dbg ~sr ~device_config = + info "SR.attach dbg:%s sr:%s device_config:[%s]" dbg (s_of_sr sr) + (device_config_str device_config) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.attach dbg sr device_config let set_name_label () ~dbg ~sr ~new_name_label = + info "SR.set_name_label dbg:%s sr:%s new_name_label:%s" dbg (s_of_sr sr) + new_name_label ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.set_name_label dbg sr new_name_label let set_name_description () ~dbg ~sr ~new_name_description = + info "SR.set_name_description dbg:%s sr:%s new_name_description:%s" dbg + (s_of_sr sr) new_name_description ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.set_name_description dbg sr new_name_description let detach () ~dbg ~sr = + info "SR.detach dbg:%s sr:%s" dbg (s_of_sr sr) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.detach dbg sr let destroy () ~dbg ~sr = + info "SR.destroy dbg:%s sr:%s" dbg (s_of_sr sr) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.destroy dbg sr let stat () ~dbg ~sr = + info "SR.stat dbg:%s sr:%s" dbg (s_of_sr sr) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.stat dbg sr let scan () ~dbg ~sr = + info "SR.scan dbg:%s sr:%s" dbg (s_of_sr sr) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.SR.scan dbg sr let list () ~dbg = + info "SR.list dbg:%s" dbg ; List.fold_left (fun acc (_, list) -> match list with SMSuccess l -> l @ acc | _ -> acc @@ -289,35 +326,73 @@ module Mux = struct end)) in C.SR.reset dbg sr - let update_snapshot_info_src () = Storage_migrate.update_snapshot_info_src + let update_snapshot_info_src () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi + ~snapshot_pairs = + info + "SR.update_snapshot_info_src dbg:%s sr:%s vdi:%s url:%s dest:%s \ + dest_vdi:%s snapshot_pairs:%s" + dbg (s_of_sr sr) (s_of_vdi vdi) url (s_of_sr dest) (s_of_vdi dest_vdi) + (List.map + (fun (local_snapshot, dest_snapshot) -> + Printf.sprintf "local:%s, dest:%s" (s_of_vdi local_snapshot) + (s_of_vdi dest_snapshot) + ) + snapshot_pairs + |> String.concat "; " + |> Printf.sprintf "[%s]" + ) ; + Storage_migrate.update_snapshot_info_src ~dbg ~sr ~vdi ~url ~dest + ~dest_vdi ~snapshot_pairs let update_snapshot_info_dest () ~dbg ~sr ~vdi ~src_vdi ~snapshot_pairs = let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in + info + "SR.update_snapshot_info_dest dbg:%s sr:%s vdi:%s ~src_vdi:%s \ + snapshot_pairs:%s" + dbg (s_of_sr sr) (s_of_vdi vdi) (s_of_vdi src_vdi.vdi) + (List.map + (fun (local_snapshot, src_snapshot_info) -> + Printf.sprintf "local:%s, src:%s" (s_of_vdi local_snapshot) + (s_of_vdi src_snapshot_info.vdi) + ) + snapshot_pairs + |> String.concat "; " + |> Printf.sprintf "[%s]" + ) ; C.SR.update_snapshot_info_dest dbg sr vdi src_vdi snapshot_pairs end module VDI = struct let create () ~dbg ~sr ~vdi_info = + info "VDI.create dbg:%s sr:%s vdi_info:%s" dbg (s_of_sr sr) + (string_of_vdi_info vdi_info) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.create dbg sr vdi_info let set_name_label () ~dbg ~sr ~vdi ~new_name_label = + info "VDI.set_name_label dbg:%s sr:%s vdi:%s new_name_label:%s" dbg + (s_of_sr sr) (s_of_vdi vdi) new_name_label ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.set_name_label dbg sr vdi new_name_label let set_name_description () ~dbg ~sr ~vdi ~new_name_description = + info + "VDI.set_name_description dbg:%s sr:%s vdi:%s new_name_description:%s" + dbg (s_of_sr sr) (s_of_vdi vdi) new_name_description ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.set_name_description dbg sr vdi new_name_description let snapshot () ~dbg ~sr ~vdi_info = + info "VDI.snapshot dbg:%s sr:%s vdi_info:%s" dbg (s_of_sr sr) + (string_of_vdi_info vdi_info) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in @@ -335,48 +410,64 @@ module Mux = struct ) let clone () ~dbg ~sr ~vdi_info = + info "VDI.clone dbg:%s sr:%s vdi_info:%s" dbg (s_of_sr sr) + (string_of_vdi_info vdi_info) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.clone dbg sr vdi_info let resize () ~dbg ~sr ~vdi ~new_size = + info "VDI.resize dbg:%s sr:%s vdi:%s new_size:%Ld" dbg (s_of_sr sr) + (s_of_vdi vdi) new_size ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.resize dbg sr vdi new_size let destroy () ~dbg ~sr ~vdi = + info "VDI.destroy dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.destroy dbg sr vdi let stat () ~dbg ~sr ~vdi = + info "VDI.stat dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.stat dbg sr vdi let introduce () ~dbg ~sr ~uuid ~sm_config ~location = + info "VDI.introduce dbg:%s sr:%s uuid:%s sm_config:%s location:%s" dbg + (s_of_sr sr) uuid + (String.concat ", " (List.map (fun (k, v) -> k ^ ":" ^ v) sm_config)) + location ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.introduce dbg sr uuid sm_config location let set_persistent () ~dbg ~sr ~vdi ~persistent = + info "VDI.set_persistent dbg:%s sr:%s vdi:%s persistent:%b" dbg + (s_of_sr sr) (s_of_vdi vdi) persistent ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.set_persistent dbg sr vdi persistent let epoch_begin () ~dbg ~sr ~vdi ~vm ~persistent = + info "VDI.epoch_begin dbg:%s sr:%s vdi:%s vm:%s persistent:%b" dbg + (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) persistent ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.epoch_begin dbg sr vdi vm persistent let attach () ~dbg ~dp ~sr ~vdi ~read_write = + info "VDI.attach dbg:%s dp:%s sr:%s vdi:%s read_write:%b" dbg dp + (s_of_sr sr) (s_of_vdi vdi) read_write ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in @@ -422,6 +513,8 @@ module Mux = struct ) let attach2 () ~dbg ~dp ~sr ~vdi ~read_write = + info "VDI.attach2 dbg:%s dp:%s sr:%s vdi:%s read_write:%b" dbg dp + (s_of_sr sr) (s_of_vdi vdi) read_write ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in @@ -455,12 +548,16 @@ module Mux = struct C.VDI.activate3 dbg dp sr vdi vm let deactivate () ~dbg ~dp ~sr ~vdi ~vm = + info "VDI.deactivate dbg:%s dp:%s sr:%s vdi:%s vm:%s" dbg dp (s_of_sr sr) + (s_of_vdi vdi) (s_of_vm vm) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.deactivate dbg dp sr vdi vm let detach () ~dbg ~dp ~sr ~vdi ~vm = + info "VDI.detach dbg:%s dp:%s sr:%s vdi:%s vm:%s" dbg dp (s_of_sr sr) + (s_of_vdi vdi) (s_of_vm vm) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in @@ -468,72 +565,91 @@ module Mux = struct DP_info.delete dp let epoch_end () ~dbg ~sr ~vdi ~vm = + info "VDI.epoch_end dbg:%s sr:%s vdi:%s vm:%s" dbg (s_of_sr sr) + (s_of_vdi vdi) (s_of_vm vm) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.epoch_end dbg sr vdi vm let get_by_name () ~dbg ~sr ~name = + info "VDI.get_by_name dbg:%s sr:%s name:%s" dbg (s_of_sr sr) name ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.get_by_name dbg sr name let set_content_id () ~dbg ~sr ~vdi ~content_id = + info "VDI.set_content_id dbg:%s sr:%s vdi:%s content_id:%s" dbg + (s_of_sr sr) (s_of_vdi vdi) content_id ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.set_content_id dbg sr vdi content_id let similar_content () ~dbg ~sr ~vdi = + info "VDI.similar_content dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) + (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.similar_content dbg sr vdi let compose () ~dbg ~sr ~vdi1 ~vdi2 = + info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" dbg (s_of_sr sr) + (s_of_vdi vdi1) (s_of_vdi vdi2) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.compose dbg sr vdi1 vdi2 let add_to_sm_config () ~dbg ~sr ~vdi ~key ~value = + info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" dbg + (s_of_sr sr) (s_of_vdi vdi) key value ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.add_to_sm_config dbg sr vdi key value let remove_from_sm_config () ~dbg ~sr ~vdi ~key = + info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" dbg + (s_of_sr sr) (s_of_vdi vdi) key ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.remove_from_sm_config dbg sr vdi key let get_url () ~dbg ~sr ~vdi = + info "VDI.get_url dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.get_url dbg sr vdi let enable_cbt () ~dbg ~sr ~vdi = + info "VDI.enable_cbt dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.enable_cbt dbg sr vdi let disable_cbt () ~dbg ~sr ~vdi = + info "VDI.disable_cbt dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.disable_cbt dbg sr vdi let data_destroy () ~dbg ~sr ~vdi = + info "VDI.data_destroy dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in C.VDI.data_destroy dbg sr vdi let list_changed_blocks () ~dbg ~sr ~vdi_from ~vdi_to = + info "VDI.list_changed_blocks dbg:%s sr:%s vdi_from:%s vdi_to:%s" dbg + (s_of_sr sr) (s_of_vdi vdi_from) (s_of_vdi vdi_to) ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in From 4f2dd37d58fb89023ccb9e739e177aeac64eb8c2 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 6 Dec 2022 15:19:02 +0000 Subject: [PATCH 06/11] Move SMAPIv1 module from storage_access to a separate file This avoids circular module dependencies in the following commits. Signed-off-by: Rob Hoes --- ocaml/xapi/storage_access.ml | 1149 +----------------------- ocaml/xapi/storage_access.mli | 19 - ocaml/xapi/storage_smapiv1.ml | 1167 +++++++++++++++++++++++++ ocaml/xapi/storage_smapiv1_wrapper.ml | 4 + ocaml/xapi/xapi_services.ml | 2 +- ocaml/xapi/xapi_vdi.ml | 2 +- 6 files changed, 1176 insertions(+), 1167 deletions(-) create mode 100644 ocaml/xapi/storage_smapiv1.ml diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 8d21c7c698b..5ea3e9ae342 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -56,1147 +56,6 @@ let transform_storage_exn f = (Api_errors.internal_error, [Printexc.to_string e]) ) -exception No_VDI - -(* Find a VDI given a storage-layer SR and VDI *) -let find_vdi ~__context sr vdi = - let sr = s_of_sr sr in - let vdi = s_of_vdi vdi in - let open Db_filter_types in - let sr = Db.SR.get_by_uuid ~__context ~uuid:sr in - match - Db.VDI.get_records_where ~__context - ~expr: - (And - ( Eq (Field "location", Literal vdi) - , Eq (Field "SR", Literal (Ref.string_of sr)) - ) - ) - with - | x :: _ -> - x - | _ -> - raise No_VDI - -(* Find a VDI reference given a name *) -let find_content ~__context ?sr name = - (* PR-1255: the backend should do this for us *) - let open Db_filter_types in - let expr = - Option.fold ~none:True - ~some:(fun sr -> - Eq - ( Field "SR" - , Literal - (Ref.string_of (Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr))) - ) - ) - sr - in - let all = Db.VDI.get_records_where ~__context ~expr in - List.find - (fun (_, vdi_rec) -> false || vdi_rec.API.vDI_location = name (* PR-1255 *)) - all - -let vdi_info_of_vdi_rec __context vdi_rec = - let content_id = - try List.assoc "content_id" vdi_rec.API.vDI_other_config - with Not_found -> vdi_rec.API.vDI_location - (* PR-1255 *) - in - { - vdi= Storage_interface.Vdi.of_string vdi_rec.API.vDI_location - ; uuid= Some vdi_rec.API.vDI_uuid - ; content_id - ; (* PR-1255 *) - name_label= vdi_rec.API.vDI_name_label - ; name_description= vdi_rec.API.vDI_name_description - ; ty= Storage_utils.string_of_vdi_type vdi_rec.API.vDI_type - ; metadata_of_pool= Ref.string_of vdi_rec.API.vDI_metadata_of_pool - ; is_a_snapshot= vdi_rec.API.vDI_is_a_snapshot - ; snapshot_time= Date.to_string vdi_rec.API.vDI_snapshot_time - ; snapshot_of= - ( if Db.is_valid_ref __context vdi_rec.API.vDI_snapshot_of then - Db.VDI.get_uuid ~__context ~self:vdi_rec.API.vDI_snapshot_of - else - "" - ) - |> Storage_interface.Vdi.of_string - ; read_only= vdi_rec.API.vDI_read_only - ; cbt_enabled= vdi_rec.API.vDI_cbt_enabled - ; virtual_size= vdi_rec.API.vDI_virtual_size - ; physical_utilisation= vdi_rec.API.vDI_physical_utilisation - ; persistent= vdi_rec.API.vDI_on_boot = `persist - ; sharable= vdi_rec.API.vDI_sharable - ; sm_config= vdi_rec.API.vDI_sm_config - } - -let redirect _sr = - raise (Storage_error (Redirect (Some (Pool_role.get_master_address ())))) - -module SMAPIv1 = struct - (** xapi's builtin ability to call local SM plugins using the existing - protocol. The code here should only call the SM functions and encapsulate - the return or error properly. It should not perform side-effects on - the xapi database: these should be handled in the layer above so they - can be shared with other SM implementation types. - - Where this layer has to perform interface adjustments (see VDI.activate - and the read/write debacle), this highlights desirable improvements to - the backend interface. - *) - - type context = unit - - let vdi_info_from_db ~__context self = - let vdi_rec = Db.VDI.get_record ~__context ~self in - vdi_info_of_vdi_rec __context vdi_rec - - (* For SMAPIv1, is_a_snapshot, snapshot_time and snapshot_of are stored in - * xapi's database. For SMAPIv2 they should be implemented by the storage - * backend. *) - let set_is_a_snapshot _context ~dbg ~sr ~vdi ~is_a_snapshot = - Server_helpers.exec_with_new_task "VDI.set_is_a_snapshot" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi, _ = find_vdi ~__context sr vdi in - Db.VDI.set_is_a_snapshot ~__context ~self:vdi ~value:is_a_snapshot - ) - - let set_snapshot_time _context ~dbg ~sr ~vdi ~snapshot_time = - Server_helpers.exec_with_new_task "VDI.set_snapshot_time" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi, _ = find_vdi ~__context sr vdi in - let snapshot_time = Date.of_string snapshot_time in - Db.VDI.set_snapshot_time ~__context ~self:vdi ~value:snapshot_time - ) - - let set_snapshot_of _context ~dbg ~sr ~vdi ~snapshot_of = - Server_helpers.exec_with_new_task "VDI.set_snapshot_of" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi, _ = find_vdi ~__context sr vdi in - let snapshot_of, _ = find_vdi ~__context sr snapshot_of in - Db.VDI.set_snapshot_of ~__context ~self:vdi ~value:snapshot_of - ) - - module Query = struct - let query _context ~dbg:_ = - { - driver= "storage_access" - ; name= "SMAPIv1 adapter" - ; description= - "Allows legacy SMAPIv1 adapters to expose an SMAPIv2 interface" - ; vendor= "XCP" - ; copyright= "see the source code" - ; version= "2.0" - ; required_api_version= "2.0" - ; features= [] - ; configuration= [] - ; required_cluster_stack= [] - } - - let diagnostics _context ~dbg:_ = - "No diagnostics are available for SMAPIv1 plugins" - end - - module DP = struct - let create _context ~dbg:_ ~id:_ = assert false - - let destroy _context ~dbg:_ ~dp:_ = assert false - - let diagnostics _context () = assert false - - let attach_info _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ = assert false - - let stat_vdi _context ~dbg:_ ~sr:_ ~vdi:_ = assert false - end - - module SR = struct - include Storage_skeleton.SR - - let probe _context ~dbg ~queue ~device_config ~sm_config = - let _type = - (* SMAPIv1 plugins have no namespaces, so strip off everything up to - the final dot *) - try - let i = String.rindex queue '.' in - String.sub queue (i + 1) (String.length queue - i - 1) - with Not_found -> queue - in - Server_helpers.exec_with_new_task "SR.probe" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let task = Context.get_task_id __context in - Storage_interface.Raw - (Sm.sr_probe - (Some task, Sm.sm_master true :: device_config) - _type sm_config - ) - ) - - let create _context ~dbg ~sr ~name_label ~name_description ~device_config - ~physical_size = - Server_helpers.exec_with_new_task "SR.create" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let subtask_of = Some (Context.get_task_id __context) in - let sr = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr) - in - Db.SR.set_name_label ~__context ~self:sr ~value:name_label ; - Db.SR.set_name_description ~__context ~self:sr ~value:name_description ; - let device_config = Sm.sm_master true :: device_config in - Sm.call_sm_functions ~__context ~sR:sr (fun _ _type -> - try - Sm.sr_create (subtask_of, device_config) _type sr physical_size - with - | Smint.Not_implemented_in_backend -> - error "SR.create failed SR:%s Not_implemented_in_backend" - (Ref.string_of sr) ; - raise - (Storage_interface.Storage_error - (Backend_error - ( Api_errors.sr_operation_not_supported - , [Ref.string_of sr] - ) - ) - ) - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | e -> - let e' = ExnHelper.string_of_exn e in - error "SR.create failed SR:%s error:%s" (Ref.string_of sr) e' ; - raise e - ) ; - List.filter (fun (x, _) -> x <> "SRmaster") device_config - ) - - let set_name_label _context ~dbg ~sr ~new_name_label = - Server_helpers.exec_with_new_task "SR.set_name_label" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr) - in - Db.SR.set_name_label ~__context ~self:sr ~value:new_name_label - ) - - let set_name_description _context ~dbg ~sr ~new_name_description = - Server_helpers.exec_with_new_task "SR.set_name_description" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr) - in - Db.SR.set_name_description ~__context ~self:sr - ~value:new_name_description - ) - - let attach _context ~dbg ~sr ~device_config = - Server_helpers.exec_with_new_task "SR.attach" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr) - in - (* Existing backends expect an SRMaster flag to be added - through the device-config. *) - let srmaster = Helpers.i_am_srmaster ~__context ~sr in - let device_config = Sm.sm_master srmaster :: device_config in - Sm.call_sm_functions ~__context ~sR:sr (fun _ _type -> - try - Sm.sr_attach - (Some (Context.get_task_id __context), device_config) - _type sr - with - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | e -> - let e' = ExnHelper.string_of_exn e in - error "SR.attach failed SR:%s error:%s" (Ref.string_of sr) e' ; - raise e - ) - ) - - let detach _context ~dbg ~sr = - Server_helpers.exec_with_new_task "SR.detach" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr) - in - Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> - try Sm.sr_detach device_config _type sr with - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | e -> - let e' = ExnHelper.string_of_exn e in - error "SR.detach failed SR:%s error:%s" (Ref.string_of sr) e' ; - raise e - ) - ) - - let reset _context ~dbg:_ ~sr:_ = assert false - - let destroy _context ~dbg ~sr = - Server_helpers.exec_with_new_task "SR.destroy" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr) - in - Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> - try Sm.sr_delete device_config _type sr with - | Smint.Not_implemented_in_backend -> - raise - (Storage_interface.Storage_error - (Backend_error - ( Api_errors.sr_operation_not_supported - , [Ref.string_of sr] - ) - ) - ) - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | e -> - let e' = ExnHelper.string_of_exn e in - error "SR.detach failed SR:%s error:%s" (Ref.string_of sr) e' ; - raise e - ) - ) - - let stat _context ~dbg ~sr:sr' = - Server_helpers.exec_with_new_task "SR.stat" ~subtask_of:(Ref.of_string dbg) - (fun __context -> - let sr = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr') - in - Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> - try - Sm.sr_update device_config _type sr ; - let r = Db.SR.get_record ~__context ~self:sr in - let sr_uuid = Some r.API.sR_uuid in - let name_label = r.API.sR_name_label in - let name_description = r.API.sR_name_description in - let total_space = r.API.sR_physical_size in - let free_space = - Int64.sub r.API.sR_physical_size r.API.sR_physical_utilisation - in - let clustered = false in - let health = Storage_interface.Healthy in - { - sr_uuid - ; name_label - ; name_description - ; total_space - ; free_space - ; clustered - ; health - } - with - | Smint.Not_implemented_in_backend -> - raise - (Storage_interface.Storage_error - (Backend_error - ( Api_errors.sr_operation_not_supported - , [Ref.string_of sr] - ) - ) - ) - | Api_errors.Server_error (code, params) -> - error "SR.scan failed SR:%s code=%s params=[%s]" - (Ref.string_of sr) code - (String.concat "; " params) ; - raise (Storage_error (Backend_error (code, params))) - | Sm.MasterOnly -> - redirect sr - | e -> - let e' = ExnHelper.string_of_exn e in - error "SR.scan failed SR:%s error:%s" (Ref.string_of sr) e' ; - raise e - ) - ) - - let scan _context ~dbg ~sr:sr' = - Server_helpers.exec_with_new_task "SR.scan" ~subtask_of:(Ref.of_string dbg) - (fun __context -> - let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr') in - Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> - try - Sm.sr_scan device_config _type sr ; - let open Db_filter_types in - let vdis = - Db.VDI.get_records_where ~__context - ~expr:(Eq (Field "SR", Literal (Ref.string_of sr))) - |> List.map snd - in - List.map (vdi_info_of_vdi_rec __context) vdis - with - | Smint.Not_implemented_in_backend -> - raise - (Storage_interface.Storage_error - (Backend_error - ( Api_errors.sr_operation_not_supported - , [Ref.string_of sr] - ) - ) - ) - | Api_errors.Server_error (code, params) -> - error "SR.scan failed SR:%s code=%s params=[%s]" - (Ref.string_of sr) code - (String.concat "; " params) ; - raise (Storage_error (Backend_error (code, params))) - | Sm.MasterOnly -> - redirect sr - | e -> - let e' = ExnHelper.string_of_exn e in - error "SR.scan failed SR:%s error:%s" (Ref.string_of sr) e' ; - raise e - ) - ) - - let list _context ~dbg:_ = assert false - - let update_snapshot_info_src _context ~dbg:_ ~sr:_ ~vdi:_ ~url:_ ~dest:_ - ~dest_vdi:_ ~snapshot_pairs:_ = - assert false - - let update_snapshot_info_dest _context ~dbg ~sr ~vdi ~src_vdi:_ - ~snapshot_pairs = - Server_helpers.exec_with_new_task "SR.update_snapshot_info_dest" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let local_vdis = scan __context ~dbg ~sr in - let find_sm_vdi ~vdi ~vdi_info_list = - try List.find (fun x -> x.vdi = vdi) vdi_info_list - with Not_found -> - raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) - in - let assert_content_ids_match ~vdi_info1 ~vdi_info2 = - if vdi_info1.content_id <> vdi_info2.content_id then - raise - (Storage_error - (Content_ids_do_not_match - (s_of_vdi vdi_info1.vdi, s_of_vdi vdi_info2.vdi) - ) - ) - in - (* For each (local snapshot vdi, source snapshot vdi) pair: - * - Check that the content_ids are the same - * - Copy snapshot_time from the source VDI to the local VDI - * - Set the local VDI's snapshot_of to vdi - * - Set is_a_snapshot = true for the local snapshot *) - List.iter - (fun (local_snapshot, src_snapshot_info) -> - let local_snapshot_info = - find_sm_vdi ~vdi:local_snapshot ~vdi_info_list:local_vdis - in - assert_content_ids_match ~vdi_info1:local_snapshot_info - ~vdi_info2:src_snapshot_info ; - set_snapshot_time __context ~dbg ~sr ~vdi:local_snapshot - ~snapshot_time:src_snapshot_info.snapshot_time ; - set_snapshot_of __context ~dbg ~sr ~vdi:local_snapshot - ~snapshot_of:vdi ; - set_is_a_snapshot __context ~dbg ~sr ~vdi:local_snapshot - ~is_a_snapshot:true - ) - snapshot_pairs - ) - end - - module VDI = struct - let for_vdi ~dbg ~sr ~vdi op_name f = - Server_helpers.exec_with_new_task op_name ~subtask_of:(Ref.of_string dbg) - (fun __context -> - let self = find_vdi ~__context sr vdi |> fst in - Sm.call_sm_vdi_functions ~__context ~vdi:self - (fun device_config _type sr -> f device_config _type sr self - ) - ) - - (* Allow us to remember whether a VDI is attached read/only or read/write. - If this is meaningful to the backend then this should be recorded there! *) - let vdi_read_write = Hashtbl.create 10 - - let vdi_read_write_m = Mutex.create () - - let vdi_read_caching_m = Mutex.create () - - let per_host_key ~__context ~prefix = - let host_uuid = - Db.Host.get_uuid ~__context ~self:(Helpers.get_localhost ~__context) - in - Printf.sprintf "%s-%s" prefix host_uuid - - let read_caching_key ~__context = - per_host_key ~__context ~prefix:"read-caching-enabled-on" - - let read_caching_reason_key ~__context = - per_host_key ~__context ~prefix:"read-caching-reason" - - let epoch_begin _context ~dbg ~sr ~vdi ~vm:_ ~persistent:_ = - try - for_vdi ~dbg ~sr ~vdi "VDI.epoch_begin" - (fun device_config _type sr self -> - Sm.vdi_epoch_begin device_config _type sr self - ) - with Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - - let attach2 _context ~dbg ~dp:_ ~sr ~vdi ~read_write = - try - let backend = - for_vdi ~dbg ~sr ~vdi "VDI.attach2" - (fun device_config _type sr self -> - let attach_info_v1 = - Sm.vdi_attach device_config _type sr self read_write - in - (* Record whether the VDI is benefiting from read caching *) - Server_helpers.exec_with_new_task "VDI.attach2" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let read_caching = not attach_info_v1.Smint.o_direct in - let on_key = read_caching_key ~__context in - let reason_key = read_caching_reason_key ~__context in - with_lock vdi_read_caching_m (fun () -> - Db.VDI.remove_from_sm_config ~__context ~self ~key:on_key ; - Db.VDI.remove_from_sm_config ~__context ~self - ~key:reason_key ; - Db.VDI.add_to_sm_config ~__context ~self ~key:on_key - ~value:(string_of_bool read_caching) ; - if not read_caching then - Db.VDI.add_to_sm_config ~__context ~self ~key:reason_key - ~value:attach_info_v1.Smint.o_direct_reason - ) - ) ; - { - implementations= - [ - XenDisk - { - params= attach_info_v1.Smint.params - ; extra= attach_info_v1.Smint.xenstore_data - ; backend_type= "vbd3" - } - ; (* Currently we always get a BlockDevice from SMAPIv1, never a File, not even for ISOs *) - BlockDevice {path= attach_info_v1.Smint.params} - ] - } - ) - in - with_lock vdi_read_write_m (fun () -> - Hashtbl.replace vdi_read_write (sr, vdi) read_write - ) ; - backend - with Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - - let attach3 context ~dbg ~dp ~sr ~vdi ~vm:_ ~read_write = - (*Throw away vm argument as does nothing in SMAPIv1*) - attach2 context ~dbg ~dp ~sr ~vdi ~read_write - - let attach _ = - failwith - "We'll never get here: attach is implemented in \ - Storage_smapiv1_wrapper.Wrapper" - - let activate _context ~dbg ~dp ~sr ~vdi = - try - let read_write = - with_lock vdi_read_write_m (fun () -> - if not (Hashtbl.mem vdi_read_write (sr, vdi)) then - error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" - (s_of_sr sr) (s_of_vdi vdi) ; - Hashtbl.find vdi_read_write (sr, vdi) - ) - in - for_vdi ~dbg ~sr ~vdi "VDI.activate" (fun device_config _type sr self -> - Server_helpers.exec_with_new_task "VDI.activate" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - if read_write then - Db.VDI.remove_from_other_config ~__context ~self - ~key:"content_id" - ) ; - (* If the backend doesn't advertise the capability then do nothing *) - if List.mem_assoc Smint.Vdi_activate (Sm.features_of_driver _type) - then - Sm.vdi_activate device_config _type sr self read_write - else - info "%s sr:%s does not support vdi_activate: doing nothing" dp - (Ref.string_of sr) - ) - with Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - - let activate3 context ~dbg ~dp ~sr ~vdi ~vm:_ = - activate context ~dbg ~dp ~sr ~vdi - - let deactivate _context ~dbg ~dp ~sr ~vdi ~vm:_ = - try - for_vdi ~dbg ~sr ~vdi "VDI.deactivate" - (fun device_config _type sr self -> - Server_helpers.exec_with_new_task "VDI.deactivate" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let other_config = Db.VDI.get_other_config ~__context ~self in - if not (List.mem_assoc "content_id" other_config) then - Db.VDI.add_to_other_config ~__context ~self ~key:"content_id" - ~value:Uuidx.(to_string (make ())) - ) ; - (* If the backend doesn't advertise the capability then do nothing *) - if List.mem_assoc Smint.Vdi_deactivate (Sm.features_of_driver _type) - then - Sm.vdi_deactivate device_config _type sr self - else - info "%s sr:%s does not support vdi_deactivate: doing nothing" dp - (Ref.string_of sr) - ) - with Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - - let detach _context ~dbg ~dp:_ ~sr ~vdi ~vm:_ = - try - for_vdi ~dbg ~sr ~vdi "VDI.detach" (fun device_config _type sr self -> - Sm.vdi_detach device_config _type sr self ; - Server_helpers.exec_with_new_task "VDI.detach" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let on_key = read_caching_key ~__context in - let reason_key = read_caching_reason_key ~__context in - with_lock vdi_read_caching_m (fun () -> - Db.VDI.remove_from_sm_config ~__context ~self ~key:on_key ; - Db.VDI.remove_from_sm_config ~__context ~self - ~key:reason_key - ) - ) - ) ; - with_lock vdi_read_write_m (fun () -> - Hashtbl.remove vdi_read_write (sr, vdi) - ) - with Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - - let epoch_end _context ~dbg ~sr ~vdi ~vm:_ = - try - for_vdi ~dbg ~sr ~vdi "VDI.epoch_end" - (fun device_config _type sr self -> - Sm.vdi_epoch_end device_config _type sr self - ) - with Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - - let require_uuid vdi_info = - match vdi_info.Smint.vdi_info_uuid with - | Some uuid -> - uuid - | None -> - failwith "SM backend failed to return field" - - let newvdi ~__context vi = - (* The current backends stash data directly in the db *) - let uuid = require_uuid vi in - vdi_info_from_db ~__context (Db.VDI.get_by_uuid ~__context ~uuid) - - let create _context ~dbg ~sr ~vdi_info = - try - Server_helpers.exec_with_new_task "VDI.create" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in - let vi = - Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> - Sm.vdi_create device_config _type sr vdi_info.sm_config - vdi_info.ty vdi_info.virtual_size vdi_info.name_label - vdi_info.name_description vdi_info.metadata_of_pool - vdi_info.is_a_snapshot vdi_info.snapshot_time - (s_of_vdi vdi_info.snapshot_of) - vdi_info.read_only - ) - in - newvdi ~__context vi - ) - with - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | Sm.MasterOnly -> - redirect sr - - (* A list of keys in sm-config that will be preserved on clone/snapshot *) - let sm_config_keys_to_preserve_on_clone = ["base_mirror"] - - let snapshot_and_clone call_name call_f is_a_snapshot _context ~dbg ~sr - ~vdi_info = - try - Server_helpers.exec_with_new_task call_name - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vi = - for_vdi ~dbg ~sr ~vdi:vdi_info.vdi call_name - (fun device_config _type sr self -> - call_f device_config _type vdi_info.sm_config sr self - ) - in - (* PR-1255: modify clone, snapshot to take the same parameters as create? *) - let self, _ = - find_vdi ~__context sr - (Storage_interface.Vdi.of_string vi.Smint.vdi_info_location) - in - let clonee, _ = find_vdi ~__context sr vdi_info.vdi in - let content_id = - try - List.assoc "content_id" - (Db.VDI.get_other_config ~__context ~self:clonee) - with _ -> Uuidx.(to_string (make ())) - in - let snapshot_time = Date.of_float (Unix.gettimeofday ()) in - Db.VDI.set_name_label ~__context ~self ~value:vdi_info.name_label ; - Db.VDI.set_name_description ~__context ~self - ~value:vdi_info.name_description ; - Db.VDI.set_snapshot_time ~__context ~self ~value:snapshot_time ; - Db.VDI.set_is_a_snapshot ~__context ~self ~value:is_a_snapshot ; - Db.VDI.remove_from_other_config ~__context ~self ~key:"content_id" ; - Db.VDI.add_to_other_config ~__context ~self ~key:"content_id" - ~value:content_id ; - debug "copying sm-config" ; - List.iter - (fun (key, value) -> - let preserve = - List.mem key sm_config_keys_to_preserve_on_clone - in - if preserve then ( - Db.VDI.remove_from_sm_config ~__context ~self ~key ; - Db.VDI.add_to_sm_config ~__context ~self ~key ~value - ) - ) - vdi_info.sm_config ; - for_vdi ~dbg ~sr - ~vdi:(Storage_interface.Vdi.of_string vi.Smint.vdi_info_location) - "VDI.update" (fun device_config _type sr self -> - Sm.vdi_update device_config _type sr self - ) ; - let vdi = vdi_info_from_db ~__context self in - debug "vdi = %s" (string_of_vdi_info vdi) ; - vdi - ) - with - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | Smint.Not_implemented_in_backend -> - raise (Storage_error (Unimplemented call_name)) - | Sm.MasterOnly -> - redirect sr - - let snapshot = snapshot_and_clone "VDI.snapshot" Sm.vdi_snapshot true - - let clone = snapshot_and_clone "VDI.clone" Sm.vdi_clone false - - let set_name_label _context ~dbg ~sr ~vdi ~new_name_label = - Server_helpers.exec_with_new_task "VDI.set_name_label" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let self, _ = find_vdi ~__context sr vdi in - Db.VDI.set_name_label ~__context ~self ~value:new_name_label - ) - - let set_name_description _context ~dbg ~sr ~vdi ~new_name_description = - Server_helpers.exec_with_new_task "VDI.set_name_description" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let self, _ = find_vdi ~__context sr vdi in - Db.VDI.set_name_description ~__context ~self - ~value:new_name_description - ) - - let resize _context ~dbg ~sr ~vdi ~new_size = - try - let vi = - for_vdi ~dbg ~sr ~vdi "VDI.resize" (fun device_config _type sr self -> - Sm.vdi_resize device_config _type sr self new_size - ) - in - Server_helpers.exec_with_new_task "VDI.resize" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let self, _ = - find_vdi ~__context sr - (Storage_interface.Vdi.of_string vi.Smint.vdi_info_location) - in - Db.VDI.get_virtual_size ~__context ~self - ) - with - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | Smint.Not_implemented_in_backend -> - raise (Storage_error (Unimplemented "VDI.resize")) - | Sm.MasterOnly -> - redirect sr - - let destroy _context ~dbg ~sr ~vdi = - try - for_vdi ~dbg ~sr ~vdi "VDI.destroy" (fun device_config _type sr self -> - Sm.vdi_delete device_config _type sr self - ) ; - with_lock vdi_read_write_m (fun () -> - Hashtbl.remove vdi_read_write (sr, vdi) - ) - with - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | No_VDI -> - raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) - | Sm.MasterOnly -> - redirect sr - - let stat _context ~dbg ~sr ~vdi = - try - Server_helpers.exec_with_new_task "VDI.stat" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - for_vdi ~dbg ~sr ~vdi "VDI.stat" (fun device_config _type sr self -> - Sm.vdi_update device_config _type sr self ; - vdi_info_of_vdi_rec __context - (Db.VDI.get_record ~__context ~self) - ) - ) - with e -> - error "VDI.stat caught: %s" (Printexc.to_string e) ; - raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) - - let introduce _context ~dbg ~sr ~uuid ~sm_config ~location = - try - Server_helpers.exec_with_new_task "VDI.introduce" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in - let vi = - Sm.call_sm_functions ~__context ~sR:sr - (fun device_config sr_type -> - Sm.vdi_introduce device_config sr_type sr uuid sm_config - location - ) - in - newvdi ~__context vi - ) - with e -> - error "VDI.introduce caught: %s" (Printexc.to_string e) ; - raise (Storage_error (Vdi_does_not_exist location)) - - let set_persistent _context ~dbg ~sr ~vdi ~persistent = - try - Server_helpers.exec_with_new_task "VDI.set_persistent" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - if not persistent then ( - info - "VDI.set_persistent: calling VDI.clone and VDI.destroy to make \ - an empty vhd-leaf" ; - let new_vdi = - for_vdi ~dbg ~sr ~vdi "VDI.clone" - (fun device_config _type sr self -> - let vi = Sm.vdi_clone device_config _type [] sr self in - Storage_interface.Vdi.of_string vi.Smint.vdi_info_location - ) - in - for_vdi ~dbg ~sr ~vdi:new_vdi "VDI.destroy" - (fun device_config _type sr self -> - Sm.vdi_delete device_config _type sr self - ) - ) - ) - with - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | Sm.MasterOnly -> - redirect sr - - let get_by_name _context ~dbg ~sr ~name = - info "VDI.get_by_name dbg:%s sr:%s name:%s" dbg (s_of_sr sr) name ; - (* PR-1255: the backend should do this for us *) - Server_helpers.exec_with_new_task "VDI.get_by_name" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - (* PR-1255: the backend should do this for us *) - try - let _, vdi = find_content ~__context ~sr name in - let vi = vdi_info_of_vdi_rec __context vdi in - debug "VDI.get_by_name returning successfully" ; - vi - with e -> - error "VDI.get_by_name caught: %s" (Printexc.to_string e) ; - raise (Storage_error (Vdi_does_not_exist name)) - ) - - let set_content_id _context ~dbg ~sr ~vdi ~content_id = - info "VDI.get_by_content dbg:%s sr:%s vdi:%s content_id:%s" dbg - (s_of_sr sr) (s_of_vdi vdi) content_id ; - (* PR-1255: the backend should do this for us *) - Server_helpers.exec_with_new_task "VDI.set_content_id" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi, _ = find_vdi ~__context sr vdi in - Db.VDI.remove_from_other_config ~__context ~self:vdi ~key:"content_id" ; - Db.VDI.add_to_other_config ~__context ~self:vdi ~key:"content_id" - ~value:content_id - ) - - let similar_content _context ~dbg ~sr ~vdi = - info "VDI.similar_content dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) - (s_of_vdi vdi) ; - Server_helpers.exec_with_new_task "VDI.similar_content" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - (* PR-1255: the backend should do this for us. *) - let sr_ref = - Db.SR.get_by_uuid ~__context - ~uuid:(Storage_interface.Sr.string_of sr) - in - (* Return a nearest-first list of similar VDIs. "near" should mean - "has similar blocks" but we approximate this with distance in the tree *) - let module StringMap = Map.Make (struct - type t = string - - let compare = compare - end) in - let _vhdparent = "vhd-parent" in - let open Db_filter_types in - let all = - Db.VDI.get_records_where ~__context - ~expr:(Eq (Field "SR", Literal (Ref.string_of sr_ref))) - in - let locations = - List.fold_left - (fun acc (_, vdi_rec) -> - StringMap.add vdi_rec.API.vDI_location vdi_rec acc - ) - StringMap.empty all - in - (* Compute a map of parent location -> children locations *) - let children, parents = - List.fold_left - (fun (children, parents) (_, vdi_rec) -> - if List.mem_assoc _vhdparent vdi_rec.API.vDI_sm_config then - let me = vdi_rec.API.vDI_location in - let parent = - List.assoc _vhdparent vdi_rec.API.vDI_sm_config - in - let other_children = - if StringMap.mem parent children then - StringMap.find parent children - else - [] - in - ( StringMap.add parent (me :: other_children) children - , StringMap.add me parent parents - ) - else - (children, parents) - ) - (StringMap.empty, StringMap.empty) - all - in - let rec explore current_distance acc vdi = - (* add me *) - let acc = StringMap.add vdi current_distance acc in - (* add the parent *) - let parent = - if StringMap.mem vdi parents then - [StringMap.find vdi parents] - else - [] - in - let children = - if StringMap.mem vdi children then - StringMap.find vdi children - else - [] - in - List.fold_left - (fun acc vdi -> - if not (StringMap.mem vdi acc) then - explore (current_distance + 1) acc vdi - else - acc - ) - acc (parent @ children) - in - let module IntMap = Map.Make (struct - type t = int - - let compare = compare - end) in - let invert map = - StringMap.fold - (fun vdi n acc -> - let current = - if IntMap.mem n acc then IntMap.find n acc else [] - in - IntMap.add n (vdi :: current) acc - ) - map IntMap.empty - in - let _, vdi_rec = find_vdi ~__context sr vdi in - let vdis = - explore 0 StringMap.empty vdi_rec.API.vDI_location - |> invert - |> IntMap.bindings - |> List.map snd - |> List.concat - in - let vdi_recs = List.map (fun l -> StringMap.find l locations) vdis in - (* We drop cbt_metadata VDIs that do not have any actual data *) - let vdi_recs = - List.filter (fun r -> r.API.vDI_type <> `cbt_metadata) vdi_recs - in - List.map (fun x -> vdi_info_of_vdi_rec __context x) vdi_recs - ) - - let compose _context ~dbg ~sr ~vdi1 ~vdi2 = - info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" dbg (s_of_sr sr) - (s_of_vdi vdi1) (s_of_vdi vdi2) ; - try - Server_helpers.exec_with_new_task "VDI.compose" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - (* This call 'operates' on vdi2 *) - let vdi1 = find_vdi ~__context sr vdi1 |> fst in - for_vdi ~dbg ~sr ~vdi:vdi2 "VDI.compose" - (fun device_config _type sr self -> - Sm.vdi_compose device_config _type sr vdi1 self - ) - ) - with - | Smint.Not_implemented_in_backend -> - raise (Storage_error (Unimplemented "VDI.compose")) - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | No_VDI -> - raise - (Storage_error - (Vdi_does_not_exist (Storage_interface.Vdi.string_of vdi1)) - ) - | Sm.MasterOnly -> - redirect sr - - let add_to_sm_config _context ~dbg ~sr ~vdi ~key ~value = - info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" dbg - (s_of_sr sr) (s_of_vdi vdi) key value ; - Server_helpers.exec_with_new_task "VDI.add_to_sm_config" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let self = find_vdi ~__context sr vdi |> fst in - Db.VDI.add_to_sm_config ~__context ~self ~key ~value - ) - - let remove_from_sm_config _context ~dbg ~sr ~vdi ~key = - info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" dbg - (s_of_sr sr) (s_of_vdi vdi) key ; - Server_helpers.exec_with_new_task "VDI.remove_from_sm_config" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let self = find_vdi ~__context sr vdi |> fst in - Db.VDI.remove_from_sm_config ~__context ~self ~key - ) - - let get_url _context ~dbg ~sr ~vdi = - info "VDI.get_url dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; - (* XXX: PR-1255: tapdisk shouldn't hardcode xapi urls *) - (* peer_ip/session_ref/vdi_ref *) - Server_helpers.exec_with_new_task "VDI.get_url" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let ip = Helpers.get_management_ip_addr ~__context |> Option.get in - let rpc = Helpers.make_rpc ~__context in - let localhost = Helpers.get_localhost ~__context in - (* XXX: leaked *) - let session_ref = - XenAPI.Session.slave_login ~rpc ~host:localhost - ~psecret:(Xapi_globs.pool_secret ()) - in - let vdi, _ = find_vdi ~__context sr vdi in - Printf.sprintf "%s/%s/%s" ip - (Ref.string_of session_ref) - (Ref.string_of vdi) - ) - - let call_cbt_function _context ~f ~f_name ~dbg ~sr ~vdi = - try - for_vdi ~dbg ~sr ~vdi f_name (fun device_config _type sr self -> - f device_config _type sr self - ) - with - | Smint.Not_implemented_in_backend -> - raise (Storage_error (Unimplemented f_name)) - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | No_VDI -> - raise - (Storage_error - (Vdi_does_not_exist (Storage_interface.Vdi.string_of vdi)) - ) - | Sm.MasterOnly -> - redirect sr - - let enable_cbt context = - call_cbt_function context ~f:Sm.vdi_enable_cbt ~f_name:"VDI.enable_cbt" - - let disable_cbt context = - call_cbt_function context ~f:Sm.vdi_disable_cbt ~f_name:"VDI.disable_cbt" - - let data_destroy context ~dbg ~sr ~vdi = - call_cbt_function context ~f:Sm.vdi_data_destroy - ~f_name:"VDI.data_destroy" ~dbg ~sr ~vdi ; - set_content_id context ~dbg ~sr ~vdi - ~content_id:"/No content: this is a cbt_metadata VDI/" - - let list_changed_blocks _context ~dbg ~sr ~vdi_from ~vdi_to = - try - Server_helpers.exec_with_new_task "VDI.list_changed_blocks" - ~subtask_of:(Ref.of_string dbg) (fun __context -> - let vdi_from = find_vdi ~__context sr vdi_from |> fst in - for_vdi ~dbg ~sr ~vdi:vdi_to "VDI.list_changed_blocks" - (fun device_config _type sr vdi_to -> - Sm.vdi_list_changed_blocks device_config _type sr ~vdi_from - ~vdi_to - ) - ) - with - | Smint.Not_implemented_in_backend -> - raise (Storage_error (Unimplemented "VDI.list_changed_blocks")) - | Api_errors.Server_error (code, params) -> - raise (Storage_error (Backend_error (code, params))) - | Sm.MasterOnly -> - redirect sr - end - - let get_by_name _context ~dbg:_ ~name:_ = assert false - - module DATA = struct - let copy_into _context ~dbg:_ ~sr:_ ~vdi:_ ~url:_ ~dest:_ ~dest_vdi:_ - ~verify_dest:_ = - assert false - - let copy _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ ~url:_ ~dest:_ ~verify_dest:_ = - assert false - - module MIRROR = struct - let start _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ ~url:_ ~dest:_ ~verify_dest:_ - = - assert false - - let stop _context ~dbg:_ ~id:_ = assert false - - let list _context ~dbg:_ = assert false - - let stat _context ~dbg:_ ~id:_ = assert false - - let receive_start _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ = - assert false - - let receive_finalize _context ~dbg:_ ~id:_ = assert false - - let receive_cancel _context ~dbg:_ ~id:_ = assert false - end - end - - module Policy = struct - let get_backend_vm _context ~dbg:_ ~vm:_ ~sr:_ ~vdi:_ = assert false - end - - module TASK = struct - let stat _context ~dbg:_ ~task:_ = assert false - - let destroy _context ~dbg:_ ~task:_ = assert false - - let cancel _context ~dbg:_ ~task:_ = assert false - - let list _context ~dbg:_ = assert false - end - - module UPDATES = struct - let get _context ~dbg:_ ~from:_ ~timeout:_ = assert false - end -end - (* Start a set of servers for all SMAPIv1 plugins *) let start_smapiv1_servers () = let drivers = Sm.supported_drivers () in @@ -1204,9 +63,7 @@ let start_smapiv1_servers () = (fun ty -> let path = !Storage_interface.default_path ^ ".d/" ^ ty in let queue_name = !Storage_interface.queue_name ^ "." ^ ty in - let module S = - Storage_interface.Server (Storage_smapiv1_wrapper.Wrapper (SMAPIv1)) () - in + let module S = Storage_smapiv1_wrapper.Server in let s = Xcp_service.make ~path ~queue_name ~rpc_fn:S.process () in let (_ : Thread.t) = Thread.create (fun () -> Xcp_service.serve_forever s) () @@ -1886,8 +743,8 @@ let refresh_local_vdi_activations ~__context = in let remember key ro_rw = (* The module above contains a hashtable of R/O vs R/W-ness *) - with_lock SMAPIv1.VDI.vdi_read_write_m (fun () -> - Hashtbl.replace SMAPIv1.VDI.vdi_read_write key (ro_rw = RW) + with_lock Storage_smapiv1.vdi_read_write_m (fun () -> + Hashtbl.replace Storage_smapiv1.vdi_read_write key (ro_rw = RW) ) in let dbg = Ref.string_of (Context.get_task_id __context) in diff --git a/ocaml/xapi/storage_access.mli b/ocaml/xapi/storage_access.mli index deab895768a..28cf3108dee 100644 --- a/ocaml/xapi/storage_access.mli +++ b/ocaml/xapi/storage_access.mli @@ -25,25 +25,6 @@ val start : unit -> unit (** once [start ()] returns the storage service is listening for requests on its unix domain socket. *) -val find_vdi : - __context:Context.t - -> Storage_interface.sr - -> Storage_interface.vdi - -> API.ref_VDI * API.vDI_t -(** [find_vdi __context sr vdi] returns the XenAPI VDI ref associated - with (sr, vdi) *) - -val find_content : - __context:Context.t - -> ?sr:Storage_interface.sr - -> Storage_interface.content_id - -> API.ref_VDI * API.vDI_t -(** [find_content __context ?sr content_id] returns the XenAPI VDI ref associated - with [content_id] *) - -val vdi_info_of_vdi_rec : Context.t -> API.vDI_t -> Storage_interface.vdi_info -(** [vdi_info_of_vdi_rec __context vdi_rec] constructs a vdi_info record from information in the given VDI database record. *) - val bind : __context:Context.t -> pbd:API.ref_PBD -> Storage_interface.query_result (** [bind __context pbd] causes the storage_access module to choose the most diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml new file mode 100644 index 00000000000..dcd0db2dda4 --- /dev/null +++ b/ocaml/xapi/storage_smapiv1.ml @@ -0,0 +1,1167 @@ +(* + * Copyright (C) 2006-2011 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. + *) + +module D = Debug.Make (struct let name = __MODULE__ end) + +open D +module Date = Xapi_stdext_date.Date +module XenAPI = Client.Client +open Storage_interface + +exception No_VDI + +let s_of_vdi = Vdi.string_of + +let s_of_sr = Sr.string_of + +let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute + +(* Find a VDI given a storage-layer SR and VDI *) +let find_vdi ~__context sr vdi = + let sr = s_of_sr sr in + let vdi = s_of_vdi vdi in + let open Db_filter_types in + let sr = Db.SR.get_by_uuid ~__context ~uuid:sr in + match + Db.VDI.get_records_where ~__context + ~expr: + (And + ( Eq (Field "location", Literal vdi) + , Eq (Field "SR", Literal (Ref.string_of sr)) + ) + ) + with + | x :: _ -> + x + | _ -> + raise No_VDI + +(* Find a VDI reference given a name *) +let find_content ~__context ?sr name = + (* PR-1255: the backend should do this for us *) + let open Db_filter_types in + let expr = + Option.fold ~none:True + ~some:(fun sr -> + Eq + ( Field "SR" + , Literal + (Ref.string_of (Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr))) + ) + ) + sr + in + let all = Db.VDI.get_records_where ~__context ~expr in + List.find + (fun (_, vdi_rec) -> false || vdi_rec.API.vDI_location = name (* PR-1255 *)) + all + +let vdi_info_of_vdi_rec __context vdi_rec = + let content_id = + try List.assoc "content_id" vdi_rec.API.vDI_other_config + with Not_found -> vdi_rec.API.vDI_location + (* PR-1255 *) + in + { + vdi= Storage_interface.Vdi.of_string vdi_rec.API.vDI_location + ; uuid= Some vdi_rec.API.vDI_uuid + ; content_id + ; (* PR-1255 *) + name_label= vdi_rec.API.vDI_name_label + ; name_description= vdi_rec.API.vDI_name_description + ; ty= Storage_utils.string_of_vdi_type vdi_rec.API.vDI_type + ; metadata_of_pool= Ref.string_of vdi_rec.API.vDI_metadata_of_pool + ; is_a_snapshot= vdi_rec.API.vDI_is_a_snapshot + ; snapshot_time= Date.to_string vdi_rec.API.vDI_snapshot_time + ; snapshot_of= + ( if Db.is_valid_ref __context vdi_rec.API.vDI_snapshot_of then + Db.VDI.get_uuid ~__context ~self:vdi_rec.API.vDI_snapshot_of + else + "" + ) + |> Storage_interface.Vdi.of_string + ; read_only= vdi_rec.API.vDI_read_only + ; cbt_enabled= vdi_rec.API.vDI_cbt_enabled + ; virtual_size= vdi_rec.API.vDI_virtual_size + ; physical_utilisation= vdi_rec.API.vDI_physical_utilisation + ; persistent= vdi_rec.API.vDI_on_boot = `persist + ; sharable= vdi_rec.API.vDI_sharable + ; sm_config= vdi_rec.API.vDI_sm_config + } + +let redirect _sr = + raise (Storage_error (Redirect (Some (Pool_role.get_master_address ())))) + +(* Allow us to remember whether a VDI is attached read/only or read/write. + If this is meaningful to the backend then this should be recorded there! *) +let vdi_read_write = Hashtbl.create 10 + +let vdi_read_write_m = Mutex.create () + +let vdi_read_caching_m = Mutex.create () + +module SMAPIv1 : Server_impl = struct + (** xapi's builtin ability to call local SM plugins using the existing + protocol. The code here should only call the SM functions and encapsulate + the return or error properly. It should not perform side-effects on + the xapi database: these should be handled in the layer above so they + can be shared with other SM implementation types. + + Where this layer has to perform interface adjustments (see VDI.activate + and the read/write debacle), this highlights desirable improvements to + the backend interface. + *) + + type context = unit + + let vdi_info_from_db ~__context self = + let vdi_rec = Db.VDI.get_record ~__context ~self in + vdi_info_of_vdi_rec __context vdi_rec + + (* For SMAPIv1, is_a_snapshot, snapshot_time and snapshot_of are stored in + * xapi's database. For SMAPIv2 they should be implemented by the storage + * backend. *) + let set_is_a_snapshot _context ~dbg ~sr ~vdi ~is_a_snapshot = + Server_helpers.exec_with_new_task "VDI.set_is_a_snapshot" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + Db.VDI.set_is_a_snapshot ~__context ~self:vdi ~value:is_a_snapshot + ) + + let set_snapshot_time _context ~dbg ~sr ~vdi ~snapshot_time = + Server_helpers.exec_with_new_task "VDI.set_snapshot_time" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + let snapshot_time = Date.of_string snapshot_time in + Db.VDI.set_snapshot_time ~__context ~self:vdi ~value:snapshot_time + ) + + let set_snapshot_of _context ~dbg ~sr ~vdi ~snapshot_of = + Server_helpers.exec_with_new_task "VDI.set_snapshot_of" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + let snapshot_of, _ = find_vdi ~__context sr snapshot_of in + Db.VDI.set_snapshot_of ~__context ~self:vdi ~value:snapshot_of + ) + + module Query = struct + let query _context ~dbg:_ = + { + driver= "storage_access" + ; name= "SMAPIv1 adapter" + ; description= + "Allows legacy SMAPIv1 adapters to expose an SMAPIv2 interface" + ; vendor= "XCP" + ; copyright= "see the source code" + ; version= "2.0" + ; required_api_version= "2.0" + ; features= [] + ; configuration= [] + ; required_cluster_stack= [] + } + + let diagnostics _context ~dbg:_ = + "No diagnostics are available for SMAPIv1 plugins" + end + + module DP = struct + let create _context ~dbg:_ ~id:_ = assert false + + let destroy _context ~dbg:_ ~dp:_ = assert false + + let diagnostics _context () = assert false + + let attach_info _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ = assert false + + let stat_vdi _context ~dbg:_ ~sr:_ ~vdi:_ = assert false + end + + module SR = struct + include Storage_skeleton.SR + + let probe _context ~dbg ~queue ~device_config ~sm_config = + let _type = + (* SMAPIv1 plugins have no namespaces, so strip off everything up to + the final dot *) + try + let i = String.rindex queue '.' in + String.sub queue (i + 1) (String.length queue - i - 1) + with Not_found -> queue + in + Server_helpers.exec_with_new_task "SR.probe" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let task = Context.get_task_id __context in + Storage_interface.Raw + (Sm.sr_probe + (Some task, Sm.sm_master true :: device_config) + _type sm_config + ) + ) + + let create _context ~dbg ~sr ~name_label ~name_description ~device_config + ~physical_size = + Server_helpers.exec_with_new_task "SR.create" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let subtask_of = Some (Context.get_task_id __context) in + let sr = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr) + in + Db.SR.set_name_label ~__context ~self:sr ~value:name_label ; + Db.SR.set_name_description ~__context ~self:sr ~value:name_description ; + let device_config = Sm.sm_master true :: device_config in + Sm.call_sm_functions ~__context ~sR:sr (fun _ _type -> + try + Sm.sr_create (subtask_of, device_config) _type sr physical_size + with + | Smint.Not_implemented_in_backend -> + error "SR.create failed SR:%s Not_implemented_in_backend" + (Ref.string_of sr) ; + raise + (Storage_interface.Storage_error + (Backend_error + ( Api_errors.sr_operation_not_supported + , [Ref.string_of sr] + ) + ) + ) + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | e -> + let e' = ExnHelper.string_of_exn e in + error "SR.create failed SR:%s error:%s" (Ref.string_of sr) e' ; + raise e + ) ; + List.filter (fun (x, _) -> x <> "SRmaster") device_config + ) + + let set_name_label _context ~dbg ~sr ~new_name_label = + Server_helpers.exec_with_new_task "SR.set_name_label" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let sr = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr) + in + Db.SR.set_name_label ~__context ~self:sr ~value:new_name_label + ) + + let set_name_description _context ~dbg ~sr ~new_name_description = + Server_helpers.exec_with_new_task "SR.set_name_description" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let sr = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr) + in + Db.SR.set_name_description ~__context ~self:sr + ~value:new_name_description + ) + + let attach _context ~dbg ~sr ~device_config = + Server_helpers.exec_with_new_task "SR.attach" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let sr = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr) + in + (* Existing backends expect an SRMaster flag to be added + through the device-config. *) + let srmaster = Helpers.i_am_srmaster ~__context ~sr in + let device_config = Sm.sm_master srmaster :: device_config in + Sm.call_sm_functions ~__context ~sR:sr (fun _ _type -> + try + Sm.sr_attach + (Some (Context.get_task_id __context), device_config) + _type sr + with + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | e -> + let e' = ExnHelper.string_of_exn e in + error "SR.attach failed SR:%s error:%s" (Ref.string_of sr) e' ; + raise e + ) + ) + + let detach _context ~dbg ~sr = + Server_helpers.exec_with_new_task "SR.detach" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let sr = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr) + in + Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> + try Sm.sr_detach device_config _type sr with + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | e -> + let e' = ExnHelper.string_of_exn e in + error "SR.detach failed SR:%s error:%s" (Ref.string_of sr) e' ; + raise e + ) + ) + + let reset _context ~dbg:_ ~sr:_ = assert false + + let destroy _context ~dbg ~sr = + Server_helpers.exec_with_new_task "SR.destroy" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let sr = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr) + in + Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> + try Sm.sr_delete device_config _type sr with + | Smint.Not_implemented_in_backend -> + raise + (Storage_interface.Storage_error + (Backend_error + ( Api_errors.sr_operation_not_supported + , [Ref.string_of sr] + ) + ) + ) + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | e -> + let e' = ExnHelper.string_of_exn e in + error "SR.detach failed SR:%s error:%s" (Ref.string_of sr) e' ; + raise e + ) + ) + + let stat _context ~dbg ~sr:sr' = + Server_helpers.exec_with_new_task "SR.stat" ~subtask_of:(Ref.of_string dbg) + (fun __context -> + let sr = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr') + in + Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> + try + Sm.sr_update device_config _type sr ; + let r = Db.SR.get_record ~__context ~self:sr in + let sr_uuid = Some r.API.sR_uuid in + let name_label = r.API.sR_name_label in + let name_description = r.API.sR_name_description in + let total_space = r.API.sR_physical_size in + let free_space = + Int64.sub r.API.sR_physical_size r.API.sR_physical_utilisation + in + let clustered = false in + let health = Storage_interface.Healthy in + { + sr_uuid + ; name_label + ; name_description + ; total_space + ; free_space + ; clustered + ; health + } + with + | Smint.Not_implemented_in_backend -> + raise + (Storage_interface.Storage_error + (Backend_error + ( Api_errors.sr_operation_not_supported + , [Ref.string_of sr] + ) + ) + ) + | Api_errors.Server_error (code, params) -> + error "SR.scan failed SR:%s code=%s params=[%s]" + (Ref.string_of sr) code + (String.concat "; " params) ; + raise (Storage_error (Backend_error (code, params))) + | Sm.MasterOnly -> + redirect sr + | e -> + let e' = ExnHelper.string_of_exn e in + error "SR.scan failed SR:%s error:%s" (Ref.string_of sr) e' ; + raise e + ) + ) + + let scan _context ~dbg ~sr:sr' = + Server_helpers.exec_with_new_task "SR.scan" ~subtask_of:(Ref.of_string dbg) + (fun __context -> + let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr') in + Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> + try + Sm.sr_scan device_config _type sr ; + let open Db_filter_types in + let vdis = + Db.VDI.get_records_where ~__context + ~expr:(Eq (Field "SR", Literal (Ref.string_of sr))) + |> List.map snd + in + List.map (vdi_info_of_vdi_rec __context) vdis + with + | Smint.Not_implemented_in_backend -> + raise + (Storage_interface.Storage_error + (Backend_error + ( Api_errors.sr_operation_not_supported + , [Ref.string_of sr] + ) + ) + ) + | Api_errors.Server_error (code, params) -> + error "SR.scan failed SR:%s code=%s params=[%s]" + (Ref.string_of sr) code + (String.concat "; " params) ; + raise (Storage_error (Backend_error (code, params))) + | Sm.MasterOnly -> + redirect sr + | e -> + let e' = ExnHelper.string_of_exn e in + error "SR.scan failed SR:%s error:%s" (Ref.string_of sr) e' ; + raise e + ) + ) + + let list _context ~dbg:_ = assert false + + let update_snapshot_info_src _context ~dbg:_ ~sr:_ ~vdi:_ ~url:_ ~dest:_ + ~dest_vdi:_ ~snapshot_pairs:_ = + assert false + + let update_snapshot_info_dest _context ~dbg ~sr ~vdi ~src_vdi:_ + ~snapshot_pairs = + Server_helpers.exec_with_new_task "SR.update_snapshot_info_dest" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let local_vdis = scan __context ~dbg ~sr in + let find_sm_vdi ~vdi ~vdi_info_list = + try List.find (fun x -> x.vdi = vdi) vdi_info_list + with Not_found -> + raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) + in + let assert_content_ids_match ~vdi_info1 ~vdi_info2 = + if vdi_info1.content_id <> vdi_info2.content_id then + raise + (Storage_error + (Content_ids_do_not_match + (s_of_vdi vdi_info1.vdi, s_of_vdi vdi_info2.vdi) + ) + ) + in + (* For each (local snapshot vdi, source snapshot vdi) pair: + * - Check that the content_ids are the same + * - Copy snapshot_time from the source VDI to the local VDI + * - Set the local VDI's snapshot_of to vdi + * - Set is_a_snapshot = true for the local snapshot *) + List.iter + (fun (local_snapshot, src_snapshot_info) -> + let local_snapshot_info = + find_sm_vdi ~vdi:local_snapshot ~vdi_info_list:local_vdis + in + assert_content_ids_match ~vdi_info1:local_snapshot_info + ~vdi_info2:src_snapshot_info ; + set_snapshot_time __context ~dbg ~sr ~vdi:local_snapshot + ~snapshot_time:src_snapshot_info.snapshot_time ; + set_snapshot_of __context ~dbg ~sr ~vdi:local_snapshot + ~snapshot_of:vdi ; + set_is_a_snapshot __context ~dbg ~sr ~vdi:local_snapshot + ~is_a_snapshot:true + ) + snapshot_pairs + ) + end + + module VDI = struct + let for_vdi ~dbg ~sr ~vdi op_name f = + Server_helpers.exec_with_new_task op_name ~subtask_of:(Ref.of_string dbg) + (fun __context -> + let self = find_vdi ~__context sr vdi |> fst in + Sm.call_sm_vdi_functions ~__context ~vdi:self + (fun device_config _type sr -> f device_config _type sr self + ) + ) + + let per_host_key ~__context ~prefix = + let host_uuid = + Db.Host.get_uuid ~__context ~self:(Helpers.get_localhost ~__context) + in + Printf.sprintf "%s-%s" prefix host_uuid + + let read_caching_key ~__context = + per_host_key ~__context ~prefix:"read-caching-enabled-on" + + let read_caching_reason_key ~__context = + per_host_key ~__context ~prefix:"read-caching-reason" + + let epoch_begin _context ~dbg ~sr ~vdi ~vm:_ ~persistent:_ = + try + for_vdi ~dbg ~sr ~vdi "VDI.epoch_begin" + (fun device_config _type sr self -> + Sm.vdi_epoch_begin device_config _type sr self + ) + with Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + + let attach2 _context ~dbg ~dp:_ ~sr ~vdi ~read_write = + try + let backend = + for_vdi ~dbg ~sr ~vdi "VDI.attach2" + (fun device_config _type sr self -> + let attach_info_v1 = + Sm.vdi_attach device_config _type sr self read_write + in + (* Record whether the VDI is benefiting from read caching *) + Server_helpers.exec_with_new_task "VDI.attach2" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let read_caching = not attach_info_v1.Smint.o_direct in + let on_key = read_caching_key ~__context in + let reason_key = read_caching_reason_key ~__context in + with_lock vdi_read_caching_m (fun () -> + Db.VDI.remove_from_sm_config ~__context ~self ~key:on_key ; + Db.VDI.remove_from_sm_config ~__context ~self + ~key:reason_key ; + Db.VDI.add_to_sm_config ~__context ~self ~key:on_key + ~value:(string_of_bool read_caching) ; + if not read_caching then + Db.VDI.add_to_sm_config ~__context ~self ~key:reason_key + ~value:attach_info_v1.Smint.o_direct_reason + ) + ) ; + { + implementations= + [ + XenDisk + { + params= attach_info_v1.Smint.params + ; extra= attach_info_v1.Smint.xenstore_data + ; backend_type= "vbd3" + } + ; (* Currently we always get a BlockDevice from SMAPIv1, never a File, not even for ISOs *) + BlockDevice {path= attach_info_v1.Smint.params} + ] + } + ) + in + with_lock vdi_read_write_m (fun () -> + Hashtbl.replace vdi_read_write (sr, vdi) read_write + ) ; + backend + with Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + + let attach3 context ~dbg ~dp ~sr ~vdi ~vm:_ ~read_write = + (*Throw away vm argument as does nothing in SMAPIv1*) + attach2 context ~dbg ~dp ~sr ~vdi ~read_write + + let attach _ = + failwith + "We'll never get here: attach is implemented in \ + Storage_smapiv1_wrapper.Wrapper" + + let activate _context ~dbg ~dp ~sr ~vdi = + try + let read_write = + with_lock vdi_read_write_m (fun () -> + if not (Hashtbl.mem vdi_read_write (sr, vdi)) then + error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" + (s_of_sr sr) (s_of_vdi vdi) ; + Hashtbl.find vdi_read_write (sr, vdi) + ) + in + for_vdi ~dbg ~sr ~vdi "VDI.activate" (fun device_config _type sr self -> + Server_helpers.exec_with_new_task "VDI.activate" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + if read_write then + Db.VDI.remove_from_other_config ~__context ~self + ~key:"content_id" + ) ; + (* If the backend doesn't advertise the capability then do nothing *) + if List.mem_assoc Smint.Vdi_activate (Sm.features_of_driver _type) + then + Sm.vdi_activate device_config _type sr self read_write + else + info "%s sr:%s does not support vdi_activate: doing nothing" dp + (Ref.string_of sr) + ) + with Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + + let activate3 context ~dbg ~dp ~sr ~vdi ~vm:_ = + activate context ~dbg ~dp ~sr ~vdi + + let deactivate _context ~dbg ~dp ~sr ~vdi ~vm:_ = + try + for_vdi ~dbg ~sr ~vdi "VDI.deactivate" + (fun device_config _type sr self -> + Server_helpers.exec_with_new_task "VDI.deactivate" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let other_config = Db.VDI.get_other_config ~__context ~self in + if not (List.mem_assoc "content_id" other_config) then + Db.VDI.add_to_other_config ~__context ~self ~key:"content_id" + ~value:Uuidx.(to_string (make ())) + ) ; + (* If the backend doesn't advertise the capability then do nothing *) + if List.mem_assoc Smint.Vdi_deactivate (Sm.features_of_driver _type) + then + Sm.vdi_deactivate device_config _type sr self + else + info "%s sr:%s does not support vdi_deactivate: doing nothing" dp + (Ref.string_of sr) + ) + with Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + + let detach _context ~dbg ~dp:_ ~sr ~vdi ~vm:_ = + try + for_vdi ~dbg ~sr ~vdi "VDI.detach" (fun device_config _type sr self -> + Sm.vdi_detach device_config _type sr self ; + Server_helpers.exec_with_new_task "VDI.detach" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let on_key = read_caching_key ~__context in + let reason_key = read_caching_reason_key ~__context in + with_lock vdi_read_caching_m (fun () -> + Db.VDI.remove_from_sm_config ~__context ~self ~key:on_key ; + Db.VDI.remove_from_sm_config ~__context ~self + ~key:reason_key + ) + ) + ) ; + with_lock vdi_read_write_m (fun () -> + Hashtbl.remove vdi_read_write (sr, vdi) + ) + with Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + + let epoch_end _context ~dbg ~sr ~vdi ~vm:_ = + try + for_vdi ~dbg ~sr ~vdi "VDI.epoch_end" + (fun device_config _type sr self -> + Sm.vdi_epoch_end device_config _type sr self + ) + with Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + + let require_uuid vdi_info = + match vdi_info.Smint.vdi_info_uuid with + | Some uuid -> + uuid + | None -> + failwith "SM backend failed to return field" + + let newvdi ~__context vi = + (* The current backends stash data directly in the db *) + let uuid = require_uuid vi in + vdi_info_from_db ~__context (Db.VDI.get_by_uuid ~__context ~uuid) + + let create _context ~dbg ~sr ~vdi_info = + try + Server_helpers.exec_with_new_task "VDI.create" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in + let vi = + Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type -> + Sm.vdi_create device_config _type sr vdi_info.sm_config + vdi_info.ty vdi_info.virtual_size vdi_info.name_label + vdi_info.name_description vdi_info.metadata_of_pool + vdi_info.is_a_snapshot vdi_info.snapshot_time + (s_of_vdi vdi_info.snapshot_of) + vdi_info.read_only + ) + in + newvdi ~__context vi + ) + with + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | Sm.MasterOnly -> + redirect sr + + (* A list of keys in sm-config that will be preserved on clone/snapshot *) + let sm_config_keys_to_preserve_on_clone = ["base_mirror"] + + let snapshot_and_clone call_name call_f is_a_snapshot _context ~dbg ~sr + ~vdi_info = + try + Server_helpers.exec_with_new_task call_name + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vi = + for_vdi ~dbg ~sr ~vdi:vdi_info.vdi call_name + (fun device_config _type sr self -> + call_f device_config _type vdi_info.sm_config sr self + ) + in + (* PR-1255: modify clone, snapshot to take the same parameters as create? *) + let self, _ = + find_vdi ~__context sr + (Storage_interface.Vdi.of_string vi.Smint.vdi_info_location) + in + let clonee, _ = find_vdi ~__context sr vdi_info.vdi in + let content_id = + try + List.assoc "content_id" + (Db.VDI.get_other_config ~__context ~self:clonee) + with _ -> Uuidx.(to_string (make ())) + in + let snapshot_time = Date.of_float (Unix.gettimeofday ()) in + Db.VDI.set_name_label ~__context ~self ~value:vdi_info.name_label ; + Db.VDI.set_name_description ~__context ~self + ~value:vdi_info.name_description ; + Db.VDI.set_snapshot_time ~__context ~self ~value:snapshot_time ; + Db.VDI.set_is_a_snapshot ~__context ~self ~value:is_a_snapshot ; + Db.VDI.remove_from_other_config ~__context ~self ~key:"content_id" ; + Db.VDI.add_to_other_config ~__context ~self ~key:"content_id" + ~value:content_id ; + debug "copying sm-config" ; + List.iter + (fun (key, value) -> + let preserve = + List.mem key sm_config_keys_to_preserve_on_clone + in + if preserve then ( + Db.VDI.remove_from_sm_config ~__context ~self ~key ; + Db.VDI.add_to_sm_config ~__context ~self ~key ~value + ) + ) + vdi_info.sm_config ; + for_vdi ~dbg ~sr + ~vdi:(Storage_interface.Vdi.of_string vi.Smint.vdi_info_location) + "VDI.update" (fun device_config _type sr self -> + Sm.vdi_update device_config _type sr self + ) ; + let vdi = vdi_info_from_db ~__context self in + debug "vdi = %s" (string_of_vdi_info vdi) ; + vdi + ) + with + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | Smint.Not_implemented_in_backend -> + raise (Storage_error (Unimplemented call_name)) + | Sm.MasterOnly -> + redirect sr + + let snapshot = snapshot_and_clone "VDI.snapshot" Sm.vdi_snapshot true + + let clone = snapshot_and_clone "VDI.clone" Sm.vdi_clone false + + let set_name_label _context ~dbg ~sr ~vdi ~new_name_label = + Server_helpers.exec_with_new_task "VDI.set_name_label" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let self, _ = find_vdi ~__context sr vdi in + Db.VDI.set_name_label ~__context ~self ~value:new_name_label + ) + + let set_name_description _context ~dbg ~sr ~vdi ~new_name_description = + Server_helpers.exec_with_new_task "VDI.set_name_description" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let self, _ = find_vdi ~__context sr vdi in + Db.VDI.set_name_description ~__context ~self + ~value:new_name_description + ) + + let resize _context ~dbg ~sr ~vdi ~new_size = + try + let vi = + for_vdi ~dbg ~sr ~vdi "VDI.resize" (fun device_config _type sr self -> + Sm.vdi_resize device_config _type sr self new_size + ) + in + Server_helpers.exec_with_new_task "VDI.resize" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let self, _ = + find_vdi ~__context sr + (Storage_interface.Vdi.of_string vi.Smint.vdi_info_location) + in + Db.VDI.get_virtual_size ~__context ~self + ) + with + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | Smint.Not_implemented_in_backend -> + raise (Storage_error (Unimplemented "VDI.resize")) + | Sm.MasterOnly -> + redirect sr + + let destroy _context ~dbg ~sr ~vdi = + try + for_vdi ~dbg ~sr ~vdi "VDI.destroy" (fun device_config _type sr self -> + Sm.vdi_delete device_config _type sr self + ) ; + with_lock vdi_read_write_m (fun () -> + Hashtbl.remove vdi_read_write (sr, vdi) + ) + with + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | No_VDI -> + raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) + | Sm.MasterOnly -> + redirect sr + + let stat _context ~dbg ~sr ~vdi = + try + Server_helpers.exec_with_new_task "VDI.stat" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + for_vdi ~dbg ~sr ~vdi "VDI.stat" (fun device_config _type sr self -> + Sm.vdi_update device_config _type sr self ; + vdi_info_of_vdi_rec __context + (Db.VDI.get_record ~__context ~self) + ) + ) + with e -> + error "VDI.stat caught: %s" (Printexc.to_string e) ; + raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi))) + + let introduce _context ~dbg ~sr ~uuid ~sm_config ~location = + try + Server_helpers.exec_with_new_task "VDI.introduce" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in + let vi = + Sm.call_sm_functions ~__context ~sR:sr + (fun device_config sr_type -> + Sm.vdi_introduce device_config sr_type sr uuid sm_config + location + ) + in + newvdi ~__context vi + ) + with e -> + error "VDI.introduce caught: %s" (Printexc.to_string e) ; + raise (Storage_error (Vdi_does_not_exist location)) + + let set_persistent _context ~dbg ~sr ~vdi ~persistent = + try + Server_helpers.exec_with_new_task "VDI.set_persistent" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + if not persistent then ( + info + "VDI.set_persistent: calling VDI.clone and VDI.destroy to make \ + an empty vhd-leaf" ; + let new_vdi = + for_vdi ~dbg ~sr ~vdi "VDI.clone" + (fun device_config _type sr self -> + let vi = Sm.vdi_clone device_config _type [] sr self in + Storage_interface.Vdi.of_string vi.Smint.vdi_info_location + ) + in + for_vdi ~dbg ~sr ~vdi:new_vdi "VDI.destroy" + (fun device_config _type sr self -> + Sm.vdi_delete device_config _type sr self + ) + ) + ) + with + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | Sm.MasterOnly -> + redirect sr + + let get_by_name _context ~dbg ~sr ~name = + info "VDI.get_by_name dbg:%s sr:%s name:%s" dbg (s_of_sr sr) name ; + (* PR-1255: the backend should do this for us *) + Server_helpers.exec_with_new_task "VDI.get_by_name" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + (* PR-1255: the backend should do this for us *) + try + let _, vdi = find_content ~__context ~sr name in + let vi = vdi_info_of_vdi_rec __context vdi in + debug "VDI.get_by_name returning successfully" ; + vi + with e -> + error "VDI.get_by_name caught: %s" (Printexc.to_string e) ; + raise (Storage_error (Vdi_does_not_exist name)) + ) + + let set_content_id _context ~dbg ~sr ~vdi ~content_id = + info "VDI.get_by_content dbg:%s sr:%s vdi:%s content_id:%s" dbg + (s_of_sr sr) (s_of_vdi vdi) content_id ; + (* PR-1255: the backend should do this for us *) + Server_helpers.exec_with_new_task "VDI.set_content_id" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi, _ = find_vdi ~__context sr vdi in + Db.VDI.remove_from_other_config ~__context ~self:vdi ~key:"content_id" ; + Db.VDI.add_to_other_config ~__context ~self:vdi ~key:"content_id" + ~value:content_id + ) + + let similar_content _context ~dbg ~sr ~vdi = + info "VDI.similar_content dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) + (s_of_vdi vdi) ; + Server_helpers.exec_with_new_task "VDI.similar_content" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + (* PR-1255: the backend should do this for us. *) + let sr_ref = + Db.SR.get_by_uuid ~__context + ~uuid:(Storage_interface.Sr.string_of sr) + in + (* Return a nearest-first list of similar VDIs. "near" should mean + "has similar blocks" but we approximate this with distance in the tree *) + let module StringMap = Map.Make (struct + type t = string + + let compare = compare + end) in + let _vhdparent = "vhd-parent" in + let open Db_filter_types in + let all = + Db.VDI.get_records_where ~__context + ~expr:(Eq (Field "SR", Literal (Ref.string_of sr_ref))) + in + let locations = + List.fold_left + (fun acc (_, vdi_rec) -> + StringMap.add vdi_rec.API.vDI_location vdi_rec acc + ) + StringMap.empty all + in + (* Compute a map of parent location -> children locations *) + let children, parents = + List.fold_left + (fun (children, parents) (_, vdi_rec) -> + if List.mem_assoc _vhdparent vdi_rec.API.vDI_sm_config then + let me = vdi_rec.API.vDI_location in + let parent = + List.assoc _vhdparent vdi_rec.API.vDI_sm_config + in + let other_children = + if StringMap.mem parent children then + StringMap.find parent children + else + [] + in + ( StringMap.add parent (me :: other_children) children + , StringMap.add me parent parents + ) + else + (children, parents) + ) + (StringMap.empty, StringMap.empty) + all + in + let rec explore current_distance acc vdi = + (* add me *) + let acc = StringMap.add vdi current_distance acc in + (* add the parent *) + let parent = + if StringMap.mem vdi parents then + [StringMap.find vdi parents] + else + [] + in + let children = + if StringMap.mem vdi children then + StringMap.find vdi children + else + [] + in + List.fold_left + (fun acc vdi -> + if not (StringMap.mem vdi acc) then + explore (current_distance + 1) acc vdi + else + acc + ) + acc (parent @ children) + in + let module IntMap = Map.Make (struct + type t = int + + let compare = compare + end) in + let invert map = + StringMap.fold + (fun vdi n acc -> + let current = + if IntMap.mem n acc then IntMap.find n acc else [] + in + IntMap.add n (vdi :: current) acc + ) + map IntMap.empty + in + let _, vdi_rec = find_vdi ~__context sr vdi in + let vdis = + explore 0 StringMap.empty vdi_rec.API.vDI_location + |> invert + |> IntMap.bindings + |> List.map snd + |> List.concat + in + let vdi_recs = List.map (fun l -> StringMap.find l locations) vdis in + (* We drop cbt_metadata VDIs that do not have any actual data *) + let vdi_recs = + List.filter (fun r -> r.API.vDI_type <> `cbt_metadata) vdi_recs + in + List.map (fun x -> vdi_info_of_vdi_rec __context x) vdi_recs + ) + + let compose _context ~dbg ~sr ~vdi1 ~vdi2 = + info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" dbg (s_of_sr sr) + (s_of_vdi vdi1) (s_of_vdi vdi2) ; + try + Server_helpers.exec_with_new_task "VDI.compose" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + (* This call 'operates' on vdi2 *) + let vdi1 = find_vdi ~__context sr vdi1 |> fst in + for_vdi ~dbg ~sr ~vdi:vdi2 "VDI.compose" + (fun device_config _type sr self -> + Sm.vdi_compose device_config _type sr vdi1 self + ) + ) + with + | Smint.Not_implemented_in_backend -> + raise (Storage_error (Unimplemented "VDI.compose")) + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | No_VDI -> + raise + (Storage_error + (Vdi_does_not_exist (Storage_interface.Vdi.string_of vdi1)) + ) + | Sm.MasterOnly -> + redirect sr + + let add_to_sm_config _context ~dbg ~sr ~vdi ~key ~value = + info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" dbg + (s_of_sr sr) (s_of_vdi vdi) key value ; + Server_helpers.exec_with_new_task "VDI.add_to_sm_config" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let self = find_vdi ~__context sr vdi |> fst in + Db.VDI.add_to_sm_config ~__context ~self ~key ~value + ) + + let remove_from_sm_config _context ~dbg ~sr ~vdi ~key = + info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" dbg + (s_of_sr sr) (s_of_vdi vdi) key ; + Server_helpers.exec_with_new_task "VDI.remove_from_sm_config" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let self = find_vdi ~__context sr vdi |> fst in + Db.VDI.remove_from_sm_config ~__context ~self ~key + ) + + let get_url _context ~dbg ~sr ~vdi = + info "VDI.get_url dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ; + (* XXX: PR-1255: tapdisk shouldn't hardcode xapi urls *) + (* peer_ip/session_ref/vdi_ref *) + Server_helpers.exec_with_new_task "VDI.get_url" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let ip = Helpers.get_management_ip_addr ~__context |> Option.get in + let rpc = Helpers.make_rpc ~__context in + let localhost = Helpers.get_localhost ~__context in + (* XXX: leaked *) + let session_ref = + XenAPI.Session.slave_login ~rpc ~host:localhost + ~psecret:(Xapi_globs.pool_secret ()) + in + let vdi, _ = find_vdi ~__context sr vdi in + Printf.sprintf "%s/%s/%s" ip + (Ref.string_of session_ref) + (Ref.string_of vdi) + ) + + let call_cbt_function _context ~f ~f_name ~dbg ~sr ~vdi = + try + for_vdi ~dbg ~sr ~vdi f_name (fun device_config _type sr self -> + f device_config _type sr self + ) + with + | Smint.Not_implemented_in_backend -> + raise (Storage_error (Unimplemented f_name)) + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | No_VDI -> + raise + (Storage_error + (Vdi_does_not_exist (Storage_interface.Vdi.string_of vdi)) + ) + | Sm.MasterOnly -> + redirect sr + + let enable_cbt context = + call_cbt_function context ~f:Sm.vdi_enable_cbt ~f_name:"VDI.enable_cbt" + + let disable_cbt context = + call_cbt_function context ~f:Sm.vdi_disable_cbt ~f_name:"VDI.disable_cbt" + + let data_destroy context ~dbg ~sr ~vdi = + call_cbt_function context ~f:Sm.vdi_data_destroy + ~f_name:"VDI.data_destroy" ~dbg ~sr ~vdi ; + set_content_id context ~dbg ~sr ~vdi + ~content_id:"/No content: this is a cbt_metadata VDI/" + + let list_changed_blocks _context ~dbg ~sr ~vdi_from ~vdi_to = + try + Server_helpers.exec_with_new_task "VDI.list_changed_blocks" + ~subtask_of:(Ref.of_string dbg) (fun __context -> + let vdi_from = find_vdi ~__context sr vdi_from |> fst in + for_vdi ~dbg ~sr ~vdi:vdi_to "VDI.list_changed_blocks" + (fun device_config _type sr vdi_to -> + Sm.vdi_list_changed_blocks device_config _type sr ~vdi_from + ~vdi_to + ) + ) + with + | Smint.Not_implemented_in_backend -> + raise (Storage_error (Unimplemented "VDI.list_changed_blocks")) + | Api_errors.Server_error (code, params) -> + raise (Storage_error (Backend_error (code, params))) + | Sm.MasterOnly -> + redirect sr + end + + let get_by_name _context ~dbg:_ ~name:_ = assert false + + module DATA = struct + let copy_into _context ~dbg:_ ~sr:_ ~vdi:_ ~url:_ ~dest:_ ~dest_vdi:_ + ~verify_dest:_ = + assert false + + let copy _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ ~url:_ ~dest:_ ~verify_dest:_ = + assert false + + module MIRROR = struct + let start _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ ~url:_ ~dest:_ ~verify_dest:_ + = + assert false + + let stop _context ~dbg:_ ~id:_ = assert false + + let list _context ~dbg:_ = assert false + + let stat _context ~dbg:_ ~id:_ = assert false + + let receive_start _context ~dbg:_ ~sr:_ ~vdi_info:_ ~id:_ ~similar:_ = + assert false + + let receive_finalize _context ~dbg:_ ~id:_ = assert false + + let receive_cancel _context ~dbg:_ ~id:_ = assert false + end + end + + module Policy = struct + let get_backend_vm _context ~dbg:_ ~vm:_ ~sr:_ ~vdi:_ = assert false + end + + module TASK = struct + let stat _context ~dbg:_ ~task:_ = assert false + + let destroy _context ~dbg:_ ~task:_ = assert false + + let cancel _context ~dbg:_ ~task:_ = assert false + + let list _context ~dbg:_ = assert false + end + + module UPDATES = struct + let get _context ~dbg:_ ~from:_ ~timeout:_ = assert false + end +end diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 29063bc9ea4..6d0094ce3cd 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -1321,3 +1321,7 @@ let initialise () = ) else info "No storage state is persisted in %s; creating blank database" !host_state_path + +module Impl = Wrapper (Storage_smapiv1.SMAPIv1) + +module Server = Storage_interface.Server (Impl) () diff --git a/ocaml/xapi/xapi_services.ml b/ocaml/xapi/xapi_services.ml index 2841a020615..b88638739bc 100644 --- a/ocaml/xapi/xapi_services.ml +++ b/ocaml/xapi/xapi_services.ml @@ -196,7 +196,7 @@ let put_handler (req : Http.Request.t) s _ = http_proxy_to_plugin req s name | [""; services; "SM"; "data"; sr; vdi] when services = _services -> let vdi, _ = - Storage_access.find_vdi ~__context + Storage_smapiv1.find_vdi ~__context (Storage_interface.Sr.of_string sr) (Storage_interface.Vdi.of_string vdi) in diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index a2c307d39b2..668e83b3da3 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -804,7 +804,7 @@ let snapshot_and_clone call_f ~__context ~vdi ~driver_params = let open Storage_interface in let vdi_info = { - (Storage_access.vdi_info_of_vdi_rec __context vdi_rec) with + (Storage_smapiv1.vdi_info_of_vdi_rec __context vdi_rec) with sm_config= driver_params } in From a5c2e023f1e41bcfaf079f5aeedb2528eb1996c5 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 10 Jan 2023 16:20:05 +0000 Subject: [PATCH 07/11] Redirect TASK and UPDATES straight to SMAPIv1 Similarly, DP.diagnostics, DP.attach_info and DP.stat_vdi are redirected straight to SMAPIv1. We could consider later if some of this would still be useful for SMAPIv3 for diagnostic purposes, in some form. Signed-off-by: Rob Hoes --- ocaml/xapi/storage_mux.ml | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 440124862aa..ccc59deaf4d 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -199,8 +199,6 @@ module Mux = struct end module DP = struct - include Storage_skeleton.DP - let create _context ~dbg:_ ~id = id let destroy _context ~dbg ~dp ~allow_leak = @@ -214,6 +212,12 @@ module Mux = struct end)) in C.DP.destroy dbg dp allow_leak ; DP_info.delete dp + + let diagnostics () = Storage_smapiv1_wrapper.Impl.DP.diagnostics () + + let attach_info () = Storage_smapiv1_wrapper.Impl.DP.attach_info () + + let stat_vdi () = Storage_smapiv1_wrapper.Impl.DP.stat_vdi () end module SR = struct @@ -718,19 +722,8 @@ module Mux = struct (Hashtbl.find plugins sr).backend_domain end - module TASK = struct - let stat () ~dbg:_ ~task:_ = assert false - - let cancel () ~dbg:_ ~task:_ = assert false - - let destroy () ~dbg:_ ~task:_ = assert false - - let list () ~dbg:_ = assert false - end - - module UPDATES = struct - let get () ~dbg:_ ~from:_ ~timeout:_ = assert false - end + module TASK = Storage_smapiv1_wrapper.Impl.TASK + module UPDATES = Storage_smapiv1_wrapper.Impl.UPDATES end module Server = Storage_interface.Server (Mux) () From e3f6c7d9e595dc9ea0fb4a265ce282f5d0c11069 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 7 Dec 2022 14:15:28 +0000 Subject: [PATCH 08/11] Introduce DP.destroy2 This is a function that serves the same purpose as DP.destroy, but takes additional SR, VDI and VM arguments besides the DP argument. This makes it possible to implement it inside the SMAPIv3 backend, which otherwise has no awareness of the concept of "datapaths" as used by xapi. The Mux keeps a mapping from datapath to SR+VDI+VM. This is used to transform DP.destroy calls into DP.destroy2 calls, which are sent to the backend. Signed-off-by: Rob Hoes --- ocaml/xapi-idl/storage/storage_interface.ml | 35 +++++++++++++++++++-- ocaml/xapi-idl/storage/storage_skeleton.ml | 2 ++ ocaml/xapi-storage-script/main.ml | 24 ++++++++++++++ ocaml/xapi/storage_mux.ml | 23 +++++++++----- ocaml/xapi/storage_smapiv1.ml | 12 +------ ocaml/xapi/storage_smapiv1_wrapper.ml | 12 +++++-- 6 files changed, 86 insertions(+), 22 deletions(-) diff --git a/ocaml/xapi-idl/storage/storage_interface.ml b/ocaml/xapi-idl/storage/storage_interface.ml index 4f03c28f6ec..c69a265c273 100644 --- a/ocaml/xapi-idl/storage/storage_interface.ml +++ b/ocaml/xapi-idl/storage/storage_interface.ml @@ -528,13 +528,31 @@ module StorageAPI (R : RPC) = struct let allow_leak_p = Param.mk ~name:"allow_leak" Types.bool in declare "DP.destroy" [ - "[DP.destroy dbg id]: frees any resources associated with [id] and \ - destroys it." + "[DP.destroy dbg id allow_leak]: frees any resources associated with \ + [id] and destroys it." ; "This will typically do any needed VDI.detach, VDI.deactivate \ cleanup." ] (dbg_p @-> dp_p @-> allow_leak_p @-> returning unit_p err) + let destroy2 = + let allow_leak_p = Param.mk ~name:"allow_leak" Types.bool in + declare "DP.destroy2" + [ + "[DP.destroy2 dbg id sr vdi vm allow_leak]: frees any resources \ + associated with [id] and destroys it." + ; "This will typically do any needed VDI.detach, VDI.deactivate \ + cleanup." + ] + (dbg_p + @-> dp_p + @-> sr_p + @-> vdi_p + @-> vm_p + @-> allow_leak_p + @-> returning unit_p err + ) + let attach_info = let backend_p = Param.mk ~name:"backend" backend in declare "DP.attach_info" @@ -1118,6 +1136,16 @@ module type Server_impl = sig val destroy : context -> dbg:debug_info -> dp:dp -> allow_leak:bool -> unit + val destroy2 : + context + -> dbg:debug_info + -> dp:dp + -> sr:sr + -> vdi:vdi + -> vm:vm + -> allow_leak:bool + -> unit + val attach_info : context -> dbg:debug_info -> sr:sr -> vdi:vdi -> dp:dp -> backend @@ -1424,6 +1452,9 @@ module Server (Impl : Server_impl) () = struct S.DP.destroy (fun dbg dp allow_leak -> Impl.DP.destroy () ~dbg ~dp ~allow_leak ) ; + S.DP.destroy2 (fun dbg dp sr vdi vm allow_leak -> + Impl.DP.destroy2 () ~dbg ~dp ~sr ~vdi ~vm ~allow_leak + ) ; S.DP.attach_info (fun dbg sr vdi dp -> Impl.DP.attach_info () ~dbg ~sr ~vdi ~dp ) ; diff --git a/ocaml/xapi-idl/storage/storage_skeleton.ml b/ocaml/xapi-idl/storage/storage_skeleton.ml index 5e93071e130..0ded2c112b8 100644 --- a/ocaml/xapi-idl/storage/storage_skeleton.ml +++ b/ocaml/xapi-idl/storage/storage_skeleton.ml @@ -37,6 +37,8 @@ module DP = struct let destroy ctx ~dbg ~dp ~allow_leak = u "DP.destroy" + let destroy2 ctx ~dbg ~dp ~sr ~vdi ~vm ~allow_leak = u "DP.destroy2" + let attach_info ctx ~dbg ~sr ~vdi ~dp = u "DP.attach_info" let diagnostics ctx () = u "DP.diagnostics" diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 5851006be5c..247c43da401 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1461,6 +1461,30 @@ let bind ~volume_script_dir = Deferred.Result.return () |> wrap in S.VDI.set_persistent vdi_set_persistent_impl ; + let dp_destroy2 dbg _dp sr vdi' vm' _allow_leak = + (let vdi = Storage_interface.Vdi.string_of vdi' in + let domain = Storage_interface.Vm.string_of vm' in + Attached_SRs.find sr >>>= fun sr -> + (* Discover the URIs using Volume.stat *) + stat ~dbg ~sr ~vdi >>>= fun response -> + ( match + List.Assoc.find response.Xapi_storage.Control.keys _clone_on_boot_key + ~equal:String.equal + with + | None -> + return (Ok response) + | Some temporary -> + stat ~dbg ~sr ~vdi:temporary + ) + >>>= fun response -> + choose_datapath domain response >>>= fun (rpc, _datapath, uri, domain) -> + return_data_rpc (fun () -> Datapath_client.deactivate rpc dbg uri domain) + >>>= fun () -> + return_data_rpc (fun () -> Datapath_client.detach rpc dbg uri domain) + ) + |> wrap + in + S.DP.destroy2 dp_destroy2 ; let u _ = failwith "Unimplemented" in S.get_by_name u ; S.VDI.compose u ; diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index ccc59deaf4d..fbb46bc3719 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -201,18 +201,27 @@ module Mux = struct module DP = struct let create _context ~dbg:_ ~id = id - let destroy _context ~dbg ~dp ~allow_leak = - info "DP.destroy dbg:%s dp:%s allow_leak:%b" dbg dp allow_leak ; - let sr : Sr.t = - let open DP_info in - match read dp with Some x -> x.sr | None -> failwith "DP not found" - in + let destroy2 _context ~dbg ~dp ~sr ~vdi ~vm ~allow_leak = + info "DP.destroy2 dbg:%s dp:%s sr:%s vdi:%s vm:%s allow_leak:%b" dbg dp + (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) allow_leak ; let module C = StorageAPI (Idl.Exn.GenClient (struct let rpc = of_sr sr end)) in - C.DP.destroy dbg dp allow_leak ; + C.DP.destroy2 dbg dp sr vdi vm allow_leak ; DP_info.delete dp + let destroy _context ~dbg ~dp ~allow_leak = + info "DP.destroy dbg:%s dp:%s allow_leak:%b" dbg dp allow_leak ; + let sr, vdi, vm = + let open DP_info in + match read dp with + | Some x -> + (x.sr, x.vdi, x.vm) + | None -> + failwith "DP not found" + in + destroy2 _context ~dbg ~dp ~sr ~vdi ~vm ~allow_leak + let diagnostics () = Storage_smapiv1_wrapper.Impl.DP.diagnostics () let attach_info () = Storage_smapiv1_wrapper.Impl.DP.attach_info () diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index dcd0db2dda4..c4832277391 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -175,17 +175,7 @@ module SMAPIv1 : Server_impl = struct "No diagnostics are available for SMAPIv1 plugins" end - module DP = struct - let create _context ~dbg:_ ~id:_ = assert false - - let destroy _context ~dbg:_ ~dp:_ = assert false - - let diagnostics _context () = assert false - - let attach_info _context ~dbg:_ ~sr:_ ~vdi:_ ~dp:_ = assert false - - let stat_vdi _context ~dbg:_ ~sr:_ ~vdi:_ = assert false - end + module DP = Storage_skeleton.DP module SR = struct include Storage_skeleton.SR diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 6d0094ce3cd..90c1aa4e466 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -1016,8 +1016,7 @@ functor ) ; failure - let destroy context ~dbg ~dp ~allow_leak = - info "DP.destroy dbg:%s dp:%s allow_leak:%b" dbg dp allow_leak ; + let destroy' context ~dbg ~dp ~allow_leak = let failures = Host.list !Host.host |> List.filter_map (fun (sr, sr_t) -> @@ -1034,6 +1033,15 @@ functor info "Forgetting leaked datapath: dp: %s" dp ; () + let destroy _context ~dbg:_ ~dp:_ ~allow_leak:_ = + (* This is no longer called. The mux redirects it to DP.destroy2. *) + assert false + + let destroy2 context ~dbg ~dp ~sr ~vdi ~vm ~allow_leak = + info "DP.destroy2 dbg:%s dp:%s sr:%s vdi:%s vm:%s allow_leak:%b" dbg dp + (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) allow_leak ; + destroy' context ~dbg ~dp ~allow_leak + let diagnostics _context () = let srs = Host.list !Host.host in let of_sr (sr, sr_t) = From 1cc0947d0f272f8915437594dedd328d991b1019 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 6 Jan 2023 17:27:09 +0000 Subject: [PATCH 09/11] xapi-storage-script: include name with Unimplemented errors Signed-off-by: Rob Hoes --- ocaml/xapi-storage-script/main.ml | 80 +++++++++++++++---------------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 247c43da401..2b366f9c831 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1485,46 +1485,46 @@ let bind ~volume_script_dir = |> wrap in S.DP.destroy2 dp_destroy2 ; - let u _ = failwith "Unimplemented" in - S.get_by_name u ; - S.VDI.compose u ; - S.VDI.get_by_name u ; - S.DATA.MIRROR.receive_start u ; - S.SR.reset u ; - S.UPDATES.get u ; - S.SR.update_snapshot_info_dest u ; - S.VDI.data_destroy u ; - S.DATA.MIRROR.list u ; - S.TASK.stat u ; - S.VDI.remove_from_sm_config u ; - S.DP.diagnostics u ; - S.TASK.destroy u ; - S.VDI.list_changed_blocks u ; - S.DP.destroy u ; - S.VDI.add_to_sm_config u ; - S.VDI.similar_content u ; - S.DATA.copy u ; - S.DP.stat_vdi u ; - S.DATA.MIRROR.receive_finalize u ; - S.DP.create u ; - S.VDI.set_content_id u ; - S.VDI.disable_cbt u ; - S.DP.attach_info u ; - S.TASK.cancel u ; - S.SR.list u ; - S.VDI.attach u ; - S.VDI.attach2 u ; - S.VDI.activate u ; - S.DATA.MIRROR.stat u ; - S.TASK.list u ; - S.VDI.get_url u ; - S.VDI.enable_cbt u ; - S.DATA.MIRROR.start u ; - S.Policy.get_backend_vm u ; - S.DATA.copy_into u ; - S.DATA.MIRROR.receive_cancel u ; - S.SR.update_snapshot_info_src u ; - S.DATA.MIRROR.stop u ; + let u name _ = failwith ("Unimplemented: " ^ name) in + S.get_by_name (u "get_by_name") ; + S.VDI.compose (u "VDI.compose") ; + S.VDI.get_by_name (u "VDI.get_by_name") ; + S.DATA.MIRROR.receive_start (u "DATA.MIRROR.receive_start") ; + S.SR.reset (u "SR.reset") ; + S.UPDATES.get (u "UPDATES.get") ; + S.SR.update_snapshot_info_dest (u "SR.update_snapshot_info_dest") ; + S.VDI.data_destroy (u "VDI.data_destroy") ; + S.DATA.MIRROR.list (u "DATA.MIRROR.list") ; + S.TASK.stat (u "TASK.stat") ; + S.VDI.remove_from_sm_config (u "VDI.remove_from_sm_config") ; + S.DP.diagnostics (u "DP.diagnostics") ; + S.TASK.destroy (u "TASK.destroy") ; + S.VDI.list_changed_blocks (u "VDI.list_changed_blocks") ; + S.DP.destroy (u "DP.destroy") ; + S.VDI.add_to_sm_config (u "VDI.add_to_sm_config") ; + S.VDI.similar_content (u "VDI.similar_content") ; + S.DATA.copy (u "DATA.copy") ; + S.DP.stat_vdi (u "DP.stat_vdi") ; + S.DATA.MIRROR.receive_finalize (u "DATA.MIRROR.receive_finalize") ; + S.DP.create (u "DP.create") ; + S.VDI.set_content_id (u "VDI.set_content_id") ; + S.VDI.disable_cbt (u "VDI.disable_cbt") ; + S.DP.attach_info (u "DP.attach_info") ; + S.TASK.cancel (u "TASK.cancel") ; + S.SR.list (u "SR.list") ; + S.VDI.attach (u "VDI.attach") ; + S.VDI.attach2 (u "VDI.attach2") ; + S.VDI.activate (u "VDI.activate") ; + S.DATA.MIRROR.stat (u "DATA.MIRROR.stat") ; + S.TASK.list (u "TASK.list") ; + S.VDI.get_url (u "VDI.get_url") ; + S.VDI.enable_cbt (u "VDI.enable_cbt") ; + S.DATA.MIRROR.start (u "DATA.MIRROR.start") ; + S.Policy.get_backend_vm (u "Policy.get_backend_vm") ; + S.DATA.copy_into (u "DATA.copy_into") ; + S.DATA.MIRROR.receive_cancel (u "DATA.MIRROR.receive_cancel") ; + S.SR.update_snapshot_info_src (u "SR.update_snapshot_info_src") ; + S.DATA.MIRROR.stop (u "DATA.MIRROR.stop") ; Rpc_async.server S.implementation let process_smapiv2_requests server txt = From db6be8350feb55006bbcfe4f5f28ceb9821e7d07 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 4 Jan 2023 15:31:55 +0000 Subject: [PATCH 10/11] xapi-storage-script: implement SR.list and SR.reset SR.list uses the existing state in the daemon to return a list of currently attached SRs. SR.reset just returns unit rather than an error, as it is a no-op in SMAPIv3. Signed-off-by: Rob Hoes --- ocaml/xapi-storage-script/main.ml | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index 2b366f9c831..257b1327121 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -599,6 +599,14 @@ module Attached_SRs = struct Hashtbl.remove !sr_table key ; return (Ok ()) + let list () = + let srs = + Hashtbl.fold !sr_table + ~f:(fun ~key ~data:_ ac -> Storage_interface.Sr.of_string key :: ac) + ~init:[] + in + return (Ok srs) + let reload path = state_path := Some path ; Sys.is_file ~follow_symlinks:true path >>= function @@ -1485,12 +1493,17 @@ let bind ~volume_script_dir = |> wrap in S.DP.destroy2 dp_destroy2 ; + let sr_list _dbg = + Attached_SRs.list () >>>= (fun srs -> Deferred.Result.return srs) |> wrap + in + S.SR.list sr_list ; + (* SR.reset is a no op in SMAPIv3 *) + S.SR.reset (fun _ _ -> Deferred.Result.return () |> wrap) ; let u name _ = failwith ("Unimplemented: " ^ name) in S.get_by_name (u "get_by_name") ; S.VDI.compose (u "VDI.compose") ; S.VDI.get_by_name (u "VDI.get_by_name") ; S.DATA.MIRROR.receive_start (u "DATA.MIRROR.receive_start") ; - S.SR.reset (u "SR.reset") ; S.UPDATES.get (u "UPDATES.get") ; S.SR.update_snapshot_info_dest (u "SR.update_snapshot_info_dest") ; S.VDI.data_destroy (u "VDI.data_destroy") ; @@ -1511,7 +1524,6 @@ let bind ~volume_script_dir = S.VDI.disable_cbt (u "VDI.disable_cbt") ; S.DP.attach_info (u "DP.attach_info") ; S.TASK.cancel (u "TASK.cancel") ; - S.SR.list (u "SR.list") ; S.VDI.attach (u "VDI.attach") ; S.VDI.attach2 (u "VDI.attach2") ; S.VDI.activate (u "VDI.activate") ; From d57cec21c64b4080e10c86e34358009bb415a7c4 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 11 Jan 2023 16:33:17 +0000 Subject: [PATCH 11/11] Add storage_smapiv1.mli Signed-off-by: Rob Hoes --- ocaml/xapi/storage_smapiv1.mli | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 ocaml/xapi/storage_smapiv1.mli diff --git a/ocaml/xapi/storage_smapiv1.mli b/ocaml/xapi/storage_smapiv1.mli new file mode 100644 index 00000000000..69a0a22aa9f --- /dev/null +++ b/ocaml/xapi/storage_smapiv1.mli @@ -0,0 +1,26 @@ +(* + * Copyright (C) 2006-2011 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. + *) + +open Storage_interface + +val vdi_read_write_m : Mutex.t + +val vdi_read_write : (Sr.t * Vdi.t, bool) Hashtbl.t + +val vdi_info_of_vdi_rec : Context.t -> API.vDI_t -> Storage_interface.vdi_info + +val find_vdi : __context:Context.t -> Sr.t -> Vdi.t -> [`VDI] Ref.t * API.vDI_t +(** Find a VDI given a storage-layer SR and VDI *) + +module SMAPIv1 : Server_impl