Libguestfs - Sep 2017 - Re: [PATCH] RFC: v2v: add and use libvirt connection objects

Enhance the Libvirt_utils module with libvirt connection objects,
and read-only and read-writen open functions for them; adapt the rest of
the mini-binding to use these objects, instead of opening + closing
libvirt connections every time.  This has different improvements:
a) a libvirt connection is reused for different API calls, improving
   the communication with remote (input) servers
b) because of (a), there is way less need to pass libvirt_uri and
   password variables all around

The hierarchy of input_libvirt* classes is changed to take a Lazy object
with the libvirt connection, accessing it through a "proctected"
method:
this way, the connection is opened only at the first access.
---
 v2v/copy_to_local.ml                |   3 +-
 v2v/input_libvirt.ml                |  13 +-
 v2v/input_libvirt_other.ml          |  24 ++--
 v2v/input_libvirt_other.mli         |   5 +-
 v2v/input_libvirt_vcenter_https.ml  |  10 +-
 v2v/input_libvirt_vcenter_https.mli |   2 +-
 v2v/input_libvirt_vddk.ml           |  18 +--
 v2v/input_libvirt_vddk.mli          |   4 +-
 v2v/input_libvirt_xen_ssh.ml        |  10 +-
 v2v/input_libvirt_xen_ssh.mli       |   2 +-
 v2v/input_libvirtxml.ml             |   3 +-
 v2v/libvirt_utils-c.c               | 259 +++++++++++++++++++-----------------
 v2v/libvirt_utils.ml                |  16 ++-
 v2v/libvirt_utils.mli               |  44 +++---
 v2v/output_libvirt.ml               |   8 +-
 v2v/parse_libvirt_xml.ml            |   4 +-
 v2v/parse_libvirt_xml.mli           |   2 +-
 17 files changed, 233 insertions(+), 194 deletions(-)

diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index 0a2b7ed75..828b5b490 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -131,7 +131,8 @@ read the man page virt-v2v-copy-to-local(1).
 
   (* Get the remote libvirt XML. *)
   message (f_"Fetching the remote libvirt XML metadata ...");
-  let xml = Libvirt_utils.dumpxml ?password ~conn:input_conn guest_name in
+  let conn = Libvirt_utils.connect_rw ?password ~conn:input_conn () in
+  let xml = Libvirt_utils.dumpxml conn guest_name in
 
   debug "libvirt XML from remote server:\n%s" xml;
 
diff --git a/v2v/input_libvirt.ml b/v2v/input_libvirt.ml
index e8143b6ad..6baac7d5f 100644
--- a/v2v/input_libvirt.ml
+++ b/v2v/input_libvirt.ml
@@ -28,9 +28,10 @@ open Utils
 
 (* Choose the right subclass based on the URI. *)
 let input_libvirt dcpath vddk_options password libvirt_uri guest +  let conn =
lazy (Libvirt_utils.connect_rw ?password ?conn:libvirt_uri ()) in
   match libvirt_uri with
   | None ->
-    Input_libvirt_other.input_libvirt_other password libvirt_uri guest
+    Input_libvirt_other.input_libvirt_other conn guest
 
   | Some orig_uri ->
     let { Xml.uri_server = server; uri_scheme = scheme } as parsed_uri @@ -45,7
+46,7 @@ let input_libvirt dcpath vddk_options password libvirt_uri guest
     | Some _, None                      (* No scheme? *)
     | Some _, Some "" ->
-      Input_libvirt_other.input_libvirt_other password libvirt_uri guest
+      Input_libvirt_other.input_libvirt_other conn guest
 
     (* vCenter over https, or
      * vCenter or ESXi using nbdkit vddk plugin
@@ -54,16 +55,16 @@ let input_libvirt dcpath vddk_options password libvirt_uri
guest         (match vddk_options with
         | None ->
            Input_libvirt_vcenter_https.input_libvirt_vcenter_https
-             dcpath password libvirt_uri parsed_uri scheme server guest
+             dcpath conn password parsed_uri scheme server guest
         | Some vddk_options ->
            Input_libvirt_vddk.input_libvirt_vddk vddk_options password
-                                                 libvirt_uri parsed_uri guest
+                                                 conn parsed_uri guest
        )
 
     (* Xen over SSH *)
     | Some server, Some ("xen+ssh" as scheme) ->
       Input_libvirt_xen_ssh.input_libvirt_xen_ssh
-        password libvirt_uri parsed_uri scheme server guest
+        conn parsed_uri scheme server guest
 
     (* Old virt-v2v also supported qemu+ssh://.  However I am
      * deliberately not supporting this in new virt-v2v.  Don't
@@ -74,6 +75,6 @@ let input_libvirt dcpath vddk_options password libvirt_uri
guest      | Some _, Some _ ->
       warning (f_"no support for remote libvirt connections to '-ic
%s'.  The conversion may fail when it tries to read the source disks.")
         orig_uri;
-      Input_libvirt_other.input_libvirt_other password libvirt_uri guest
+      Input_libvirt_other.input_libvirt_other conn guest
 
 let () = Modules_list.register_input_module "libvirt"
diff --git a/v2v/input_libvirt_other.ml b/v2v/input_libvirt_other.ml
index 05923e952..cd466a2c5 100644
--- a/v2v/input_libvirt_other.ml
+++ b/v2v/input_libvirt_other.ml
@@ -49,24 +49,24 @@ let error_if_no_ssh_agent ()      error (f_"ssh-agent
authentication has not been set up ($SSH_AUTH_SOCK is not set).  Please read
\"INPUT FROM RHEL 5 XEN\" in the virt-v2v(1) man page.")
 
 (* Superclass. *)
-class virtual input_libvirt (password : string option) libvirt_uri guest
-object
+class virtual input_libvirt lazy_conn guest +  let conn_obj = lazy_conn in
+object (self)
   inherit input
 
   method as_options -    sprintf "-i libvirt%s %s"
-      (match libvirt_uri with
-      | None -> ""
-      | Some uri -> " -ic " ^ uri)
-      guest
+    sprintf "-i libvirt -ic %s %s" (Libvirt_utils.get_uri self#conn)
guest
+
+  method private conn +    Lazy.force conn_obj
 end
 
 (* Subclass specialized for handling anything that's *not* VMware vCenter
  * or Xen.
  *)
-class input_libvirt_other password libvirt_uri guest -object
-  inherit input_libvirt password libvirt_uri guest
+class input_libvirt_other lazy_conn guest +object (self)
+  inherit input_libvirt lazy_conn guest
 
   method source ()      debug "input_libvirt_other: source()";
@@ -74,9 +74,9 @@ object
     (* Get the libvirt XML.  This also checks (as a side-effect)
      * that the domain is not running.  (RHBZ#1138586)
      *)
-    let xml = Libvirt_utils.dumpxml ?password ?conn:libvirt_uri guest in
+    let xml = Libvirt_utils.dumpxml self#conn guest in
 
-    let source, disks = parse_libvirt_xml ?conn:libvirt_uri xml in
+    let source, disks = parse_libvirt_xml self#conn xml in
     let disks = List.map (fun { p_source_disk = disk } -> disk) disks in
     { source with s_disks = disks }
 end
diff --git a/v2v/input_libvirt_other.mli b/v2v/input_libvirt_other.mli
index 603fd3dd2..9645aa5af 100644
--- a/v2v/input_libvirt_other.mli
+++ b/v2v/input_libvirt_other.mli
@@ -21,10 +21,11 @@
 val error_if_libvirt_does_not_support_json_backingfile : unit -> unit
 val error_if_no_ssh_agent : unit -> unit
 
-class virtual input_libvirt : string option -> string option -> string
-> object
+class virtual input_libvirt : Libvirt_utils.conn Lazy.t -> string ->
object
   method as_options : string
   method virtual source : unit -> Types.source
   method adjust_overlay_parameters : Types.overlay -> unit
+  method private conn : Libvirt_utils.conn
 end
 
-val input_libvirt_other : string option -> string option -> string ->
Types.input
+val input_libvirt_other : Libvirt_utils.conn Lazy.t -> string ->
Types.input
diff --git a/v2v/input_libvirt_vcenter_https.ml
b/v2v/input_libvirt_vcenter_https.ml
index 8b6856c7e..54370b954 100644
--- a/v2v/input_libvirt_vcenter_https.ml
+++ b/v2v/input_libvirt_vcenter_https.ml
@@ -36,9 +36,9 @@ let readahead_for_copying = Some (64 * 1024 * 1024)
 
 (* Subclass specialized for handling VMware vCenter over https. *)
 class input_libvirt_vcenter_https
-  cmdline_dcPath password libvirt_uri parsed_uri scheme server guest -object
-  inherit input_libvirt password libvirt_uri guest
+  cmdline_dcPath lazy_conn password parsed_uri scheme server guest +object
(self)
+  inherit input_libvirt lazy_conn guest
 
   val saved_source_paths = Hashtbl.create 13
   val mutable dcPath = ""
@@ -64,8 +64,8 @@ object
     (* Get the libvirt XML.  This also checks (as a side-effect)
      * that the domain is not running.  (RHBZ#1138586)
      *)
-    let xml = Libvirt_utils.dumpxml ?password ?conn:libvirt_uri guest in
-    let source, disks = parse_libvirt_xml ?conn:libvirt_uri xml in
+    let xml = Libvirt_utils.dumpxml self#conn guest in
+    let source, disks = parse_libvirt_xml self#conn xml in
 
     (* Find the <vmware:datacenterpath> element from the XML, if it
      * exists.  This was added in libvirt >= 1.2.20.
diff --git a/v2v/input_libvirt_vcenter_https.mli
b/v2v/input_libvirt_vcenter_https.mli
index 840b5a90f..6f848f2f0 100644
--- a/v2v/input_libvirt_vcenter_https.mli
+++ b/v2v/input_libvirt_vcenter_https.mli
@@ -18,4 +18,4 @@
 
 (** [-i libvirt] when the source is VMware vCenter *)
 
-val input_libvirt_vcenter_https : string option -> string option ->
string option -> Xml.uri -> string -> string -> string ->
Types.input
+val input_libvirt_vcenter_https : string option -> Libvirt_utils.conn Lazy.t
-> string option -> Xml.uri -> string -> string -> string ->
Types.input
diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml
index b6a57d374..a09c0b55b 100644
--- a/v2v/input_libvirt_vddk.ml
+++ b/v2v/input_libvirt_vddk.ml
@@ -34,7 +34,7 @@ open Xpath_helpers
 open Printf
 
 (* Subclass specialized for handling VMware via nbdkit vddk plugin. *)
-class input_libvirt_vddk vddk_options password libvirt_uri parsed_uri guest
+class input_libvirt_vddk vddk_options password lazy_conn parsed_uri guest
   (* The VDDK path. *)
   let libdir = vddk_options.vddk_libdir in
@@ -102,8 +102,8 @@ See also \"INPUT FROM VDDK\" in the virt-v2v(1)
manual.") library_path
       error (f_"You must pass the ‘--vddk-thumbprint’ option with the SSL
thumbprint of the VMware server.  To find the thumbprint, see the
nbdkit-vddk-plugin(1) manual.  See also \"INPUT FROM VDDK\" in the
virt-v2v(1) manual.")
   in
 
-object
-  inherit input_libvirt password libvirt_uri guest
+object (self)
+  inherit input_libvirt lazy_conn guest
 
   method source ()      error_unless_vddk_libdir ();
@@ -114,8 +114,8 @@ object
     (* Get the libvirt XML.  This also checks (as a side-effect)
      * that the domain is not running.  (RHBZ#1138586)
      *)
-    let xml = Libvirt_utils.dumpxml ?password ?conn:libvirt_uri guest in
-    let source, disks = parse_libvirt_xml ?conn:libvirt_uri xml in
+    let xml = Libvirt_utils.dumpxml self#conn guest in
+    let source, disks = parse_libvirt_xml self#conn xml in
 
     (* Find the <vmware:moref> element from the XML.  This was added
      * in libvirt >= 3.7 and is required.
@@ -163,12 +163,8 @@ object
         match parsed_uri.Xml.uri_server with
         | Some server -> server
         | None ->
-           match libvirt_uri with
-           | Some libvirt_uri ->
-              error (f_"‘-ic %s’ URL does not contain a host name
field")
-                    libvirt_uri
-           | None ->
-              error (f_"you must use the ‘-ic’ parameter.  See
\"INPUT FROM VDDK\" in the virt-v2v(1) manual.") in
+           (* XXX *)
+            error (f_"you must use the ‘-ic’ parameter.  See \"INPUT
FROM VDDK\" in the virt-v2v(1) manual.") in
 
       (* Similar to above, we also need a username to pass. *)
       let user diff --git a/v2v/input_libvirt_vddk.mli
b/v2v/input_libvirt_vddk.mli
index 19a34c202..3017488b5 100644
--- a/v2v/input_libvirt_vddk.mli
+++ b/v2v/input_libvirt_vddk.mli
@@ -18,7 +18,7 @@
 
 (** [-i libvirt] when the source is VMware via nbdkit vddk plugin *)
 
-val input_libvirt_vddk : Types.vddk_options -> string option -> string
option -> Xml.uri -> string -> Types.input
-(** [input_libvirt_vddk vddk_options password libvirt_uri parsed_uri guest]
+val input_libvirt_vddk : Types.vddk_options -> string option ->
Libvirt_utils.conn Lazy.t -> Xml.uri -> string -> Types.input
+(** [input_libvirt_vddk vddk_options password conn parsed_uri guest]
     creates and returns a {!Types.input} object specialized for reading
     the guest disks using the nbdkit vddk plugin. *)
diff --git a/v2v/input_libvirt_xen_ssh.ml b/v2v/input_libvirt_xen_ssh.ml
index fd3da2c44..9d3005855 100644
--- a/v2v/input_libvirt_xen_ssh.ml
+++ b/v2v/input_libvirt_xen_ssh.ml
@@ -30,9 +30,9 @@ open Input_libvirt_other
 open Printf
 
 (* Subclass specialized for handling Xen over SSH. *)
-class input_libvirt_xen_ssh password libvirt_uri parsed_uri scheme server guest
-object
-  inherit input_libvirt password libvirt_uri guest
+class input_libvirt_xen_ssh lazy_conn parsed_uri scheme server guest +object
(self)
+  inherit input_libvirt lazy_conn guest
 
   method source ()      debug "input_libvirt_xen_ssh: source: scheme %s
server %s"
@@ -47,8 +47,8 @@ object
     (* Get the libvirt XML.  This also checks (as a side-effect)
      * that the domain is not running.  (RHBZ#1138586)
      *)
-    let xml = Libvirt_utils.dumpxml ?password ?conn:libvirt_uri guest in
-    let source, disks = parse_libvirt_xml ?conn:libvirt_uri xml in
+    let xml = Libvirt_utils.dumpxml self#conn guest in
+    let source, disks = parse_libvirt_xml self#conn xml in
 
     (* Map the <source/> filename (which is relative to the remote
      * Xen server) to an ssh URI.  This is a JSON URI looking something
diff --git a/v2v/input_libvirt_xen_ssh.mli b/v2v/input_libvirt_xen_ssh.mli
index 85213241a..bde0ff65a 100644
--- a/v2v/input_libvirt_xen_ssh.mli
+++ b/v2v/input_libvirt_xen_ssh.mli
@@ -18,4 +18,4 @@
 
 (** [-i libvirt] when the source is Xen *)
 
-val input_libvirt_xen_ssh : string option -> string option -> Xml.uri
-> string -> string -> string -> Types.input
+val input_libvirt_xen_ssh : Libvirt_utils.conn Lazy.t -> Xml.uri ->
string -> string -> string -> Types.input
diff --git a/v2v/input_libvirtxml.ml b/v2v/input_libvirtxml.ml
index 570541d7d..5d13faee6 100644
--- a/v2v/input_libvirtxml.ml
+++ b/v2v/input_libvirtxml.ml
@@ -34,7 +34,8 @@ object
   method source ()      let xml = read_whole_file file in
 
-    let source, disks = parse_libvirt_xml xml in
+    let conn = Libvirt_utils.connect_ro () in
+    let source, disks = parse_libvirt_xml conn xml in
 
     (* When reading libvirt XML from a file (-i libvirtxml) we allow
      * paths to disk images in the libvirt XML to be relative (to the XML
diff --git a/v2v/libvirt_utils-c.c b/v2v/libvirt_utils-c.c
index 93ee5208e..fec14356b 100644
--- a/v2v/libvirt_utils-c.c
+++ b/v2v/libvirt_utils-c.c
@@ -31,6 +31,7 @@
 #include <libintl.h>
 
 #include <caml/alloc.h>
+#include <caml/custom.h>
 #include <caml/fail.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
@@ -49,6 +50,39 @@
 
 #define ERROR_MESSAGE_LEN 512
 
+/* Wrap and unwrap virConnectPtr, with a finalizer. */
+#define Libvirtconn_val(rv) (*(virConnectPtr *)Data_custom_val(rv))
+
+static void
+libvirtconn_finalize (value rev)
+{
+  virConnectPtr conn = Libvirtconn_val (rev);
+  if (conn)
+    virConnectClose (conn);
+}
+
+static struct custom_operations custom_operations = {
+  (char *) "libvirtconn_custom_operations",
+  libvirtconn_finalize,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default
+};
+
+static value
+Val_libvirtconn (virConnectPtr conn)
+{
+  CAMLparam0 ();
+  CAMLlocal1 (rv);
+
+  rv = caml_alloc_custom (&custom_operations, sizeof (virConnectPtr), 0,
1);
+  Libvirtconn_val (rv) = conn;
+
+  CAMLreturn (rv);
+}
+
+
 static void
 ignore_errors (void *ignore, virErrorPtr ignore2)
 {
@@ -111,11 +145,10 @@ libvirt_auth_default_wrapper (virConnectCredentialPtr
cred,
   }
 }
 
-virStoragePoolPtr
+static virStoragePoolPtr
 connect_and_load_pool (value connv, value poolnamev)
 {
   CAMLparam2 (connv, poolnamev);
-  const char *conn_uri = NULL;
   const char *poolname;
   /* We have to assemble the error on the stack because a dynamic
    * string couldn't be freed.
@@ -125,31 +158,8 @@ connect_and_load_pool (value connv, value poolnamev)
   virConnectPtr conn;
   virStoragePoolPtr pool;
 
-  if (connv != Val_int (0))
-    conn_uri = String_val (Field (connv, 0)); /* Some conn */
-
-  /* We have to call the default authentication handler, not least
-   * since it handles all the PolicyKit crap.  However it also makes
-   * coding this simpler.
-   */
-  conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault,
-                             VIR_CONNECT_RO);
-  if (conn == NULL) {
-    if (conn_uri)
-      snprintf (errmsg, sizeof errmsg,
-                _("cannot open libvirt connection ‘%s’"), conn_uri);
-    else
-      snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
-    caml_invalid_argument (errmsg);
-  }
-
-  /* Suppress default behaviour of printing errors to stderr.  Note
-   * you can't set this to NULL to ignore errors; setting it to NULL
-   * restores the default error handler ...
-   */
-  virConnSetErrorFunc (conn, NULL, ignore_errors);
-
   /* Look up the pool. */
+  conn = Libvirtconn_val (connv);
   poolname = String_val (poolnamev);
 
   pool = virStoragePoolLookupByUUIDString (conn, poolname);
@@ -162,48 +172,72 @@ connect_and_load_pool (value connv, value poolnamev)
     snprintf (errmsg, sizeof errmsg,
               _("cannot find libvirt pool ‘%s’: %s\n\nUse ‘virsh pool-list
--all’ to list all available pools, and ‘virsh pool-dumpxml <pool>’ to
display details about a particular pool.\n\nTo set the pool which virt-v2v uses,
add the ‘-os <pool>’ option."),
               poolname, err->message);
-    virConnectClose (conn);
     caml_invalid_argument (errmsg);
   }
 
   CAMLreturnT (virStoragePoolPtr, pool);
 }
 
+
 value
-v2v_dumpxml (value passwordv, value connv, value domnamev)
+v2v_libvirt_connect_ro (value connv, value unitv)
 {
-  CAMLparam3 (passwordv, connv, domnamev);
-  CAMLlocal1 (retv);
+  CAMLparam2 (connv, unitv);
+  const char *conn_uri = NULL;
+  char errmsg[ERROR_MESSAGE_LEN];
+  virConnectPtr conn;
+
+  if (connv != Val_int (0))
+    conn_uri = String_val (Field (connv, 0)); /* Some conn */
+
+  /* We have to call the default authentication handler, not least
+   * since it handles all the PolicyKit crap.  However it also makes
+   * coding this simpler.
+   */
+  conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault,
+                             VIR_CONNECT_RO);
+  if (conn == NULL) {
+    if (conn_uri)
+      snprintf (errmsg, sizeof errmsg,
+                _("cannot open libvirt connection ‘%s’"), conn_uri);
+    else
+      snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
+    caml_invalid_argument (errmsg);
+  }
+
+  /* Suppress default behaviour of printing errors to stderr.  Note
+   * you can't set this to NULL to ignore errors; setting it to NULL
+   * restores the default error handler ...
+   */
+  virConnSetErrorFunc (conn, NULL, ignore_errors);
+
+  CAMLreturn (Val_libvirtconn (conn));
+}
+
+value
+v2v_libvirt_connect_rw (value passwordv, value connv, value unitv)
+{
+  CAMLparam3 (passwordv, connv, unitv);
   const char *password = NULL;
   const char *conn_uri = NULL;
-  const char *domname;
   virConnectAuth authdata;
   /* We have to assemble the error on the stack because a dynamic
    * string couldn't be freed.
    */
   char errmsg[ERROR_MESSAGE_LEN];
-  virErrorPtr err;
   virConnectPtr conn;
-  virDomainPtr dom;
-  int is_test_uri = 0;
-  char *xml;
 
   if (passwordv != Val_int (0))
     password = String_val (Field (passwordv, 0)); /* Some password */
 
-  if (connv != Val_int (0)) {
+  if (connv != Val_int (0))
     conn_uri = String_val (Field (connv, 0)); /* Some conn */
-    is_test_uri = STRPREFIX (conn_uri, "test:");
-  }
 
   /* Set up authentication wrapper. */
   authdata = *virConnectAuthPtrDefault;
   authdata.cb = libvirt_auth_default_wrapper;
   authdata.cbdata = (void *) password;
 
-  /* Note this cannot be a read-only connection since we need to use
-   * the VIR_DOMAIN_XML_SECURE flag below.
-   */
   conn = virConnectOpenAuth (conn_uri, &authdata, 0);
   if (conn == NULL) {
     if (conn_uri)
@@ -220,6 +254,26 @@ v2v_dumpxml (value passwordv, value connv, value domnamev)
    */
   virConnSetErrorFunc (conn, NULL, ignore_errors);
 
+  CAMLreturn (Val_libvirtconn (conn));
+}
+
+value
+v2v_libvirt_dumpxml (value connv, value domnamev)
+{
+  CAMLparam2 (connv, domnamev);
+  CAMLlocal1 (retv);
+  const char *domname;
+  /* We have to assemble the error on the stack because a dynamic
+   * string couldn't be freed.
+   */
+  char errmsg[ERROR_MESSAGE_LEN];
+  virErrorPtr err;
+  virConnectPtr conn;
+  virDomainPtr dom;
+  int is_test_uri = 0;
+  char *xml;
+
+  conn = Libvirtconn_val (connv);
   /* Look up the domain. */
   domname = String_val (domnamev);
 
@@ -232,10 +286,11 @@ v2v_dumpxml (value passwordv, value connv, value domnamev)
     err = virGetLastError ();
     snprintf (errmsg, sizeof errmsg,
               _("cannot find libvirt domain ‘%s’: %s"), domname,
err->message);
-    virConnectClose (conn);
     caml_invalid_argument (errmsg);
   }
 
+  is_test_uri = STRPREFIX (virConnectGetURI (conn), "test:");
+
   /* As a side-effect we check that the domain is shut down.  Of course
    * this is only appropriate for virt-v2v.  (RHBZ#1138586)
    */
@@ -249,7 +304,6 @@ v2v_dumpxml (value passwordv, value connv, value domnamev)
                 _("libvirt domain ‘%s’ is running or paused.  It must be
shut down in order to perform virt-v2v conversion"),
                 domname);
       virDomainFree (dom);
-      virConnectClose (conn);
       caml_invalid_argument (errmsg);
     }
   }
@@ -262,11 +316,9 @@ v2v_dumpxml (value passwordv, value connv, value domnamev)
               _("cannot fetch XML description of guest ‘%s’: %s"),
               domname, err->message);
     virDomainFree (dom);
-    virConnectClose (conn);
     caml_invalid_argument (errmsg);
   }
   virDomainFree (dom);
-  virConnectClose (conn);
 
   retv = caml_copy_string (xml);
   free (xml);
@@ -275,7 +327,7 @@ v2v_dumpxml (value passwordv, value connv, value domnamev)
 }
 
 value
-v2v_pool_dumpxml (value connv, value poolnamev)
+v2v_libvirt_pool_dumpxml (value connv, value poolnamev)
 {
   CAMLparam2 (connv, poolnamev);
   CAMLlocal1 (retv);
@@ -284,13 +336,11 @@ v2v_pool_dumpxml (value connv, value poolnamev)
    */
   char errmsg[ERROR_MESSAGE_LEN];
   virErrorPtr err;
-  virConnectPtr conn;
   virStoragePoolPtr pool;
   char *xml;
 
   /* Look up the pool. */
   pool = connect_and_load_pool (connv, poolnamev);
-  conn = virStoragePoolGetConnect (pool);
 
   xml = virStoragePoolGetXMLDesc (pool, 0);
   if (xml == NULL) {
@@ -299,11 +349,9 @@ v2v_pool_dumpxml (value connv, value poolnamev)
               _("cannot fetch XML description of pool ‘%s’: %s"),
               String_val (poolnamev), err->message);
     virStoragePoolFree (pool);
-    virConnectClose (conn);
     caml_invalid_argument (errmsg);
   }
   virStoragePoolFree (pool);
-  virConnectClose (conn);
 
   retv = caml_copy_string (xml);
   free (xml);
@@ -312,7 +360,7 @@ v2v_pool_dumpxml (value connv, value poolnamev)
 }
 
 value
-v2v_vol_dumpxml (value connv, value poolnamev, value volnamev)
+v2v_libvirt_vol_dumpxml (value connv, value poolnamev, value volnamev)
 {
   CAMLparam3 (connv, poolnamev, volnamev);
   CAMLlocal1 (retv);
@@ -322,14 +370,12 @@ v2v_vol_dumpxml (value connv, value poolnamev, value
volnamev)
    */
   char errmsg[ERROR_MESSAGE_LEN];
   virErrorPtr err;
-  virConnectPtr conn;
   virStoragePoolPtr pool;
   virStorageVolPtr vol;
   char *xml;
 
   /* Look up the pool. */
   pool = connect_and_load_pool (connv, poolnamev);
-  conn = virStoragePoolGetConnect (pool);
 
   /* Look up the volume. */
   volname = String_val (volnamev);
@@ -341,7 +387,6 @@ v2v_vol_dumpxml (value connv, value poolnamev, value
volnamev)
     snprintf (errmsg, sizeof errmsg,
               _("cannot find libvirt volume ‘%s’: %s"), volname,
err->message);
     virStoragePoolFree (pool);
-    virConnectClose (conn);
     caml_invalid_argument (errmsg);
   }
 
@@ -353,12 +398,10 @@ v2v_vol_dumpxml (value connv, value poolnamev, value
volnamev)
               volname, err->message);
     virStorageVolFree (vol);
     virStoragePoolFree (pool);
-    virConnectClose (conn);
     caml_invalid_argument (errmsg);
   }
   virStorageVolFree (vol);
   virStoragePoolFree (pool);
-  virConnectClose (conn);
 
   retv = caml_copy_string (xml);
   free (xml);
@@ -367,11 +410,10 @@ v2v_vol_dumpxml (value connv, value poolnamev, value
volnamev)
 }
 
 value
-v2v_capabilities (value connv, value unitv)
+v2v_libvirt_capabilities (value connv)
 {
-  CAMLparam2 (connv, unitv);
+  CAMLparam1 (connv);
   CAMLlocal1 (capabilitiesv);
-  const char *conn_uri = NULL;
   char *capabilities;
   /* We have to assemble the error on the stack because a dynamic
    * string couldn't be freed.
@@ -380,29 +422,7 @@ v2v_capabilities (value connv, value unitv)
   virErrorPtr err;
   virConnectPtr conn;
 
-  if (connv != Val_int (0))
-    conn_uri = String_val (Field (connv, 0)); /* Some conn */
-
-  /* We have to call the default authentication handler, not least
-   * since it handles all the PolicyKit crap.  However it also makes
-   * coding this simpler.
-   */
-  conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault,
-                             VIR_CONNECT_RO);
-  if (conn == NULL) {
-    if (conn_uri)
-      snprintf (errmsg, sizeof errmsg,
-                _("cannot open libvirt connection ‘%s’"), conn_uri);
-    else
-      snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
-    caml_invalid_argument (errmsg);
-  }
-
-  /* Suppress default behaviour of printing errors to stderr.  Note
-   * you can't set this to NULL to ignore errors; setting it to NULL
-   * restores the default error handler ...
-   */
-  virConnSetErrorFunc (conn, NULL, ignore_errors);
+  conn = Libvirtconn_val (connv);
 
   capabilities = virConnectGetCapabilities (conn);
   if (!capabilities) {
@@ -410,23 +430,19 @@ v2v_capabilities (value connv, value unitv)
     snprintf (errmsg, sizeof errmsg,
               _("cannot get libvirt hypervisor capabilities: %s"),
               err->message);
-    virConnectClose (conn);
     caml_invalid_argument (errmsg);
   }
 
   capabilitiesv = caml_copy_string (capabilities);
   free (capabilities);
 
-  virConnectClose (conn);
-
   CAMLreturn (capabilitiesv);
 }
 
 value
-v2v_domain_exists (value connv, value domnamev)
+v2v_libvirt_domain_exists (value connv, value domnamev)
 {
   CAMLparam2 (connv, domnamev);
-  const char *conn_uri = NULL;
   const char *domname;
   /* We have to assemble the error on the stack because a dynamic
    * string couldn't be freed.
@@ -437,31 +453,8 @@ v2v_domain_exists (value connv, value domnamev)
   virDomainPtr dom;
   int domain_exists;
 
-  if (connv != Val_int (0))
-    conn_uri = String_val (Field (connv, 0)); /* Some conn */
-
-  /* We have to call the default authentication handler, not least
-   * since it handles all the PolicyKit crap.  However it also makes
-   * coding this simpler.
-   */
-  conn = virConnectOpenAuth (conn_uri, virConnectAuthPtrDefault,
-                             VIR_CONNECT_RO);
-  if (conn == NULL) {
-    if (conn_uri)
-      snprintf (errmsg, sizeof errmsg,
-                _("cannot open libvirt connection ‘%s’"), conn_uri);
-    else
-      snprintf (errmsg, sizeof errmsg, _("cannot open libvirt
connection"));
-    caml_invalid_argument (errmsg);
-  }
-
-  /* Suppress default behaviour of printing errors to stderr.  Note
-   * you can't set this to NULL to ignore errors; setting it to NULL
-   * restores the default error handler ...
-   */
-  virConnSetErrorFunc (conn, NULL, ignore_errors);
-
   /* Look up the domain. */
+  conn = Libvirtconn_val (connv);
   domname = String_val (domnamev);
   dom = virDomainLookupByName (conn, domname);
 
@@ -477,17 +470,44 @@ v2v_domain_exists (value connv, value domnamev)
       snprintf (errmsg, sizeof errmsg,
                 _("cannot find libvirt domain ‘%s’: %s"),
                 domname, err->message);
-      virConnectClose (conn);
       caml_invalid_argument (errmsg);
     }
   }
 
-  virConnectClose (conn);
-
   CAMLreturn (Val_bool (domain_exists));
 }
 
 value
+v2v_libvirt_get_uri (value connv)
+{
+  CAMLparam1 (connv);
+  CAMLlocal1 (uriv);
+  char *uri;
+  /* We have to assemble the error on the stack because a dynamic
+   * string couldn't be freed.
+   */
+  char errmsg[ERROR_MESSAGE_LEN];
+  virErrorPtr err;
+  virConnectPtr conn;
+
+  conn = Libvirtconn_val (connv);
+
+  uri = virConnectGetURI (conn);
+  if (!uri) {
+    err = virGetLastError ();
+    snprintf (errmsg, sizeof errmsg,
+              _("cannot get libvirt hypervisor URI: %s"),
+              err->message);
+    caml_invalid_argument (errmsg);
+  }
+
+  uriv = caml_copy_string (uri);
+  free (uri);
+
+  CAMLreturn (uriv);
+}
+
+value
 v2v_libvirt_get_version (value unitv)
 {
   CAMLparam1 (unitv);
@@ -529,11 +549,12 @@ v2v_libvirt_get_version (value unitv)
     caml_invalid_argument ("virt-v2v was compiled without libvirt
support"); \
   }
 
-NO_LIBVIRT (value v2v_dumpxml (value connv, value domv))
-NO_LIBVIRT (value v2v_pool_dumpxml (value connv, value poolv))
-NO_LIBVIRT (value v2v_vol_dumpxml (value connv, value poolnamev, value
volnamev))
-NO_LIBVIRT (value v2v_capabilities (value connv, value unitv))
-NO_LIBVIRT (value v2v_domain_exists (value connv, value domnamev))
+NO_LIBVIRT (value v2v_libvirt_dumpxml (value connv, value domv))
+NO_LIBVIRT (value v2v_libvirt_pool_dumpxml (value connv, value poolv))
+NO_LIBVIRT (value v2v_libvirt_vol_dumpxml (value connv, value poolnamev, value
volnamev))
+NO_LIBVIRT (value v2v_libvirt_capabilities (value connv, value unitv))
+NO_LIBVIRT (value v2v_libvirt_domain_exists (value connv, value domnamev))
+NO_LIBVIRT (value v2v_libvirt_get_uri (value connv))
 NO_LIBVIRT (value v2v_libvirt_get_version (value unitv))
 
 #endif /* !HAVE_LIBVIRT */
diff --git a/v2v/libvirt_utils.ml b/v2v/libvirt_utils.ml
index 248d78c72..d813855cd 100644
--- a/v2v/libvirt_utils.ml
+++ b/v2v/libvirt_utils.ml
@@ -19,13 +19,19 @@
 (* This module implements various [virsh]-like commands, but with
     non-broken authentication handling. *)
 
-external dumpxml : ?password:string -> ?conn:string -> string ->
string = "v2v_dumpxml"
-external pool_dumpxml : ?conn:string -> string -> string =
"v2v_pool_dumpxml"
-external vol_dumpxml : ?conn:string -> string -> string -> string =
"v2v_vol_dumpxml"
+type conn
+external connect_ro : ?conn:string -> unit -> conn =
"v2v_libvirt_connect_ro"
+external connect_rw : ?password:string -> ?conn:string -> unit -> conn
= "v2v_libvirt_connect_rw"
 
-external capabilities : ?conn:string -> unit -> string =
"v2v_capabilities"
+external dumpxml : conn -> string -> string =
"v2v_libvirt_dumpxml"
+external pool_dumpxml : conn -> string -> string =
"v2v_libvirt_pool_dumpxml"
+external vol_dumpxml : conn -> string -> string -> string =
"v2v_libvirt_vol_dumpxml"
 
-external domain_exists : ?conn:string -> string -> bool =
"v2v_domain_exists"
+external capabilities : conn -> string =
"v2v_libvirt_capabilities"
+
+external domain_exists : conn -> string -> bool =
"v2v_libvirt_domain_exists"
+
+external get_uri : conn -> string = "v2v_libvirt_get_uri"
 
 external libvirt_get_version : unit -> int * int * int
   = "v2v_libvirt_get_version"
diff --git a/v2v/libvirt_utils.mli b/v2v/libvirt_utils.mli
index 53dfd48e5..11a83b9a2 100644
--- a/v2v/libvirt_utils.mli
+++ b/v2v/libvirt_utils.mli
@@ -24,32 +24,42 @@
     password prompt to stdout, which is the same place we would be
     reading the XML from.  This file works around this brokenness. *)
 
-val dumpxml : ?password:string -> ?conn:string -> string -> string
-(** [dumpxml ?password ?conn dom] returns the libvirt XML of domain [dom].
-    The optional [?conn] parameter is the libvirt connection URI.
+type conn
+(** The type of a compiled regular expression. *)
+
+val connect_ro : ?conn:string -> unit -> conn
+(** Connect in read-only mode to the specified URI. *)
+
+val connect_rw : ?password:string -> ?conn:string -> unit -> conn
+(** Connect in read-only mode to the specified URI. *)
+
+val dumpxml : conn -> string -> string
+(** [dumpxml conn dom] returns the libvirt XML of domain [dom]
+    in the libvirt connection [conn].
     [dom] may be a guest name or UUID. *)
 
-val pool_dumpxml : ?conn:string -> string -> string
-(** [pool_dumpxml ?conn pool] returns the libvirt XML of pool [pool].
-    The optional [?conn] parameter is the libvirt connection URI.
+val pool_dumpxml : conn -> string -> string
+(** [pool_dumpxml ?conn pool] returns the libvirt XML of pool [pool]
+    in the libvirt connection [conn].
     [pool] may be a pool name or UUID. *)
 
-val vol_dumpxml : ?conn:string -> string -> string -> string
-(** [vol_dumpxml ?conn pool vol] returns the libvirt XML of volume [vol],
-    which is part of the pool [pool].
-    The optional [?conn] parameter is the libvirt connection URI.
+val vol_dumpxml : conn -> string -> string -> string
+(** [vol_dumpxml conn pool vol] returns the libvirt XML of volume [vol],
+    which is part of the pool [pool], in the libvirt connection [conn].
     [pool] may be a pool name or UUID. *)
 
-val capabilities : ?conn:string -> unit -> string
-(** [capabilities ?conn ()] returns the libvirt capabilities XML.
-    The optional [?conn] parameter is the libvirt connection URI. *)
+val capabilities : conn -> string
+(** [capabilities conn] returns the libvirt capabilities XML
+    of the libvirt connection [conn]. *)
 
-val domain_exists : ?conn:string -> string -> bool
-(** [domain_exists ?conn dom] returns a boolean indicating if the
-    the libvirt XML domain [dom] exists.
-    The optional [?conn] parameter is the libvirt connection URI.
+val domain_exists : conn -> string -> bool
+(** [domain_exists conn dom] returns a boolean indicating if the
+    the libvirt XML domain [dom] exists in the libvirt connection [conn].
     [dom] may be a guest name, but not a UUID. *)
 
+val get_uri : conn -> string
+(** [get_uri conn] returns the URI of the libvirt connection [conn]. *)
+
 val libvirt_get_version : unit -> int * int * int
 (** [libvirt_get_version] returns the triple [(major, minor, release)]
     version number of the libvirt library that we are linked against. *)
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index b5df8245f..e00cac24b 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -78,8 +78,10 @@ class output_libvirt oc output_pool = object
     | Some uri -> sprintf "-o libvirt -oc %s -os %s" uri
output_pool
 
   method prepare_targets source targets +    let conn =
Libvirt_utils.connect_ro ?conn:oc () in
+
     (* Get the capabilities from libvirt. *)
-    let xml = Libvirt_utils.capabilities ?conn:oc () in
+    let xml = Libvirt_utils.capabilities conn in
     debug "libvirt capabilities XML:\n%s" xml;
 
     (* This just checks that the capabilities XML is well-formed,
@@ -94,7 +96,7 @@ class output_libvirt oc output_pool = object
     capabilities_doc <- Some doc;
 
     (* Does the domain already exist on the target?  (RHBZ#889082) *)
-    if Libvirt_utils.domain_exists ?conn:oc source.s_name then (
+    if Libvirt_utils.domain_exists conn source.s_name then (
       if source.s_hypervisor = Physical then (* virt-p2v user *)
         error (f_"a libvirt domain called ‘%s’ already exists on the
target.\n\nIf using virt-p2v, select a different ‘Name’ in the ‘Target
properties’. Or delete the existing domain on the target using the ‘virsh
undefine’ command.")
               source.s_name
@@ -106,7 +108,7 @@ class output_libvirt oc output_pool = object
     (* Connect to output libvirt instance and check that the pool exists
      * and dump out its XML.
      *)
-    let xml = Libvirt_utils.pool_dumpxml ?conn:oc output_pool in
+    let xml = Libvirt_utils.pool_dumpxml conn output_pool in
     let doc = Xml.parse_memory xml in
     let xpathctx = Xml.xpath_new_context doc in
     let xpath_string = xpath_string xpathctx in
diff --git a/v2v/parse_libvirt_xml.ml b/v2v/parse_libvirt_xml.ml
index c71707000..e3260c429 100644
--- a/v2v/parse_libvirt_xml.ml
+++ b/v2v/parse_libvirt_xml.ml
@@ -71,7 +71,7 @@ let create_curl_qemu_uri driver host port path    (* Turn the
JSON parameters into a 'json:' protocol string. *)
   "json: " ^ JSON.string_of_doc json_params
 
-let parse_libvirt_xml ?conn xml +let parse_libvirt_xml conn xml    debug
"libvirt xml is:\n%s" xml;
 
   let doc = Xml.parse_memory xml in
@@ -328,7 +328,7 @@ let parse_libvirt_xml ?conn xml          (match xpath_string
"source/@pool", xpath_string "source/@volume" with
         | None, None | Some _, None | None, Some _ -> ()
         | Some pool, Some vol ->
-          let xml = Libvirt_utils.vol_dumpxml ?conn pool vol in
+          let xml = Libvirt_utils.vol_dumpxml conn pool vol in
           let doc = Xml.parse_memory xml in
           let xpathctx = Xml.xpath_new_context doc in
           let xpath_string = Xpath_helpers.xpath_string xpathctx in
diff --git a/v2v/parse_libvirt_xml.mli b/v2v/parse_libvirt_xml.mli
index 3d4f7b375..1f2a5056e 100644
--- a/v2v/parse_libvirt_xml.mli
+++ b/v2v/parse_libvirt_xml.mli
@@ -27,7 +27,7 @@ and parsed_source  | P_source_file of string            (**
<source file> *)
 | P_dont_rewrite                     (** s_qemu_uri is already set. *)
 
-val parse_libvirt_xml : ?conn:string -> string -> Types.source *
parsed_disk list
+val parse_libvirt_xml : Libvirt_utils.conn -> string -> Types.source *
parsed_disk list
 (** Take libvirt XML and parse it into a {!Types.source} structure and a
     list of source disks.
 
-- 
2.13.5

On Fri, Sep 08, 2017 at 05:44:17PM +0200, Pino Toscano
wrote:
> diff --git a/v2v/libvirt_utils.mli b/v2v/libvirt_utils.mli
> index 53dfd48e5..11a83b9a2 100644
> --- a/v2v/libvirt_utils.mli
> +++ b/v2v/libvirt_utils.mli
> @@ -24,32 +24,42 @@
>      password prompt to stdout, which is the same place we would be
>      reading the XML from.  This file works around this brokenness. *)
>  
> -val dumpxml : ?password:string -> ?conn:string -> string ->
string
> -(** [dumpxml ?password ?conn dom] returns the libvirt XML of domain [dom].
> -    The optional [?conn] parameter is the libvirt connection URI.
> +type conn
> +(** The type of a compiled regular expression. *)
> +
> +val connect_ro : ?conn:string -> unit -> conn
> +(** Connect in read-only mode to the specified URI. *)
> +
> +val connect_rw : ?password:string -> ?conn:string -> unit -> conn
> +(** Connect in read-only mode to the specified URI. *)
^                 read-write mode

It's not exactly obvious, but read-write connections only need to be
used if you're going to call this function.  A read-only connection
will not return passwords in the XML ...
> +val dumpxml : conn -> string -> string
> +(** [dumpxml conn dom] returns the libvirt XML of domain [dom]
> +    in the libvirt connection [conn].
>      [dom] may be a guest name or UUID. *)
... because for libvirt "read-write" connection means
"secure" or
something.

Anyway, in the ocaml-libvirt bindings we use phantom types to
statically ensure that the right sort of connection is used, and it
would be worth doing the same thing here.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-df lists disk usage of guests without needing to install any
software inside the virtual machine.  Supports Linux and Windows.
http://people.redhat.com/~rjones/virt-df/

In fact thinking about this a bit more, it could be worth having
‘[`Readonly] conn’ and ‘[`Readonly|`Secure] conn’ phantom types.  Then
you would have two variants dumpxml and dumpxml_secure depending on
whether secure data was required in the output.  Existing callers
would need to be checked to see if they really need the secure data
(at the moment it seems they get it whether they need it or not).

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-top is 'top' for virtual machines.  Tiny program with many
powerful monitoring features, net stats, disk stats, logging, etc.
http://people.redhat.com/~rjones/virt-top