CP-45016 Implement inbound SXM for SMAPIv3 SRs

ocaml/tests/test_sm_features.ml

@@ -20,7 +20,7 @@ type sm_data_sequence = {
     (* Text feature list we get back as part of sr_get_driver_info. *)
     raw: string list
   ; (* SMAPIv1 driver info. *)
-    smapiv1_features: Smint.feature list
+    smapiv1_features: Smint.Feature.t list
   ; (* SMAPIv2 driver info. *)
     smapiv2_features: string list
   ; (* SM object created in the database. *)
@@ -40,7 +40,6 @@ let string_of_sm_object sm =
     )
 
 let test_sequences =
-  let open Smint in
   [
     (* Test NFS driver features as of Clearwater. *)
     {
@@ -179,14 +178,14 @@ module ParseSMAPIv1Features = Generic.MakeStateless (struct
   module Io = struct
     type input_t = string list
 
-    type output_t = Smint.feature list
+    type output_t = Smint.Feature.t list
 
     let string_of_input_t = Test_printers.(list string)
 
-    let string_of_output_t = Test_printers.(list Smint.string_of_feature)
+    let string_of_output_t = Test_printers.(list Smint.Feature.to_string)
   end
 
-  let transform = Smint.parse_capability_int64_features
+  let transform = Smint.Feature.parse_capability_int64
 
   let tests =
     `QuickAndAutoDocumented
@@ -198,16 +197,16 @@ end)
 
 module CreateSMAPIv2Features = Generic.MakeStateless (struct
   module Io = struct
-    type input_t = Smint.feature list
+    type input_t = Smint.Feature.t list
 
     type output_t = string list
 
-    let string_of_input_t = Test_printers.(list Smint.string_of_feature)
+    let string_of_input_t = Test_printers.(list Smint.Feature.to_string)
 
     let string_of_output_t = Test_printers.(list string)
   end
 
-  let transform = List.map Smint.string_of_feature
+  let transform = List.map Smint.Feature.to_string
 
   let tests =
     `QuickAndAutoDocumented
@@ -276,9 +275,10 @@ module CompatSMFeatures = Generic.MakeStateless (struct
   end
 
   let transform l =
+    let open Smint.Feature in
     List.split l |> fun (x, y) ->
-    (Smint.parse_string_int64_features x, Smint.parse_string_int64_features y)
-    |> fun (x, y) -> Smint.compat_features x y |> List.map Smint.unparse_feature
+    (parse_string_int64 x, parse_string_int64 y) |> fun (x, y) ->
+    compat_features x y |> List.map unparse
 
   let tests =
     let r1, r2 = test_intersection_sequences in

ocaml/tests/test_storage_migrate_state.ml

@@ -44,14 +44,16 @@ let sample_send_state =
     }
 
 let sample_receive_state =
+  let open Storage_interface in
   Storage_migrate.State.Receive_state.
     {
-      sr= Storage_interface.Sr.of_string "my_sr"
-    ; dummy_vdi= Storage_interface.Vdi.of_string "dummy_vdi"
-    ; leaf_vdi= Storage_interface.Vdi.of_string "leaf_vdi"
+      sr= Sr.of_string "my_sr"
+    ; dummy_vdi= Vdi.of_string "dummy_vdi"
+    ; leaf_vdi= Vdi.of_string "leaf_vdi"
     ; leaf_dp= "leaf_dp"
-    ; parent_vdi= Storage_interface.Vdi.of_string "parent_vdi"
-    ; remote_vdi= Storage_interface.Vdi.of_string "remote_vdi"
+    ; parent_vdi= Vdi.of_string "parent_vdi"
+    ; remote_vdi= Vdi.of_string "remote_vdi"
+    ; mirror_vm= Vm.of_string "mirror_vm"
     }
 
 let sample_copy_state =

ocaml/vhd-tool/cli/dune

@@ -4,7 +4,7 @@
   (libraries
     astring
 
-    local_lib
+    vhd_lib
     cmdliner
     cstruct
     forkexec

ocaml/vhd-tool/cli/sparse_dd.ml

@@ -65,6 +65,10 @@ let sni = ref None
 
 let cert_bundle_path = ref None
 
+let dest_proto = ref None
+
+let nbd_export = ref ""
+
 let string_opt = function None -> "None" | Some x -> x
 
 let machine_readable_progress = ref false
@@ -158,6 +162,16 @@ let options =
     , (fun () -> string_opt !cert_bundle_path)
     , "path to a CA certificate bundle"
     )
+  ; ( "dest-proto"
+    , Arg.String (fun x -> dest_proto := Some x)
+    , (fun () -> string_opt !dest_proto)
+    , "destination protocol to be used for copying the disk"
+    )
+  ; ( "nbd-export"
+    , Arg.String (fun x -> nbd_export := x)
+    , (fun () -> !nbd_export)
+    , "nbd export name to be used, only useful when dest-proto is nbd"
+    )
   ]
 
 let startswith prefix x =
@@ -288,6 +302,15 @@ let _ =
     debug "Must have -size argument\n" ;
     exit 1
   ) ;
+  let dest_proto =
+    match !dest_proto with
+    | Some "nbd" ->
+        Some (StreamCommon.Nbd !nbd_export)
+    | Some x ->
+        Some (StreamCommon.protocol_of_string x)
+    | None ->
+        None
+  in
   let size = !size in
   let base = !base in
   (* Helper function to bring an int into valid range *)
@@ -485,7 +508,7 @@ let _ =
   in
   let t =
     stream_t >>= fun s ->
-    Impl.write_stream common s destination None !prezeroed progress None
+    Impl.write_stream common s destination dest_proto !prezeroed progress None
       !good_ciphersuites verify_cert
   in
   if destination_format = "vhd" then

ocaml/vhd-tool/src/dune

@@ -4,7 +4,7 @@
     (language c)
     (names direct_copy_stubs)
   )
-  (name local_lib)
+  (name vhd_lib)
   (wrapped false)
   (libraries
     astring
@@ -32,6 +32,7 @@
     tapctl
     xapi-stdext-std
     xapi-stdext-unix
+    xapi-log
     xen-api-client-lwt
   )
   (preprocess

ocaml/vhd-tool/src/impl.ml

@@ -17,6 +17,8 @@ open Lwt
 module F = Vhd_format.F.From_file (Vhd_format_lwt.IO)
 module In = Vhd_format.F.From_input (Input)
 
+module D = Debug.Make (struct let name = "vhd_impl" end)
+
 module Channel_In = Vhd_format.F.From_input (struct
   include Lwt
 
@@ -218,7 +220,7 @@ let[@warning "-27"] stream_human _common _ s _ _ ?(progress = no_progress_bar)
   Printf.printf "# end of stream\n" ;
   return None
 
-let stream_nbd _common c s prezeroed _ ?(progress = no_progress_bar) () =
+let stream_nbd _common c s prezeroed ~export ?(progress = no_progress_bar) () =
   let open Nbd_unix in
   let c =
     {
@@ -229,9 +231,10 @@ let stream_nbd _common c s prezeroed _ ?(progress = no_progress_bar) () =
     }
   in
 
-  Client.negotiate c "" >>= fun (server, _size, _flags) ->
+  Client.negotiate c export >>= fun (server, size, _flags) ->
   (* Work to do is: non-zero data to write + empty sectors if the
      target is not prezeroed *)
+  D.debug "%s nbd negotiation done, size is %Ld" __FUNCTION__ size ;
   let total_work =
     let open Vhd_format.F in
     Int64.(
@@ -985,15 +988,15 @@ let write_stream common s destination destination_protocol prezeroed progress
       return (c, [NoProtocol; Human; Tar])
   | File_descr fd ->
       Channels.of_raw_fd fd >>= fun c ->
-      return (c, [Nbd; NoProtocol; Chunked; Human; Tar])
+      return (c, [dummy_nbd; NoProtocol; Chunked; Human; Tar])
   | Sockaddr sockaddr ->
       let sock = socket sockaddr in
       Lwt.catch
         (fun () -> Lwt_unix.connect sock sockaddr)
         (fun e -> Lwt_unix.close sock >>= fun () -> Lwt.fail e)
       >>= fun () ->
       Channels.of_raw_fd sock >>= fun c ->
-      return (c, [Nbd; NoProtocol; Chunked; Human; Tar])
+      return (c, [dummy_nbd; NoProtocol; Chunked; Human; Tar])
   | Https uri' | Http uri' -> (
       (* TODO: https is not currently implemented *)
       let port =
@@ -1013,7 +1016,6 @@ let write_stream common s destination destination_protocol prezeroed progress
       let host = Scanf.ksscanf host (fun _ _ -> host) "[%s@]" Fun.id in
       Lwt_unix.getaddrinfo host (string_of_int port) [] >>= fun he ->
       if he = [] then raise Not_found ;
-
       let sockaddr = (List.hd he).Unix.ai_addr in
       let sock = socket sockaddr in
       Lwt.catch
@@ -1074,7 +1076,7 @@ let write_stream common s destination destination_protocol prezeroed progress
               List.mem_assoc te headers && List.assoc te headers = "nbd"
             in
             if advertises_nbd then
-              return (c, [Nbd])
+              return (c, [dummy_nbd])
             else
               return (c, [Chunked; NoProtocol])
           else
@@ -1088,10 +1090,16 @@ let write_stream common s destination destination_protocol prezeroed progress
         x
     | None ->
         let t = List.hd possible_protocols in
-        Printf.fprintf stderr "Using protocol: %s\n%!" (string_of_protocol t) ;
+        D.info "Using protocol: %s\n%!" (string_of_protocol t) ;
         t
   in
-  if not (List.mem destination_protocol possible_protocols) then
+  if
+    not
+      (List.exists
+         (( = ) (match destination_protocol with Nbd _ -> dummy_nbd | y -> y))
+         possible_protocols
+      )
+  then
     fail
       (Failure
          (Printf.sprintf "this destination only supports protocols: [ %s ]"
@@ -1101,18 +1109,17 @@ let write_stream common s destination destination_protocol prezeroed progress
   else
     let start = Unix.gettimeofday () in
     ( match destination_protocol with
-    | Nbd ->
-        stream_nbd
+    | Nbd export ->
+        stream_nbd common c s prezeroed ~export ~progress ()
     | Human ->
-        stream_human
+        stream_human common c s prezeroed tar_filename_prefix ~progress ()
     | Chunked ->
-        stream_chunked
+        stream_chunked common c s prezeroed tar_filename_prefix ~progress ()
     | Tar ->
-        stream_tar
+        stream_tar common c s prezeroed tar_filename_prefix ~progress ()
     | NoProtocol ->
-        stream_raw
+        stream_raw common c s prezeroed tar_filename_prefix ~progress ()
     )
-      common c s prezeroed tar_filename_prefix ~progress ()
     >>= fun p ->
     c.Channels.close () >>= fun () ->
     match p with
@@ -1319,7 +1326,7 @@ let serve common_options source source_fd source_format source_protocol
     let supported_formats = ["raw"] in
     if not (List.mem destination_format supported_formats) then
       failwith (Printf.sprintf "%s is not a supported format" destination_format) ;
-    let supported_protocols = [NoProtocol; Chunked; Nbd; Tar] in
+    let supported_protocols = [NoProtocol; Chunked; dummy_nbd; Tar] in
     if not (List.mem source_protocol supported_protocols) then
       failwith
         (Printf.sprintf "%s is not a supported source protocol"
@@ -1409,7 +1416,7 @@ let serve common_options source source_fd source_format source_protocol
         match (source_format, source_protocol) with
         | "raw", NoProtocol ->
             serve_raw_to_raw common_options size
-        | "raw", Nbd ->
+        | "raw", Nbd _ ->
             serve_nbd_to_raw common_options size
         | "raw", Chunked ->
             serve_chunked_to_raw common_options

ocaml/vhd-tool/src/streamCommon.ml

@@ -12,11 +12,20 @@
  * GNU Lesser General Public License for more details.
  *)
 
-type protocol = Nbd | Chunked | Human | Tar | NoProtocol
+type protocol =
+  | Nbd of string (* export name used by the nbd client during negotiation*)
+  | Chunked
+  | Human
+  | Tar
+  | NoProtocol
+
+(** This dummy nbd has no export name in it, it is introduced for backwards compatability 
+reasons. *)
+let dummy_nbd = Nbd ""
 
 let protocol_of_string = function
   | "nbd" ->
-      Nbd
+      dummy_nbd
   | "chunked" ->
       Chunked
   | "human" ->
@@ -29,8 +38,8 @@ let protocol_of_string = function
       failwith (Printf.sprintf "Unsupported protocol: %s" x)
 
 let string_of_protocol = function
-  | Nbd ->
-      "nbd"
+  | Nbd export ->
+      "nbd:" ^ export
   | Chunked ->
       "chunked"
   | Human ->

ocaml/vhd-tool/test/dune

@@ -4,7 +4,7 @@
     alcotest
     alcotest-lwt
     lwt
-    local_lib
+    vhd_lib
     vhd-format
     vhd-format-lwt
   )