IH-657: Reduce XAPI code duplication

ocaml/vhd-tool/src/dune

@@ -11,6 +11,7 @@
     cohttp
     cohttp-lwt
     cstruct
+    (re_export ezxenstore)
     io-page
     lwt
     lwt.unix
@@ -30,6 +31,7 @@
     tapctl
     xapi-stdext-std
     xapi-stdext-unix
+    xen-api-client-lwt
     xenstore
     xenstore.client
     xenstore.unix

ocaml/vhd-tool/src/impl.ml

@@ -954,6 +954,27 @@ let make_stream common source relative_to source_format destination_format =
   | _, _ ->
       assert false
 
+module ChannelsConstrained : sig
+  type t = Channels.t
+
+  type reader = Cstruct.t -> unit Lwt.t
+
+  val really_read : t -> reader
+
+  val really_write : t -> reader
+end = struct
+  type t = Channels.t
+
+  type reader = Cstruct.t -> unit Lwt.t
+
+  let really_read x = x.Channels.really_read
+
+  let really_write x = x.Channels.really_write
+end
+
+module Cohttp_io_with_channels =
+  Xen_api_client_lwt.Cohttp_unbuffered_io.Make (ChannelsConstrained)
+
 (** [write_stream common s destination destination_protocol prezeroed progress
      tar_filename_prefix ssl_legacy good_ciphersuites legacy_ciphersuites]
     writes the data stream [s] to [destination], using the specified
@@ -1019,8 +1040,8 @@ let write_stream common s destination destination_protocol prezeroed progress
           Channels.of_raw_fd sock
       )
       >>= fun c ->
-      let module Request = Request.Make (Cohttp_unbuffered_io) in
-      let module Response = Response.Make (Cohttp_unbuffered_io) in
+      let module Request = Request.Make (Cohttp_io_with_channels) in
+      let module Response = Response.Make (Cohttp_io_with_channels) in
       let headers = Header.init () in
       let k, v = Cookie.Cookie_hdr.serialize [("chunked", "true")] in
       let headers = Header.add headers k v in
@@ -1044,7 +1065,7 @@ let write_stream common s destination destination_protocol prezeroed progress
         Cohttp.Request.make ~meth:`PUT ~version:`HTTP_1_1 ~headers uri'
       in
       Request.write (fun _ -> return ()) request c >>= fun () ->
-      Response.read (Cohttp_unbuffered_io.make_input c) >>= fun r ->
+      Response.read (Cohttp_io_with_channels.make_input c) >>= fun r ->
       match r with
       | `Invalid x ->
           fail (Failure (Printf.sprintf "Invalid HTTP response: %s" x))

ocaml/vhd-tool/src/xenstore.ml

@@ -12,102 +12,4 @@
  * GNU Lesser General Public License for more details.
  *)
 
-let error fmt = Printf.ksprintf (output_string stderr) fmt
-
-module Client = Xs_client_unix.Client (Xs_transport_unix_client)
-
-let make_client () =
-  try Client.make ()
-  with e ->
-    error "Failed to connect to xenstore. The raw error was: %s"
-      (Printexc.to_string e) ;
-    ( match e with
-    | Unix.Unix_error (Unix.EACCES, _, _) ->
-        error "Access to xenstore was denied." ;
-        let euid = Unix.geteuid () in
-        if euid <> 0 then (
-          error "My effective uid is %d." euid ;
-          error "Typically xenstore can only be accessed by root (uid 0)." ;
-          error "Please switch to root (uid 0) and retry."
-        )
-    | Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
-        error "Access to xenstore was refused." ;
-        error "This normally indicates that the service is not running." ;
-        error "Please start the xenstore service and retry."
-    | _ ->
-        ()
-    ) ;
-    raise e
-
-let get_client =
-  let client = ref None in
-  fun () ->
-    match !client with
-    | None ->
-        let c = make_client () in
-        client := Some c ;
-        c
-    | Some c ->
-        c
-
-type domid = int
-
-module Xs = struct
-  type domid = int
-
-  type xsh = {
-      (*
-        debug: string list -> string;
-*)
-      directory: string -> string list
-    ; read: string -> string
-    ; (*
-        readv : string -> string list -> string list;
-*)
-      write: string -> string -> unit
-    ; writev: string -> (string * string) list -> unit
-    ; mkdir: string -> unit
-    ; rm: string -> unit
-    ; (*
-        getperms : string -> perms;
-        setpermsv : string -> string list -> perms -> unit;
-        release : domid -> unit;
-        resume : domid -> unit;
-*)
-      setperms: string -> Xs_protocol.ACL.t -> unit
-    ; getdomainpath: domid -> string
-    ; watch: string -> string -> unit
-    ; unwatch: string -> string -> unit
-    ; introduce: domid -> nativeint -> int -> unit
-    ; set_target: domid -> domid -> unit
-  }
-
-  let ops h =
-    {
-      read= Client.read h
-    ; directory= Client.directory h
-    ; write= Client.write h
-    ; writev=
-        (fun base_path ->
-          List.iter (fun (k, v) -> Client.write h (base_path ^ "/" ^ k) v)
-        )
-    ; mkdir= Client.mkdir h
-    ; rm= (fun path -> try Client.rm h path with Xs_protocol.Enoent _ -> ())
-    ; setperms= Client.setperms h
-    ; getdomainpath= Client.getdomainpath h
-    ; watch= Client.watch h
-    ; unwatch= Client.unwatch h
-    ; introduce= Client.introduce h
-    ; set_target= Client.set_target h
-    }
-
-  let with_xs f = Client.immediate (get_client ()) (fun h -> f (ops h))
-
-  let wait f = Client.wait (get_client ()) (fun h -> f (ops h))
-
-  let transaction _ f = Client.transaction (get_client ()) (fun h -> f (ops h))
-end
-
-module Xst = Xs
-
-let with_xs = Xs.with_xs
+include Ezxenstore_core.Xenstore