Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 0/8] v2v: Move Curl wrapper to mllib and use it for virt-builder (and more).
v1 -> v2: - Fixed the bug with precedence of if / @. - Add some imperative list operators inspired by Perl, and use those for constructing the Curl arguments, and more. Rich.
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 1/8] v2v: Move Curl wrapper to mllib.
Just code motion, no change.
---
mllib/Makefile.am | 4 +++-
mllib/curl.ml | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
mllib/curl.mli | 38 +++++++++++++++++++++++++++++++++
po/POTFILES-ml | 2 +-
v2v/Makefile.am | 5 ++---
v2v/curl.ml | 64 -------------------------------------------------------
v2v/curl.mli | 38 ---------------------------------
7 files changed, 108 insertions(+), 107 deletions(-)
create mode 100644 mllib/curl.ml
create mode 100644 mllib/curl.mli
delete mode 100644 v2v/curl.ml
delete mode 100644 v2v/curl.mli
diff --git a/mllib/Makefile.am b/mllib/Makefile.am
index 10bbebf..e728d54 100644
--- a/mllib/Makefile.am
+++ b/mllib/Makefile.am
@@ -28,6 +28,7 @@ CLEANFILES = *~ *.annot *.cmi *.cmo *.cmx *.cmxa *.o
SOURCES_MLI = \
common_utils.mli \
+ curl.mli \
dev_t.mli \
fsync.mli \
JSON.mli \
@@ -52,7 +53,8 @@ SOURCES_ML = \
planner.ml \
regedit.ml \
StatVFS.ml \
- JSON.ml
+ JSON.ml \
+ curl.ml
SOURCES_C = \
../fish/progress.c \
diff --git a/mllib/curl.ml b/mllib/curl.ml
new file mode 100644
index 0000000..f0af160
--- /dev/null
+++ b/mllib/curl.ml
@@ -0,0 +1,64 @@
+(* virt-v2v
+ * Copyright (C) 2009-2016 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+
+open Common_utils
+
+type curl_args = (string * string option) list
+
+let run curl_args + let config_file, chan = Filename.open_temp_file
"v2vcurl" ".conf" in
+ List.iter (
+ function
+ | name, None -> fprintf chan "%s\n" name
+ | name, Some value ->
+ fprintf chan "%s = \"" name;
+ (* Write the quoted value. See 'curl' man page for what is
+ * allowed here.
+ *)
+ let len = String.length value in
+ for i = 0 to len-1 do
+ match value.[i] with
+ | '\\' -> output_string chan "\\\\"
+ | '"' -> output_string chan "\\\""
+ | '\t' -> output_string chan "\\t"
+ | '\n' -> output_string chan "\\n"
+ | '\r' -> output_string chan "\\r"
+ | '\x0b' -> output_string chan "\\v"
+ | c -> output_char chan c
+ done;
+ fprintf chan "\"\n"
+ ) curl_args;
+ close_out chan;
+
+ let cmd = sprintf "curl -q --config %s" (Filename.quote
config_file) in
+ let lines = external_command ~echo_cmd:false cmd in
+ Unix.unlink config_file;
+ lines
+
+let print_curl_command chan curl_args + fprintf chan "curl -q";
+ List.iter (
+ function
+ | name, None -> fprintf chan " --%s" name
+ (* Don't print passwords in the debug output. *)
+ | "user", Some _ -> fprintf chan " --user
<hidden>"
+ | name, Some value -> fprintf chan " --%s %s" name
(Filename.quote value)
+ ) curl_args;
+ fprintf chan "\n";
diff --git a/mllib/curl.mli b/mllib/curl.mli
new file mode 100644
index 0000000..cd01497
--- /dev/null
+++ b/mllib/curl.mli
@@ -0,0 +1,38 @@
+(* virt-v2v
+ * Copyright (C) 2009-2016 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** Functions for dealing with [curl]. *)
+
+type curl_args = (string * string option) list
+
+val run : curl_args -> string list
+(** [run curl_args] runs the [curl] command.
+
+ It actually uses the [curl --config] option to pass the arguments
+ securely to curl through an external file. Thus passwords etc are
+ not exposed to other users on the same machine.
+
+ The curl arguments are a list of key, value pairs corresponding
+ to curl command line parameters, without leading dashes,
+ eg. [("user", Some "user:password")].
+
+ The result is the output of curl as a list of lines. *)
+
+val print_curl_command : out_channel -> curl_args -> unit
+(** Print the curl command line. This elides any arguments that
+ might contain passwords, so is useful for debugging. *)
diff --git a/po/POTFILES-ml b/po/POTFILES-ml
index f6bade1..5937ff5 100644
--- a/po/POTFILES-ml
+++ b/po/POTFILES-ml
@@ -43,6 +43,7 @@ mllib/URI.ml
mllib/common_gettext.ml
mllib/common_utils.ml
mllib/common_utils_tests.ml
+mllib/curl.ml
mllib/dev_t.ml
mllib/fsync.ml
mllib/guestfs_config.ml
@@ -104,7 +105,6 @@ v2v/cmdline.ml
v2v/convert_linux.ml
v2v/convert_windows.ml
v2v/copy_to_local.ml
-v2v/curl.ml
v2v/domainxml.ml
v2v/input_disk.ml
v2v/input_libvirt.ml
diff --git a/v2v/Makefile.am b/v2v/Makefile.am
index 05f4611..fedc84d 100644
--- a/v2v/Makefile.am
+++ b/v2v/Makefile.am
@@ -31,7 +31,6 @@ SOURCES_MLI = \
cmdline.mli \
convert_linux.mli \
convert_windows.mli \
- curl.mli \
DOM.mli \
domainxml.mli \
input_disk.mli \
@@ -66,7 +65,6 @@ SOURCES_ML = \
types.ml \
xml.ml \
utils.ml \
- curl.ml \
vCenter.ml \
domainxml.ml \
DOM.ml \
@@ -131,6 +129,7 @@ BOBJECTS = \
$(top_builddir)/mllib/mkdtemp.cmo \
$(top_builddir)/mllib/JSON.cmo \
$(top_builddir)/mllib/StatVFS.cmo \
+ $(top_builddir)/mllib/curl.cmo \
$(top_builddir)/customize/customize_utils.cmo \
$(top_builddir)/customize/firstboot.cmo \
$(SOURCES_ML:.ml=.cmo)
@@ -199,9 +198,9 @@ COPY_TO_LOCAL_BOBJECTS = \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/JSON.cmo \
$(top_builddir)/mllib/StatVFS.cmo \
+ $(top_builddir)/mllib/curl.cmo \
xml.cmo \
utils.cmo \
- curl.cmo \
vCenter.cmo \
domainxml.cmo \
copy_to_local.cmo
diff --git a/v2v/curl.ml b/v2v/curl.ml
deleted file mode 100644
index f0af160..0000000
--- a/v2v/curl.ml
+++ /dev/null
@@ -1,64 +0,0 @@
-(* virt-v2v
- * Copyright (C) 2009-2016 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-open Printf
-
-open Common_utils
-
-type curl_args = (string * string option) list
-
-let run curl_args - let config_file, chan = Filename.open_temp_file
"v2vcurl" ".conf" in
- List.iter (
- function
- | name, None -> fprintf chan "%s\n" name
- | name, Some value ->
- fprintf chan "%s = \"" name;
- (* Write the quoted value. See 'curl' man page for what is
- * allowed here.
- *)
- let len = String.length value in
- for i = 0 to len-1 do
- match value.[i] with
- | '\\' -> output_string chan "\\\\"
- | '"' -> output_string chan "\\\""
- | '\t' -> output_string chan "\\t"
- | '\n' -> output_string chan "\\n"
- | '\r' -> output_string chan "\\r"
- | '\x0b' -> output_string chan "\\v"
- | c -> output_char chan c
- done;
- fprintf chan "\"\n"
- ) curl_args;
- close_out chan;
-
- let cmd = sprintf "curl -q --config %s" (Filename.quote
config_file) in
- let lines = external_command ~echo_cmd:false cmd in
- Unix.unlink config_file;
- lines
-
-let print_curl_command chan curl_args - fprintf chan "curl -q";
- List.iter (
- function
- | name, None -> fprintf chan " --%s" name
- (* Don't print passwords in the debug output. *)
- | "user", Some _ -> fprintf chan " --user
<hidden>"
- | name, Some value -> fprintf chan " --%s %s" name
(Filename.quote value)
- ) curl_args;
- fprintf chan "\n";
diff --git a/v2v/curl.mli b/v2v/curl.mli
deleted file mode 100644
index cd01497..0000000
--- a/v2v/curl.mli
+++ /dev/null
@@ -1,38 +0,0 @@
-(* virt-v2v
- * Copyright (C) 2009-2016 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-(** Functions for dealing with [curl]. *)
-
-type curl_args = (string * string option) list
-
-val run : curl_args -> string list
-(** [run curl_args] runs the [curl] command.
-
- It actually uses the [curl --config] option to pass the arguments
- securely to curl through an external file. Thus passwords etc are
- not exposed to other users on the same machine.
-
- The curl arguments are a list of key, value pairs corresponding
- to curl command line parameters, without leading dashes,
- eg. [("user", Some "user:password")].
-
- The result is the output of curl as a list of lines. *)
-
-val print_curl_command : out_channel -> curl_args -> unit
-(** Print the curl command line. This elides any arguments that
- might contain passwords, so is useful for debugging. *)
--
2.7.4
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 2/8] curl: Change the API to use an abstract data type.
Change the Curl module to use an ADT to store the name of the curl
binary and the arguments.
Also add Curl.safe_args, a list of arguments that control redirects etc.
The callers in virt-v2v are changed accordingly.
There is also a (currently unused) args_of_proxy function allowing
proxy parameters to be set.
---
mllib/curl.ml | 48 ++++++++++++++++++++++++++++++-----------
mllib/curl.mli | 60 ++++++++++++++++++++++++++++++++++++++++++++--------
v2v/copy_to_local.ml | 14 ++++++------
v2v/vCenter.ml | 16 ++++++++------
4 files changed, 104 insertions(+), 34 deletions(-)
diff --git a/mllib/curl.ml b/mllib/curl.ml
index f0af160..a684fdb 100644
--- a/mllib/curl.ml
+++ b/mllib/curl.ml
@@ -20,10 +20,19 @@ open Printf
open Common_utils
-type curl_args = (string * string option) list
+let quote = Filename.quote
-let run curl_args - let config_file, chan = Filename.open_temp_file
"v2vcurl" ".conf" in
+type t = {
+ curl : string;
+ args : args;
+}
+and args = (string * string option) list
+
+let create ?(curl = "curl") args + { curl = curl; args = args }
+
+let run { curl = curl; args = args } + let config_file, chan =
Filename.open_temp_file "curl" ".conf" in
List.iter (
function
| name, None -> fprintf chan "%s\n" name
@@ -44,21 +53,36 @@ let run curl_args | c -> output_char chan c
done;
fprintf chan "\"\n"
- ) curl_args;
+ ) args;
close_out chan;
- let cmd = sprintf "curl -q --config %s" (Filename.quote
config_file) in
+ let cmd = sprintf "%s -q --config %s" (quote curl) (quote
config_file) in
let lines = external_command ~echo_cmd:false cmd in
Unix.unlink config_file;
lines
-let print_curl_command chan curl_args - fprintf chan "curl -q";
+let to_string { curl = curl; args = args } + let b = Buffer.create 128 in
+ bprintf b "%s -q" (quote curl);
List.iter (
function
- | name, None -> fprintf chan " --%s" name
+ | name, None -> bprintf b " --%s" name
(* Don't print passwords in the debug output. *)
- | "user", Some _ -> fprintf chan " --user
<hidden>"
- | name, Some value -> fprintf chan " --%s %s" name
(Filename.quote value)
- ) curl_args;
- fprintf chan "\n";
+ | "user", Some _ -> bprintf b " --user
<hidden>"
+ | name, Some value -> bprintf b " --%s %s" name (quote value)
+ ) args;
+ bprintf b "\n";
+ Buffer.contents b
+
+let print chan t = output_string chan (to_string t)
+
+type proxy = UnsetProxy | ForcedProxy of string
+
+let args_of_proxy = function
+ | UnsetProxy -> [ "proxy", Some "" ;
"noproxy", Some "*" ]
+ | ForcedProxy url -> [ "proxy", Some url; "noproxy",
Some "" ]
+
+let safe_args = [
+ "max-redirs", Some "5";
+ "globoff", None; (* Don't glob URLs. *)
+]
diff --git a/mllib/curl.mli b/mllib/curl.mli
index cd01497..31927e5 100644
--- a/mllib/curl.mli
+++ b/mllib/curl.mli
@@ -18,21 +18,63 @@
(** Functions for dealing with [curl]. *)
-type curl_args = (string * string option) list
+type t
-val run : curl_args -> string list
-(** [run curl_args] runs the [curl] command.
+type args = (string * string option) list
- It actually uses the [curl --config] option to pass the arguments
- securely to curl through an external file. Thus passwords etc are
- not exposed to other users on the same machine.
+val create : ?curl:string -> args -> t
+(** Create a curl command handle.
The curl arguments are a list of key, value pairs corresponding
to curl command line parameters, without leading dashes,
eg. [("user", Some "user:password")].
+ The optional [?curl] parameter controls the name of the curl
+ binary (default ["curl"]). *)
+
+val run : t -> string list
+(** [run t] runs previously constructed the curl command.
+
+ It actually uses the [curl --config] option to pass the arguments
+ securely to curl through an external file. Thus passwords etc are
+ not exposed to other users on the same machine.
+
The result is the output of curl as a list of lines. *)
-val print_curl_command : out_channel -> curl_args -> unit
-(** Print the curl command line. This elides any arguments that
- might contain passwords, so is useful for debugging. *)
+val to_string : t -> string
+(** Convert the curl command line to a string.
+
+ This elides any arguments that might contain passwords, so is
+ useful for debugging. *)
+
+val print : out_channel -> t -> unit
+(** Print the curl command line.
+
+ This elides any arguments that might contain passwords, so is
+ useful for debugging. *)
+
+type proxy + | UnsetProxy (** The proxy is forced off. *)
+ | ForcedProxy of string (** The proxy is forced to the specified URL. *)
+
+val args_of_proxy : proxy -> args
+(** Convert the proxy setting to the equivalent list of curl arguments.
+
+ To use the system proxy, no additional arguments are required, so
+ if you don't want to control the proxy (but just use the defaults)
+ you do not need to call this function at all.
+
+ Callers should append these arguments to the list of arguments
+ passed to {!create}. *)
+
+val safe_args : args
+(** This returns a list of safe arguments which can (and probably should)
+ be added to any list of arguments passed to {!create}.
+
+ Currently this list includes:
+
+ - Only follow 3XX redirects up to 5 times.
+ - Disable URL globbing.
+
+ Note this does {b not} enable redirects. If you want to follow
+ redirects you have to add the ["location"] parameter. *)
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index 717ba50..d791293 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -198,10 +198,11 @@ read the man page virt-v2v-copy-to-local(1).
error (f_"ssh copy command failed, see earlier errors");
| ESXi _ ->
- let curl_args = [
- "url", Some remote_disk;
- "output", Some local_disk;
- ] in
+ let curl_args + Curl.safe_args @ [
+ "url", Some remote_disk;
+ "output", Some local_disk;
+ ] in
let curl_args if sslverify then curl_args
else ("insecure", None) :: curl_args in
@@ -213,9 +214,10 @@ read the man page virt-v2v-copy-to-local(1).
if quiet () then ("silent", None) :: curl_args
else curl_args in
+ let curl_h = Curl.create curl_args in
if verbose () then
- Curl.print_curl_command stderr curl_args;
- ignore (Curl.run curl_args)
+ Curl.print stderr curl_h;
+ ignore (Curl.run curl_h)
| Test ->
let cmd = [ "cp"; remote_disk; local_disk ] in
diff --git a/v2v/vCenter.ml b/v2v/vCenter.ml
index d41f223..dbfdf1a 100644
--- a/v2v/vCenter.ml
+++ b/v2v/vCenter.ml
@@ -45,11 +45,12 @@ let get_session_cookie password scheme uri sslverify url
if !session_cookie <> "" then
Some !session_cookie
else (
- let curl_args = [
- "head", None;
- "silent", None;
- "url", Some url;
- ] in
+ let curl_args + Curl.safe_args @ [
+ "head", None;
+ "silent", None;
+ "url", Some url;
+ ] in
let curl_args match uri.uri_user, password with
| None, None -> curl_args
@@ -63,10 +64,11 @@ let get_session_cookie password scheme uri sslverify url
let curl_args if not sslverify then ("insecure", None) ::
curl_args else curl_args in
- let lines = Curl.run curl_args in
+ let curl_h = Curl.create curl_args in
+ let lines = Curl.run curl_h in
let dump_response chan - Curl.print_curl_command chan curl_args;
+ Curl.print chan curl_h;
(* Dump out the output of the command. *)
List.iter (fun x -> fprintf chan "%s\n" x) lines;
--
2.7.4
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 3/8] builder: Use the new Curl module for passing parameters to curl.
These are now passed using a curl configuration file, which is a
little bit safer than using command lines. virt-builder doesn't need
to pass usernames and passwords to curl, but if it ever does in future
this will be a lot safer.
---
builder/Makefile.am | 1 +
builder/builder.ml | 6 +--
builder/downloader.ml | 94 +++++++++++++++++++++--------------------
builder/downloader.mli | 10 +----
builder/index.ml | 2 +-
builder/index.mli | 2 +-
builder/index_parser.ml | 2 +-
builder/simplestreams_parser.ml | 2 +-
builder/sources.ml | 10 ++---
builder/sources.mli | 2 +-
10 files changed, 63 insertions(+), 68 deletions(-)
diff --git a/builder/Makefile.am b/builder/Makefile.am
index ad32940..5c41cfa 100644
--- a/builder/Makefile.am
+++ b/builder/Makefile.am
@@ -144,6 +144,7 @@ BOBJECTS = \
$(top_builddir)/mllib/JSON.cmo \
$(top_builddir)/mllib/URI.cmo \
$(top_builddir)/mllib/mkdtemp.cmo \
+ $(top_builddir)/mllib/curl.cmo \
$(top_builddir)/customize/customize_utils.cmo \
$(top_builddir)/customize/urandom.cmo \
$(top_builddir)/customize/random_seed.cmo \
diff --git a/builder/builder.ml b/builder/builder.ml
index affce10..e95fcd1 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -185,7 +185,7 @@ let main () {
Sources.name = source; uri = source;
gpgkey = Utils.Fingerprint fingerprint;
- proxy = Downloader.SystemProxy;
+ proxy = None;
format = Sources.FormatNative;
}
) cmdline.sources in
@@ -249,7 +249,7 @@ let main () message (f_"Downloading:
%s") file_uri;
let progress_bar = not (quiet ()) in
ignore (Downloader.download downloader ~template ~progress_bar
- ~proxy file_uri)
+ ?proxy file_uri)
) index;
exit 0
);
@@ -297,7 +297,7 @@ let main () let template = arg, cmdline.arch,
revision in
message (f_"Downloading: %s") file_uri;
let progress_bar = not (quiet ()) in
- Downloader.download downloader ~template ~progress_bar ~proxy
+ Downloader.download downloader ~template ~progress_bar ?proxy
file_uri in
if delete_on_exit then unlink_on_exit template;
template in
diff --git a/builder/downloader.ml b/builder/downloader.ml
index 8c47bad..382981c 100644
--- a/builder/downloader.ml
+++ b/builder/downloader.ml
@@ -32,29 +32,24 @@ type t = {
cache : Cache.t option; (* cache for templates *)
}
-type proxy_mode - | UnsetProxy
- | SystemProxy
- | ForcedProxy of string
-
let create ~curl ~cache = {
curl = curl;
cache = cache;
}
-let rec download t ?template ?progress_bar ?(proxy = SystemProxy) uri +let rec
download t ?template ?progress_bar ?proxy uri match template with
| None -> (* no cache, simple download *)
(* Create a temporary name. *)
let tmpfile = Filename.temp_file "vbcache" ".txt" in
- download_to t ?progress_bar ~proxy uri tmpfile;
+ download_to t ?progress_bar ?proxy uri tmpfile;
(tmpfile, true)
| Some (name, arch, revision) ->
match t.cache with
| None ->
(* Not using the cache at all? *)
- download t ?progress_bar ~proxy uri
+ download t ?progress_bar ?proxy uri
| Some cache ->
let filename = Cache.cache_of_name cache name arch revision in
@@ -63,11 +58,11 @@ let rec download t ?template ?progress_bar ?(proxy =
SystemProxy) uri * If not, download it.
*)
if not (Sys.file_exists filename) then
- download_to t ?progress_bar ~proxy uri filename;
+ download_to t ?progress_bar ?proxy uri filename;
(filename, false)
-and download_to t ?(progress_bar = false) ~proxy uri filename +and download_to
t ?(progress_bar = false) ?proxy uri filename let parseduri try
URI.parse_uri uri
with Invalid_argument "URI.parse_uri" ->
@@ -83,6 +78,7 @@ and download_to t ?(progress_bar = false) ~proxy uri filename
unlink_on_exit filename_new;
(match parseduri.URI.protocol with
+ (* Download (ie. copy) from a local file. *)
| "file" ->
let path = parseduri.URI.path in
let cmd = [ "cp" ] @
@@ -91,15 +87,33 @@ and download_to t ?(progress_bar = false) ~proxy uri
filename let r = run_command cmd in
if r <> 0 then
error (f_"cp (download) command failed copying '%s'")
path;
- | _ as protocol -> (* Any other protocol. *)
- let outenv = proxy_envvar protocol proxy in
+
+ (* Any other protocol. *)
+ | _ ->
+ let common_args + Curl.safe_args @
+ [ "location", None ] @ (* Follow 3XX redirects. *)
+ match proxy with
+ | None (* system proxy settings *) -> []
+ | Some proxy -> Curl.args_of_proxy proxy in
+
+ let quiet_args = [ "silent", None; "show-error", None ]
in
+
(* Get the status code first to ensure the file exists. *)
- let cmd = sprintf "%s%s%s -L --max-redirs 5 -g -o /dev/null -I -w
'%%{http_code}' %s"
- outenv
- t.curl
- (if verbose () then "" else " -s -S")
- (quote uri) in
- let lines = external_command cmd in
+ let curl_h + let curl_args + common_args @
+ (if verbose () then [] else quiet_args) @ [
+ "output", Some "/dev/null"; (* Write output to
/dev/null. *)
+ "head", None; (* Request only HEAD. *)
+ (* Write HTTP status code to stdout. *)
+ "write-out", Some "%{http_code}";
+ "url", Some uri
+ ] in
+
+ Curl.create ~curl:t.curl curl_args in
+
+ let lines = Curl.run curl_h in
if List.length lines < 1 then
error (f_"unexpected output from curl command, enable debug and look
at previous messages");
let status_code = List.hd lines in
@@ -113,35 +127,23 @@ and download_to t ?(progress_bar = false) ~proxy uri
filename error (f_"failed to download %s: HTTP status code %s")
uri status_code;
(* Now download the file. *)
- let cmd = sprintf "%s%s%s -L --max-redirs 5 -g -o %s %s"
- outenv
- t.curl
- (if verbose () then "" else if progress_bar then "
-#" else " -s -S")
- (quote filename_new) (quote uri) in
- let r = shell_command cmd in
- if r <> 0 then
- error (f_"curl (download) command failed downloading
'%s'") uri;
+ let curl_h + let curl_args + common_args @ [
+ "output", Some filename_new;
+ "url", Some uri
+ ] in
+
+ let curl_args + curl_args @
+ if verbose () then []
+ else if progress_bar then [ "progress-bar", None ]
+ else quiet_args in
+
+ Curl.create ~curl:t.curl curl_args in
+
+ ignore (Curl.run curl_h)
);
(* Rename the file if the download was successful. *)
rename filename_new filename
-
-and proxy_envvar protocol = function
- | UnsetProxy ->
- (match protocol with
- | "http" -> "env http_proxy= no_proxy=* "
- | "https" -> "env https_proxy= no_proxy=* "
- | "ftp" -> "env ftp_proxy= no_proxy=* "
- | _ -> "env no_proxy=* "
- )
- | SystemProxy ->
- (* No changes required. *)
- ""
- | ForcedProxy proxy ->
- let proxy = quote proxy in
- (match protocol with
- | "http" -> sprintf "env http_proxy=%s no_proxy= "
proxy
- | "https" -> sprintf "env https_proxy=%s no_proxy= "
proxy
- | "ftp" -> sprintf "env ftp_proxy=%s no_proxy= "
proxy
- | _ -> ""
- )
diff --git a/builder/downloader.mli b/builder/downloader.mli
index 11ec498..c99aee2 100644
--- a/builder/downloader.mli
+++ b/builder/downloader.mli
@@ -24,18 +24,10 @@ type filename = string
type t
(** The abstract data type. *)
-(** Type of proxy. *)
-type proxy_mode - | UnsetProxy (* The proxy is forced off. *)
- | SystemProxy (* The proxy is not changed (follows the
- * system configuration).
- *)
- | ForcedProxy of string (* The proxy is forced to the specified URL. *)
-
val create : curl:string -> cache:Cache.t option -> t
(** Create the abstract type. *)
-val download : t -> ?template:(string*string*Utils.revision) ->
?progress_bar:bool -> ?proxy:proxy_mode -> uri -> (filename * bool)
+val download : t -> ?template:(string*string*Utils.revision) ->
?progress_bar:bool -> ?proxy:Curl.proxy -> uri -> (filename * bool)
(** Download the URI, returning the downloaded filename and a
temporary file flag. The temporary file flag is [true] iff
the downloaded file is temporary and should be deleted by the
diff --git a/builder/index.ml b/builder/index.ml
index 01b4a5f..fa3c34a 100644
--- a/builder/index.ml
+++ b/builder/index.ml
@@ -43,7 +43,7 @@ and entry = {
aliases : string list option;
sigchecker : Sigchecker.t;
- proxy : Downloader.proxy_mode;
+ proxy : Curl.proxy option;
}
let print_entry chan (name, { printable_name = printable_name;
diff --git a/builder/index.mli b/builder/index.mli
index 07cfb9d..8a93ba8 100644
--- a/builder/index.mli
+++ b/builder/index.mli
@@ -35,7 +35,7 @@ and entry = {
aliases : string list option;
sigchecker : Sigchecker.t;
- proxy : Downloader.proxy_mode;
+ proxy : Curl.proxy option;
}
val print_entry : out_channel -> (string * entry) -> unit
diff --git a/builder/index_parser.ml b/builder/index_parser.ml
index d232a3a..4ac66c0 100644
--- a/builder/index_parser.ml
+++ b/builder/index_parser.ml
@@ -32,7 +32,7 @@ let get_index ~downloader ~sigchecker
let rec get_index () (* Get the index page. *)
- let tmpfile, delete_tmpfile = Downloader.download downloader ~proxy uri in
+ let tmpfile, delete_tmpfile = Downloader.download downloader ?proxy uri in
(* Check index file signature (also verifies it was fully
* downloaded and not corrupted in transit).
diff --git a/builder/simplestreams_parser.ml b/builder/simplestreams_parser.ml
index 13e0b5d..808b121 100644
--- a/builder/simplestreams_parser.ml
+++ b/builder/simplestreams_parser.ml
@@ -86,7 +86,7 @@ let get_index ~downloader ~sigchecker
let uri = ensure_trailing_slash uri in
let download_and_parse uri - let tmpfile, delete_tmpfile =
Downloader.download downloader ~proxy uri in
+ let tmpfile, delete_tmpfile = Downloader.download downloader ?proxy uri in
if delete_tmpfile then
unlink_on_exit tmpfile;
let file diff --git a/builder/sources.ml b/builder/sources.ml
index 4c8d6c7..9255702 100644
--- a/builder/sources.ml
+++ b/builder/sources.ml
@@ -26,7 +26,7 @@ type source = {
name : string;
uri : string;
gpgkey : Utils.gpgkey_type;
- proxy : Downloader.proxy_mode;
+ proxy : Curl.proxy option;
format : source_format;
}
and source_format @@ -67,12 +67,12 @@ let parse_conf file let proxy
try
(match (List.assoc ("proxy", None) fields) with
- | "no" | "off" -> Downloader.UnsetProxy
- | "system" -> Downloader.SystemProxy
- | _ as proxy -> Downloader.ForcedProxy proxy
+ | "no" | "off" -> Some Curl.UnsetProxy
+ | "system" -> None
+ | _ as proxy -> Some (Curl.ForcedProxy proxy)
)
with
- Not_found -> Downloader.SystemProxy in
+ Not_found -> None in
let format try
(match (List.assoc ("format", None) fields) with
diff --git a/builder/sources.mli b/builder/sources.mli
index e621a9f..d7f822e 100644
--- a/builder/sources.mli
+++ b/builder/sources.mli
@@ -20,7 +20,7 @@ type source = {
name : string;
uri : string;
gpgkey : Utils.gpgkey_type;
- proxy : Downloader.proxy_mode;
+ proxy : Curl.proxy option;
format : source_format;
}
and source_format --
2.7.4
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 4/8] mllib: Add some imperative list manipulation functions.
This adds imperative list manipulation functions inspired by Perl.
The functions are passed list refs which get updated in place.
This allows us to replace some awkward pure functional code like:
let xs = ys in
let xs = if foo then xs @ zs else xs in
with:
let xs = ref ys in
if foo then append xs zs;
---
mllib/common_utils.ml | 20 ++++++++++++++++++++
mllib/common_utils.mli | 37 +++++++++++++++++++++++++++++++++++++
2 files changed, 57 insertions(+)
diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index 77b9acd..40a19bc 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -282,6 +282,26 @@ let sort_uniq ?(cmp = Pervasives.compare) xs let xs =
uniq ~cmp xs in
xs
+let push xsp x = xsp := !xsp @ [x]
+let unshift x xsp = xsp := x :: !xsp
+let pop xsp + let x, xs + match List.rev !xsp with
+ | x :: xs -> x, xs
+ | [] -> failwith "pop" in
+ xsp := List.rev xs;
+ x
+let shift xsp + let x, xs + match !xsp with
+ | x :: xs -> x, xs
+ | [] -> failwith "shift" in
+ xsp := xs;
+ x
+
+let append xsp xs = xsp := !xsp @ xs
+let prepend xs xsp = xsp := xs @ !xsp
+
let may f = function
| None -> ()
| Some x -> f x
diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli
index 5b0b9bb..41994fa 100644
--- a/mllib/common_utils.mli
+++ b/mllib/common_utils.mli
@@ -141,6 +141,43 @@ val uniq : ?cmp:('a -> 'a -> int) ->
'a list -> 'a list
val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list ->
'a list
(** Sort and uniquify a list. *)
+val push : 'a list ref -> 'a -> unit
+val unshift : 'a -> 'a list ref -> unit
+val pop : 'a list ref -> 'a
+val shift : 'a list ref -> 'a
+(** Imperative list manipulation functions, similar to the Perl
+ functions described in http://perlmaven.com/manipulating-perl-arrays
+
+ These operate on list references, and each function modifies the
+ list reference that is passed to it.
+
+ [push xsp x] appends the element [x] to the end of the list [xsp].
+ This function is not tail-recursive.
+
+ [unshift x xsp] prepends the element [x] to the head of the list [xsp].
+ (The arguments are reversed compared to the same Perl function, but
+ OCaml is type safe so that's OK.)
+
+ [pop xsp] removes the last element of the list [xsp] and returns it.
+ The list is modified to become the list minus the final element.
+ If a zero-length list is passed in, this raises [Failure "pop"].
+ This function is not tail-recursive.
+
+ [shift xsp] removes the head element of the list [xsp] and returns it.
+ The list is modified to become the tail of the list. If a zero-length
+ list is passed in, this raises [Failure "shift"].
+ *)
+
+val append : 'a list ref -> 'a list -> unit
+val prepend : 'a list -> 'a list ref -> unit
+(** More imperative list manipulation functions.
+
+ [append] is like {!push} above, except it appends a list to
+ the list reference. This function is not tail-recursive.
+
+ [prepend] is like {!unshift} above, except it prepends a list
+ to the list reference. *)
+
val may : ('a -> unit) -> 'a option -> unit
(** [may f (Some x)] runs [f x]. [may f None] does nothing. *)
--
2.7.4
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 5/8] builder, v2v: Use imperative list functions to simplify curl arg code.
No functional change in this commit.
---
builder/downloader.ml | 40 +++++++++++++++++++---------------------
v2v/copy_to_local.ml | 28 ++++++++++++----------------
v2v/vCenter.ml | 36 +++++++++++++++++-------------------
3 files changed, 48 insertions(+), 56 deletions(-)
diff --git a/builder/downloader.ml b/builder/downloader.ml
index 382981c..1c7b086 100644
--- a/builder/downloader.ml
+++ b/builder/downloader.ml
@@ -101,17 +101,17 @@ and download_to t ?(progress_bar = false) ?proxy uri
filename
(* Get the status code first to ensure the file exists. *)
let curl_h - let curl_args - common_args @
- (if verbose () then [] else quiet_args) @ [
- "output", Some "/dev/null"; (* Write output to
/dev/null. *)
- "head", None; (* Request only HEAD. *)
- (* Write HTTP status code to stdout. *)
- "write-out", Some "%{http_code}";
- "url", Some uri
- ] in
+ let curl_args = ref common_args in
+ if not (verbose ()) then append curl_args quiet_args;
+ append curl_args [
+ "output", Some "/dev/null"; (* Write output to
/dev/null. *)
+ "head", None; (* Request only HEAD. *)
+ (* Write HTTP status code to stdout. *)
+ "write-out", Some "%{http_code}";
+ "url", Some uri
+ ];
- Curl.create ~curl:t.curl curl_args in
+ Curl.create ~curl:t.curl !curl_args in
let lines = Curl.run curl_h in
if List.length lines < 1 then
@@ -128,19 +128,17 @@ and download_to t ?(progress_bar = false) ?proxy uri
filename
(* Now download the file. *)
let curl_h - let curl_args - common_args @ [
- "output", Some filename_new;
- "url", Some uri
- ] in
+ let curl_args = ref common_args in
+ append curl_args [
+ "output", Some filename_new;
+ "url", Some uri
+ ];
- let curl_args - curl_args @
- if verbose () then []
- else if progress_bar then [ "progress-bar", None ]
- else quiet_args in
+ if verbose () then ()
+ else if progress_bar then push curl_args ("progress-bar", None)
+ else append curl_args quiet_args;
- Curl.create ~curl:t.curl curl_args in
+ Curl.create ~curl:t.curl !curl_args in
ignore (Curl.run curl_h)
);
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index d791293..24ed03f 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -198,23 +198,19 @@ read the man page virt-v2v-copy-to-local(1).
error (f_"ssh copy command failed, see earlier errors");
| ESXi _ ->
- let curl_args - Curl.safe_args @ [
- "url", Some remote_disk;
- "output", Some local_disk;
- ] in
- let curl_args - if sslverify then curl_args
- else ("insecure", None) :: curl_args in
- let curl_args - match cookie with
- | None -> curl_args
- | Some cookie -> ("cookie", Some cookie) :: curl_args in
- let curl_args - if quiet () then ("silent", None) ::
curl_args
- else curl_args in
+ let curl_args = ref Curl.safe_args in
+ append curl_args [
+ "url", Some remote_disk;
+ "output", Some local_disk;
+ ];
+ if not sslverify then push curl_args ("insecure", None);
+ (match cookie with
+ | None -> ()
+ | Some cookie -> push curl_args ("cookie", Some cookie)
+ );
+ if quiet () then push curl_args ("silent", None);
- let curl_h = Curl.create curl_args in
+ let curl_h = Curl.create !curl_args in
if verbose () then
Curl.print stderr curl_h;
ignore (Curl.run curl_h)
diff --git a/v2v/vCenter.ml b/v2v/vCenter.ml
index dbfdf1a..0fa3967 100644
--- a/v2v/vCenter.ml
+++ b/v2v/vCenter.ml
@@ -45,26 +45,24 @@ let get_session_cookie password scheme uri sslverify url
if !session_cookie <> "" then
Some !session_cookie
else (
- let curl_args - Curl.safe_args @ [
- "head", None;
- "silent", None;
- "url", Some url;
- ] in
- let curl_args - match uri.uri_user, password with
- | None, None -> curl_args
- | None, Some _ ->
- warning (f_"--password-file parameter ignored because
'user@' was not given in the URL");
- curl_args
- | Some user, None ->
- ("user", Some user) :: curl_args
- | Some user, Some password ->
- ("user", Some (user ^ ":" ^ password)) ::
curl_args in
- let curl_args - if not sslverify then ("insecure", None) ::
curl_args else curl_args in
+ let curl_args = ref Curl.safe_args in
+ append curl_args [
+ "head", None;
+ "silent", None;
+ "url", Some url;
+ ];
+ (match uri.uri_user, password with
+ | None, None -> ()
+ | None, Some _ ->
+ warning (f_"--password-file parameter ignored because
'user@' was not given in the URL")
+ | Some user, None ->
+ push curl_args ("user", Some user)
+ | Some user, Some password ->
+ push curl_args ("user", Some (user ^ ":" ^
password))
+ );
+ if not sslverify then push curl_args ("insecure", None);
- let curl_h = Curl.create curl_args in
+ let curl_h = Curl.create !curl_args in
let lines = Curl.run curl_h in
let dump_response chan --
2.7.4
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 6/8] Replace 'xs := x :: !xs' with 'unshift x xs'.
In one case, I used prepend instead.
---
builder/builder.ml | 2 +-
builder/cmdline.ml | 8 ++++----
builder/languages.ml | 6 +++---
builder/sigchecker.ml | 4 +---
customize/customize_main.ml | 4 ++--
dib/cmdline.ml | 17 ++++++-----------
generator/customize.ml | 20 ++++++++++----------
resize/resize.ml | 4 ++--
sparsify/cmdline.ml | 4 ++--
sysprep/main.ml | 2 +-
sysprep/sysprep_operation.ml | 4 ++--
sysprep/sysprep_operation_script.ml | 2 +-
v2v/cmdline.ml | 6 +++---
v2v/convert_linux.ml | 10 +++++-----
v2v/convert_windows.ml | 2 +-
v2v/copy_to_local.ml | 4 ++--
v2v/input_libvirtxml.ml | 11 ++++++-----
v2v/input_ova.ml | 6 +++---
v2v/modules_list.ml | 10 +++++-----
v2v/output_libvirt.ml | 2 +-
v2v/test-harness/v2v_test_harness.ml | 6 +++---
21 files changed, 64 insertions(+), 70 deletions(-)
diff --git a/builder/builder.ml b/builder/builder.ml
index e95fcd1..b4229d6 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -405,7 +405,7 @@ let main () let is_not t = not (is t) in
let remove = List.remove_assoc in
let ret = ref [] in
- let tr task weight otags = ret := (task, weight, otags) :: !ret in
+ let tr task weight otags = unshift (task, weight, otags) ret in
(* XXX Weights are not very smartly chosen. At the moment I'm
* using a range [0..100] where 0 = free and 100 = expensive. We
diff --git a/builder/cmdline.ml b/builder/cmdline.ml
index eee8367..93ac179 100644
--- a/builder/cmdline.ml
+++ b/builder/cmdline.ml
@@ -71,7 +71,7 @@ let parse_cmdline () | "auto" ->
attach_format := None
| s -> attach_format := Some s
in
- let attach_disk s = attach := (!attach_format, s) :: !attach in
+ let attach_disk s = unshift (!attach_format, s) attach in
let cache = ref Paths.xdg_cache_home in
let set_cache arg = cache := Some arg in
@@ -83,7 +83,7 @@ let parse_cmdline () let delete_on_failure = ref true in
let fingerprints = ref [] in
- let add_fingerprint arg = fingerprints := arg :: !fingerprints in
+ let add_fingerprint arg = unshift arg fingerprints in
let format = ref "" in
let gpg = ref "gpg" in
@@ -113,7 +113,7 @@ let parse_cmdline () let set_smp arg = smp := Some arg in
let sources = ref [] in
- let add_source arg = sources := arg :: !sources in
+ let add_source arg = unshift arg sources in
let sync = ref true in
let warn_if_partition = ref true in
@@ -175,7 +175,7 @@ let parse_cmdline () let argspec = set_standard_options
argspec in
let args = ref [] in
- let anon_fun s = args := s :: !args in
+ let anon_fun s = unshift s args in
let usage_msg sprintf (f_"\
%s: build virtual machine images quickly
diff --git a/builder/languages.ml b/builder/languages.ml
index 37acf83..5e1d70a 100644
--- a/builder/languages.ml
+++ b/builder/languages.ml
@@ -30,10 +30,10 @@ let split_locale loc let territory = match_or_empty 3
in
(match territory with
| "" -> ()
- | territory -> l := (lang ^ "_" ^ territory) :: !l);
- l := lang :: !l;
+ | territory -> unshift (lang ^ "_" ^ territory) l);
+ unshift lang l;
);
- l := "" :: !l;
+ unshift "" l;
List.rev !l
let languages () diff --git a/builder/sigchecker.ml b/builder/sigchecker.ml
index 94727d6..e2a3b5f 100644
--- a/builder/sigchecker.ml
+++ b/builder/sigchecker.ml
@@ -80,9 +80,7 @@ let import_keyfile ~gpg ~gpghome ?(trust = true) keyfile
(match !current with
| None -> ()
| Some k ->
- if String.is_suffix id k then (
- subkeys := id :: !subkeys;
- );
+ if String.is_suffix id k then unshift id subkeys;
current := None
)
| _ -> ()
diff --git a/customize/customize_main.ml b/customize/customize_main.ml
index 5b7712e..6b58aea 100644
--- a/customize/customize_main.ml
+++ b/customize/customize_main.ml
@@ -38,7 +38,7 @@ let main () | "auto" -> attach_format :=
None
| s -> attach_format := Some s
in
- let attach_disk s = attach := (!attach_format, s) :: !attach in
+ let attach_disk s = unshift (!attach_format, s) attach in
let domain = ref None in
let dryrun = ref false in
let files = ref [] in
@@ -62,7 +62,7 @@ let main () error (f_"error parsing URI
'%s'. Look for error messages printed above.")
arg in
let format = match !format with "auto" -> None | fmt ->
Some fmt in
- files := (uri, format) :: !files;
+ unshift (uri, format) files;
format_consumed := true
and set_domain dom if !domain <> None then
diff --git a/dib/cmdline.ml b/dib/cmdline.ml
index 3a97366..f51a20d 100644
--- a/dib/cmdline.ml
+++ b/dib/cmdline.ml
@@ -68,20 +68,16 @@ read the man page virt-dib(1).
prog in
let elements = ref [] in
- let append_element element - elements := element :: !elements in
+ let append_element element = unshift element elements in
let excluded_elements = ref [] in
- let append_excluded_element element - excluded_elements := element ::
!excluded_elements in
+ let append_excluded_element element = unshift element excluded_elements in
let element_paths = ref [] in
- let append_element_path arg - element_paths := arg :: !element_paths in
+ let append_element_path arg = unshift arg element_paths in
let excluded_scripts = ref [] in
- let append_excluded_script arg - excluded_scripts := arg ::
!excluded_scripts in
+ let append_excluded_script arg = unshift arg excluded_scripts in
let debug = ref 0 in
let set_debug arg @@ -118,8 +114,7 @@ read the man page virt-dib(1).
formats := fmts in
let envvars = ref [] in
- let append_envvar arg - envvars := arg :: !envvars in
+ let append_envvar arg = unshift arg envvars in
let use_base = ref true in
@@ -153,7 +148,7 @@ read the man page virt-dib(1).
let extra_packages = ref [] in
let append_extra_packages arg - extra_packages := List.rev (String.nsplit
"," arg) @ !extra_packages in
+ prepend (List.rev (String.nsplit "," arg)) extra_packages in
let argspec = [
"-p", Arg.String append_element_path, "path"
^ " " ^ s_"Add new a elements location";
diff --git a/generator/customize.ml b/generator/customize.ml
index 5db76d5..b4b12c4 100644
--- a/generator/customize.ml
+++ b/generator/customize.ml
@@ -653,7 +653,7 @@ let rec argspec () op_shortdesc = shortdesc;
op_pod_longdesc = longdesc } ->
pr " (\n";
pr " \"--%s\",\n" name;
- pr " Arg.Unit (fun () -> ops := %s :: !ops),\n"
discrim;
+ pr " Arg.Unit (fun () -> unshift %s ops),\n" discrim;
pr " \" \" ^ s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " None, %S;\n" longdesc
@@ -661,7 +661,7 @@ let rec argspec () op_shortdesc = shortdesc;
op_pod_longdesc = longdesc } ->
pr " (\n";
pr " \"--%s\",\n" name;
- pr " Arg.String (fun s -> ops := %s s :: !ops),\n"
discrim;
+ pr " Arg.String (fun s -> unshift (%s s) ops),\n"
discrim;
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
@@ -672,7 +672,7 @@ let rec argspec () pr " Arg.String
(\n";
pr " fun s ->\n";
pr " let p = split_string_pair \"%s\" s
in\n" name;
- pr " ops := %s p :: !ops\n" discrim;
+ pr " unshift (%s p) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
@@ -684,7 +684,7 @@ let rec argspec () pr " Arg.String
(\n";
pr " fun s ->\n";
pr " let ss = split_string_list s in\n";
- pr " ops := %s ss :: !ops\n" discrim;
+ pr " unshift (%s ss) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
@@ -696,7 +696,7 @@ let rec argspec () pr " Arg.String
(\n";
pr " fun s ->\n";
pr " let ss = split_links_list \"%s\" s
in\n" name;
- pr " ops := %s ss :: !ops\n" discrim;
+ pr " unshift (%s ss) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
@@ -708,7 +708,7 @@ let rec argspec () pr " Arg.String
(\n";
pr " fun s ->\n";
pr " let sel = Password.parse_selector s in\n";
- pr " ops := %s sel :: !ops\n" discrim;
+ pr " unshift (%s sel) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
@@ -721,7 +721,7 @@ let rec argspec () pr " fun s
->\n";
pr " let user, sel = split_string_pair \"%s\" s
in\n" name;
pr " let sel = Password.parse_selector sel in\n";
- pr " ops := %s (user, sel) :: !ops\n" discrim;
+ pr " unshift (%s (user, sel)) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
@@ -734,7 +734,7 @@ let rec argspec () pr " fun s
->\n";
pr " let user, selstr = String.split \":\" s
in\n";
pr " let sel = Ssh_key.parse_selector selstr in\n";
- pr " ops := %s (user, sel) :: !ops\n" discrim;
+ pr " unshift (%s (user, sel)) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
@@ -746,7 +746,7 @@ let rec argspec () pr " Arg.String
(\n";
pr " fun s ->\n";
pr " %s s;\n" fn;
- pr " ops := %s s :: !ops\n" discrim;
+ pr " unshift (%s s) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
@@ -758,7 +758,7 @@ let rec argspec () pr " Arg.String
(\n";
pr " fun s ->\n";
pr " let sel = Subscription_manager.parse_pool_selector s
in\n";
- pr " ops := %s sel :: !ops\n" discrim;
+ pr " unshift (%s sel) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
pr " ),\n";
diff --git a/resize/resize.ml b/resize/resize.ml
index 22386ce..fb98c17 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -150,7 +150,7 @@ let main () lv_expands, machine_readable,
ntfsresize_force, output_format,
resizes, resizes_force, shrink, sparse, unknown_fs_mode
- let add xs s = xs := s :: !xs in
+ let add xs s = unshift s xs in
let align_first = ref "auto" in
let alignment = ref 128 in
@@ -214,7 +214,7 @@ let main () ] in
let argspec = set_standard_options argspec in
let disks = ref [] in
- let anon_fun s = disks := s :: !disks in
+ let anon_fun s = unshift s disks in
let usage_msg sprintf (f_"\
%s: resize a virtual machine disk
diff --git a/sparsify/cmdline.ml b/sparsify/cmdline.ml
index bd49e71..1855fa6 100644
--- a/sparsify/cmdline.ml
+++ b/sparsify/cmdline.ml
@@ -41,7 +41,7 @@ and mode_t and check_t = [`Ignore|`Continue|`Warn|`Fail]
let parse_cmdline () - let add xs s = xs := s :: !xs in
+ let add xs s = unshift s xs in
let check_tmpdir = ref `Warn in
let set_check_tmpdir = function
@@ -79,7 +79,7 @@ let parse_cmdline () ] in
let argspec = set_standard_options argspec in
let disks = ref [] in
- let anon_fun s = disks := s :: !disks in
+ let anon_fun s = unshift s disks in
let usage_msg sprintf (f_"\
%s: sparsify a virtual machine disk
diff --git a/sysprep/main.ml b/sysprep/main.ml
index 35a259c..c8db653 100644
--- a/sysprep/main.ml
+++ b/sysprep/main.ml
@@ -56,7 +56,7 @@ let main () with Invalid_argument
"URI.parse_uri" ->
error (f_"error parsing URI '%s'. Look for error
messages printed above.") arg in
let format = match !format with "auto" -> None | fmt ->
Some fmt in
- files := (uri, format) :: !files;
+ unshift (uri, format) files;
format_consumed := true
and set_domain dom if !domain <> None then
diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml
index 057c8c5..806e9d8 100644
--- a/sysprep/sysprep_operation.ml
+++ b/sysprep/sysprep_operation.ml
@@ -109,9 +109,9 @@ let remove_all_from_set set empty_set
let register_operation op - all_operations := op :: !all_operations;
+ unshift op all_operations;
if op.enabled_by_default then
- enabled_by_default_operations := op :: !enabled_by_default_operations
+ unshift op enabled_by_default_operations
let baked = ref false
let rec bake () diff --git a/sysprep/sysprep_operation_script.ml
b/sysprep/sysprep_operation_script.ml
index 140225c..f7f6e88 100644
--- a/sysprep/sysprep_operation_script.ml
+++ b/sysprep/sysprep_operation_script.ml
@@ -33,7 +33,7 @@ let set_scriptdir dir scriptdir := Some dir
let scripts = ref []
-let add_script script = scripts := script :: !scripts
+let add_script script = unshift script scripts
let rec script_perform (g : Guestfs.guestfs) root side_effects let scripts =
List.rev !scripts in
diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml
index 1064987..558ace4 100644
--- a/v2v/cmdline.ml
+++ b/v2v/cmdline.ml
@@ -150,10 +150,10 @@ let parse_cmdline () in
let vdsm_image_uuids = ref [] in
- let add_vdsm_image_uuid s = vdsm_image_uuids := s :: !vdsm_image_uuids in
+ let add_vdsm_image_uuid s = unshift s vdsm_image_uuids in
let vdsm_vol_uuids = ref [] in
- let add_vdsm_vol_uuid s = vdsm_vol_uuids := s :: !vdsm_vol_uuids in
+ let add_vdsm_vol_uuid s = unshift s vdsm_vol_uuids in
let vmtype_warning _ warning (f_"the --vmtype option has been
removed and now does nothing")
@@ -216,7 +216,7 @@ let parse_cmdline () ] in
let argspec = set_standard_options argspec in
let args = ref [] in
- let anon_fun s = args := s :: !args in
+ let anon_fun s = unshift s args in
let usage_msg sprintf (f_"\
%s: convert a guest to use KVM
diff --git a/v2v/convert_linux.ml b/v2v/convert_linux.ml
index a5ba8dd..90f9543 100644
--- a/v2v/convert_linux.ml
+++ b/v2v/convert_linux.ml
@@ -555,13 +555,13 @@ let rec convert ~keep_serial_console (g : G.guestfs)
inspect source rcaps List.iter (
fun { G.app2_name = name } ->
if String.is_prefix name "vmware-tools-libraries-" then
- libraries := name :: !libraries
+ unshift name libraries
else if String.is_prefix name "vmware-tools-" then
- remove := name :: !remove
+ unshift name remove
else if name = "VMwareTools" then
- remove := name :: !remove
+ unshift name remove
else if String.is_prefix name "kmod-vmware-tools" then
- remove := name :: !remove
+ unshift name remove
) inspect.i_apps;
let libraries = !libraries in
@@ -601,7 +601,7 @@ let rec convert ~keep_serial_console (g : G.guestfs) inspect
source rcaps let cmd = Array.of_list cmd in
(try
ignore (g#command cmd);
- remove := library :: !remove
+ unshift library remove
with G.Error msg ->
eprintf "%s: could not install replacement for %s. Error
was: %s. %s was not removed.\n"
prog library msg library
diff --git a/v2v/convert_windows.ml b/v2v/convert_windows.ml
index e5e4dc7..34fe9cb 100644
--- a/v2v/convert_windows.ml
+++ b/v2v/convert_windows.ml
@@ -196,7 +196,7 @@ let convert ~keep_serial_console (g : G.guestfs) inspect
source rcaps * uninstaller still shows a no-way-out
reboot dialog *)
" PREVENT_REBOOT=Yes LAUNCHED_BY_SETUP_EXE=Yes"
in
- uninsts := uninst :: !uninsts
+ unshift uninst uninsts
with
Not_found -> ()
) uninstnodes
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index 24ed03f..91e4b58 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -48,7 +48,7 @@ let rec main () ] in
let argspec = set_standard_options argspec in
let args = ref [] in
- let anon_fun s = args := s :: !args in
+ let anon_fun s = unshift s args in
let usage_msg sprintf (f_"\
%s: copy a remote guest to the local machine
@@ -259,7 +259,7 @@ and parse_libvirt_xml guest_name xml incr i;
let local_disk = sprintf "%s-disk%d" guest_name !i in
- disks := (remote_disk, local_disk) :: !disks;
+ unshift (remote_disk, local_disk) disks;
local_disk
in
get_disks, add_disk
diff --git a/v2v/input_libvirtxml.ml b/v2v/input_libvirtxml.ml
index 552bd9f..a1fa96a 100644
--- a/v2v/input_libvirtxml.ml
+++ b/v2v/input_libvirtxml.ml
@@ -76,7 +76,7 @@ let parse_libvirt_xml ?conn xml let nr_nodes =
Xml.xpathobj_nr_nodes obj in
for i = 0 to nr_nodes-1 do
let node = Xml.xpathobj_node obj i in
- features := Xml.node_name node :: !features
+ unshift (Xml.node_name node) features
done;
!features in
@@ -193,11 +193,12 @@ let parse_libvirt_xml ?conn xml let get_disks () =
List.rev !disks in
let add_disk qemu_uri format controller p_source incr i;
- disks :+ unshift
{ p_source_disk = { s_disk_id = !i;
s_qemu_uri = qemu_uri; s_format = format;
s_controller = controller };
- p_source = p_source } :: !disks
+ p_source = p_source }
+ disks
in
get_disks, add_disk
in
@@ -334,7 +335,7 @@ let parse_libvirt_xml ?conn xml { s_removable_type
= typ;
s_removable_controller = controller;
s_removable_slot = slot } in
- disks := disk :: !disks
+ unshift disk disks
done;
List.rev !disks in
@@ -378,7 +379,7 @@ let parse_libvirt_xml ?conn xml s_vnet_orig =
vnet;
s_vnet_type = vnet_type
} in
- nics := nic :: !nics
+ unshift nic nics
in
match xpath_string "source/@network | source/@bridge" with
| None -> ()
diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml
index 8a5886c..f3d35c4 100644
--- a/v2v/input_ova.ml
+++ b/v2v/input_ova.ml
@@ -287,7 +287,7 @@ object
s_format = Some "vmdk";
s_controller = controller;
} in
- disks := disk :: !disks;
+ unshift disk disks;
) else
error (f_"could not parse disk rasd:HostResource from OVF
document")
done in
@@ -331,7 +331,7 @@ object
s_removable_controller = controller;
s_removable_slot = slot;
} in
- removables := disk :: !removables;
+ unshift disk removables;
done in
let removables = List.rev !removables in
@@ -351,7 +351,7 @@ object
s_vnet_orig = vnet;
s_vnet_type = Network;
} in
- nics := nic :: !nics
+ unshift nic nics
done;
let source = {
diff --git a/v2v/modules_list.ml b/v2v/modules_list.ml
index fd7b2ff..30b044e 100644
--- a/v2v/modules_list.ml
+++ b/v2v/modules_list.ml
@@ -16,13 +16,13 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
+open Common_utils
+
let input_modules = ref []
and output_modules = ref []
-let register_input_module name - input_modules := name :: !input_modules
-and register_output_module name - output_modules := name :: !output_modules
+let register_input_module name = unshift name input_modules
+and register_output_module name = unshift name output_modules
let input_modules () = List.sort compare !input_modules
and output_modules () = List.sort compare !output_modules
@@ -35,7 +35,7 @@ type conversion_fn let convert_modules = ref []
let register_convert_module inspect_fn name conversion_fn - convert_modules :=
(inspect_fn, (name, conversion_fn)) :: !convert_modules
+ unshift (inspect_fn, (name, conversion_fn)) convert_modules
let find_convert_module inspect let rec loop = function
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index e7067d7..69cdd2b 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -64,7 +64,7 @@ let target_features_of_capabilities_doc doc arch for i =
0 to Xml.xpathobj_nr_nodes obj - 1 do
let feature_node = Xml.xpathobj_node obj i in
let feature_name = Xml.node_name feature_node in
- features := feature_name :: !features
+ unshift feature_name features
done;
!features
)
diff --git a/v2v/test-harness/v2v_test_harness.ml
b/v2v/test-harness/v2v_test_harness.ml
index 70ce73e..f774978 100644
--- a/v2v/test-harness/v2v_test_harness.ml
+++ b/v2v/test-harness/v2v_test_harness.ml
@@ -94,7 +94,7 @@ let run ~test ?input_disk ?input_xml ?(test_plan =
default_plan) () let nodes_of_xpathobj doc xpathobj let nodes = ref []
in
for i = 0 to Xml.xpathobj_nr_nodes xpathobj - 1 do
- nodes := Xml.xpathobj_node xpathobj i :: !nodes
+ unshift (Xml.xpathobj_node xpathobj i) nodes
done;
List.rev !nodes
in
@@ -210,7 +210,7 @@ let run ~test ?input_disk ?input_xml ?(test_plan =
default_plan) () printf "%s\n%!" cmd;
let chan = open_process_in cmd in
let lines = ref [] in
- (try while true do lines := input_line chan :: !lines done
+ (try while true do unshift (input_line chan) lines done
with End_of_file -> ());
let lines = List.rev !lines in
let stat = close_process_in chan in
@@ -283,7 +283,7 @@ let run ~test ?input_disk ?input_xml ?(test_plan =
default_plan) () printf "%s\n%!" cmd;
let chan = open_process_in cmd in
let lines = ref [] in
- (try while true do lines := input_line chan :: !lines done
+ (try while true do unshift (input_line chan) lines done
with End_of_file -> ());
let lines = List.rev !lines in
let stat = close_process_in chan in
--
2.7.4
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 7/8] v2v: Don't open DOM module in output_rhev and output_vdsm.
I think this is left over from before we moved the OVF code
out to its own module.
---
v2v/output_rhev.ml | 3 +--
v2v/output_vdsm.ml | 3 +--
2 files changed, 2 insertions(+), 4 deletions(-)
diff --git a/v2v/output_rhev.ml b/v2v/output_rhev.ml
index 5277456..e45043b 100644
--- a/v2v/output_rhev.ml
+++ b/v2v/output_rhev.ml
@@ -24,7 +24,6 @@ open Printf
open Types
open Utils
-open DOM
let rec mount_and_check_storage_domain domain_class os (* The user can
either specify -os nfs:/export, or a local directory
@@ -276,7 +275,7 @@ object
let dir = esd_mp // esd_uuid // "master" // "vms" //
vm_uuid in
Changeuid.mkdir changeuid_t dir 0o755;
let file = dir // vm_uuid ^ ".ovf" in
- Changeuid.output changeuid_t file (fun chan -> doc_to_chan chan ovf);
+ Changeuid.output changeuid_t file (fun chan -> DOM.doc_to_chan chan
ovf);
(* Finished, so don't delete the target directory on exit. *)
delete_target_directory <- false
diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml
index 39f722b..7cd94c0 100644
--- a/v2v/output_vdsm.ml
+++ b/v2v/output_vdsm.ml
@@ -24,7 +24,6 @@ open Printf
open Types
open Utils
-open DOM
type vdsm_params = {
image_uuids : string list;
@@ -171,7 +170,7 @@ object
(* Write it to the metadata file. *)
let file = vdsm_params.ovf_output // vdsm_params.vm_uuid ^ ".ovf"
in
let chan = open_out file in
- doc_to_chan chan ovf;
+ DOM.doc_to_chan chan ovf;
close_out chan
end
--
2.7.4
Richard W.M. Jones
2016-Jul-07 15:22 UTC
[Libguestfs] [PATCH v2 8/8] v2v: Use imperative list functions to simplify DOM building code.
---
v2v/OVF.ml | 173 +++++++++++++++++++++++++-------------------------
v2v/output_libvirt.ml | 16 +++--
2 files changed, 100 insertions(+), 89 deletions(-)
diff --git a/v2v/OVF.ml b/v2v/OVF.ml
index ec835e5..97b2928 100644
--- a/v2v/OVF.ml
+++ b/v2v/OVF.ml
@@ -274,76 +274,77 @@ let rec create_ovf source targets guestcaps inspect
e "Info" [] [PCData "List of Virtual Disks"]
];
- e "Content" ["ovf:id", "out";
"xsi:type", "ovf:VirtualSystem_Type"] (
- let es = [
- e "Name" [] [PCData source.s_name];
- e "TemplateId" [] [PCData
"00000000-0000-0000-0000-000000000000"];
- e "TemplateName" [] [PCData "Blank"];
- e "Description" [] [PCData generated_by];
- e "Domain" [] [];
- e "CreationDate" [] [PCData iso_time];
- e "IsInitilized" (* sic *) [] [PCData "True"];
- e "IsAutoSuspend" [] [PCData "False"];
- e "TimeZone" [] [];
- e "IsStateless" [] [PCData "False"];
- e "VmType" [] [PCData vmtype];
- (* See https://bugzilla.redhat.com/show_bug.cgi?id=1260590#c17 *)
- e "DefaultDisplayType" [] [PCData "1"];
- ] in
+ let content_subnodes = ref [
+ e "Name" [] [PCData source.s_name];
+ e "TemplateId" [] [PCData
"00000000-0000-0000-0000-000000000000"];
+ e "TemplateName" [] [PCData "Blank"];
+ e "Description" [] [PCData generated_by];
+ e "Domain" [] [];
+ e "CreationDate" [] [PCData iso_time];
+ e "IsInitilized" (* sic *) [] [PCData "True"];
+ e "IsAutoSuspend" [] [PCData "False"];
+ e "TimeZone" [] [];
+ e "IsStateless" [] [PCData "False"];
+ e "VmType" [] [PCData vmtype];
+ (* See https://bugzilla.redhat.com/show_bug.cgi?id=1260590#c17 *)
+ e "DefaultDisplayType" [] [PCData "1"];
+ ] in
- (* Add the <Origin/> element if we can. *)
- let es - match origin_of_source_hypervisor source.s_hypervisor
with
- | None -> es
- | Some origin ->
- es @ [e "Origin" [] [PCData (string_of_int origin)]] in
+ (* Add the <Origin/> element if we can. *)
+ (match origin_of_source_hypervisor source.s_hypervisor with
+ | None -> ()
+ | Some origin ->
+ push content_subnodes (e "Origin" [] [PCData (string_of_int
origin)])
+ );
- es @ [
- e "Section" ["ovf:id", vm_uuid;
"ovf:required", "false";
- "xsi:type",
"ovf:OperatingSystemSection_Type"] [
- e "Info" [] [PCData inspect.i_product_name];
- e "Description" [] [PCData ostype];
- ];
+ append content_subnodes [
+ e "Section" ["ovf:id", vm_uuid;
"ovf:required", "false";
+ "xsi:type",
"ovf:OperatingSystemSection_Type"] [
+ e "Info" [] [PCData inspect.i_product_name];
+ e "Description" [] [PCData ostype];
+ ];
- e "Section" ["xsi:type",
"ovf:VirtualHardwareSection_Type"] [
- e "Info" [] [PCData (sprintf "%d CPU, %Ld
Memory" source.s_vcpu memsize_mb)];
- e "Item" [] [
- e "rasd:Caption" [] [PCData (sprintf "%d virtual
cpu" source.s_vcpu)];
- e "rasd:Description" [] [PCData "Number of virtual
CPU"];
- e "rasd:InstanceId" [] [PCData "1"];
- e "rasd:ResourceType" [] [PCData "3"];
- e "rasd:num_of_sockets" [] [PCData (string_of_int
source.s_vcpu)];
- e "rasd:cpu_per_socket"[] [PCData "1"];
- ];
- e "Item" [] [
- e "rasd:Caption" [] [PCData (sprintf "%Ld MB of
memory" memsize_mb)];
- e "rasd:Description" [] [PCData "Memory
Size"];
- e "rasd:InstanceId" [] [PCData "2"];
- e "rasd:ResourceType" [] [PCData "4"];
- e "rasd:AllocationUnits" [] [PCData
"MegaBytes"];
- e "rasd:VirtualQuantity" [] [PCData (Int64.to_string
memsize_mb)];
- ];
- e "Item" [] [
- e "rasd:Caption" [] [PCData "USB
Controller"];
- e "rasd:InstanceId" [] [PCData "3"];
- e "rasd:ResourceType" [] [PCData "23"];
- e "rasd:UsbPolicy" [] [PCData "Disabled"];
- ];
- (* We always add a qxl device when outputting to RHEV.
- * See RHBZ#1213701 and RHBZ#1211231 for the reasoning
- * behind that.
- *)
- e "Item" [] [
- e "rasd:Caption" [] [PCData "Graphical
Controller"];
- e "rasd:InstanceId" [] [PCData (uuidgen ())];
- e "rasd:ResourceType" [] [PCData "20"];
- e "Type" [] [PCData "video"];
- e "rasd:VirtualQuantity" [] [PCData "1"];
- e "rasd:Device" [] [PCData "qxl"];
- ]
+ e "Section" ["xsi:type",
"ovf:VirtualHardwareSection_Type"] [
+ e "Info" [] [PCData (sprintf "%d CPU, %Ld Memory"
source.s_vcpu memsize_mb)];
+ e "Item" [] [
+ e "rasd:Caption" [] [PCData (sprintf "%d virtual
cpu" source.s_vcpu)];
+ e "rasd:Description" [] [PCData "Number of virtual
CPU"];
+ e "rasd:InstanceId" [] [PCData "1"];
+ e "rasd:ResourceType" [] [PCData "3"];
+ e "rasd:num_of_sockets" [] [PCData (string_of_int
source.s_vcpu)];
+ e "rasd:cpu_per_socket"[] [PCData "1"];
+ ];
+ e "Item" [] [
+ e "rasd:Caption" [] [PCData (sprintf "%Ld MB of
memory" memsize_mb)];
+ e "rasd:Description" [] [PCData "Memory Size"];
+ e "rasd:InstanceId" [] [PCData "2"];
+ e "rasd:ResourceType" [] [PCData "4"];
+ e "rasd:AllocationUnits" [] [PCData
"MegaBytes"];
+ e "rasd:VirtualQuantity" [] [PCData (Int64.to_string
memsize_mb)];
+ ];
+ e "Item" [] [
+ e "rasd:Caption" [] [PCData "USB Controller"];
+ e "rasd:InstanceId" [] [PCData "3"];
+ e "rasd:ResourceType" [] [PCData "23"];
+ e "rasd:UsbPolicy" [] [PCData "Disabled"];
+ ];
+ (* We always add a qxl device when outputting to RHEV.
+ * See RHBZ#1213701 and RHBZ#1211231 for the reasoning
+ * behind that.
+ *)
+ e "Item" [] [
+ e "rasd:Caption" [] [PCData "Graphical
Controller"];
+ e "rasd:InstanceId" [] [PCData (uuidgen ())];
+ e "rasd:ResourceType" [] [PCData "20"];
+ e "Type" [] [PCData "video"];
+ e "rasd:VirtualQuantity" [] [PCData "1"];
+ e "rasd:Device" [] [PCData "qxl"];
]
]
- )
+ ];
+
+ e "Content" ["ovf:id", "out";
"xsi:type", "ovf:VirtualSystem_Type"]
+ !content_subnodes
] in
(* Add disks to the OVF XML. *)
@@ -448,7 +449,7 @@ and add_disks targets guestcaps output_alloc sd_uuid
image_uuids vol_uuids ovf
(* Add disk to DiskSection. *)
let disk - let attrs = [
+ let attrs = ref [
"ovf:diskId", vol_uuid;
"ovf:size", Int64.to_string size_gb;
"ovf:fileRef", fileref;
@@ -465,12 +466,12 @@ and add_disks targets guestcaps output_alloc sd_uuid
image_uuids vol_uuids ovf "ovf:disk-type",
"System"; (* RHBZ#744538 *)
"ovf:boot", if is_bootable_drive then "True" else
"False";
] in
- let attrs - match actual_size_gb with
- | None -> attrs
- | Some actual_size_gb ->
- ("ovf:actual_size", Int64.to_string actual_size_gb) ::
attrs in
- e "Disk" attrs [] in
+ (match actual_size_gb with
+ | None -> ()
+ | Some actual_size_gb ->
+ push attrs ("ovf:actual_size", Int64.to_string
actual_size_gb)
+ );
+ e "Disk" !attrs [] in
if is_estimate then (
let comment = Comment "note: actual_size field is estimated"
in
append_child comment disk_section
@@ -483,7 +484,7 @@ and add_disks targets guestcaps output_alloc sd_uuid
image_uuids vol_uuids ovf * will not parse.
*)
let caption = sprintf "Drive %d" (i+1) in
- e "Item" [] ([
+ let item_subnodes = ref [
e "rasd:Caption" [] [PCData caption];
e "rasd:InstanceId" [] [PCData vol_uuid];
e "rasd:ResourceType" [] [PCData "17"];
@@ -497,12 +498,12 @@ and add_disks targets guestcaps output_alloc sd_uuid
image_uuids vol_uuids ovf e "rasd:CreationDate" [] [PCData
iso_time];
e "rasd:LastModified" [] [PCData iso_time];
e "rasd:last_modified_date" [] [PCData iso_time];
- ] @
- if is_bootable_drive then
- [e "BootOrder" [] [PCData (string_of_int boot_order)]]
- else
- []
- ) in
+ ] in
+ if is_bootable_drive then
+ push item_subnodes
+ (e "BootOrder" [] [PCData (string_of_int
boot_order)]);
+
+ e "Item" [] !item_subnodes in
append_child item virtualhardware_section;
) (combine3 targets image_uuids vol_uuids)
@@ -543,7 +544,7 @@ and add_networks nics guestcaps ovf append_child
network network_section;
let item - let children = [
+ let item_subnodes = ref [
e "rasd:InstanceId" [] [PCData (uuidgen ())];
e "rasd:Caption" [] [PCData (sprintf "Ethernet adapter
on %s" vnet)];
e "rasd:ResourceType" [] [PCData "10"];
@@ -552,11 +553,13 @@ and add_networks nics guestcaps ovf e
"rasd:Connection" [] [PCData vnet];
e "rasd:Name" [] [PCData dev];
] in
- let children - match mac with
- | None -> children
- | Some mac -> children @ [e "rasd:MACAddress" [] [PCData
mac]] in
- e "Item" [] children in
+ (match mac with
+ | None -> ()
+ | Some mac ->
+ push item_subnodes
+ (e "rasd:MACAddress" [] [PCData mac])
+ );
+ e "Item" [] !item_subnodes in
append_child item virtualhardware_section;
) nics
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index 69cdd2b..750c64d 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -125,6 +125,9 @@ let create_libvirt_xml ?pool source target_buses guestcaps
(e "type" ["arch", guestcaps.gcaps_arch] [PCData
"hvm"]) :: loader in
+ (* The devices. *)
+ let devices = ref [] in
+
(* Fixed and removable disks. *)
let disks let make_disk bus_name drive_prefix i = function
@@ -189,6 +192,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
(Array.mapi (make_disk "floppy" "fd")
target_buses.target_floppy_bus)
] in
+ append devices disks;
let nics let net_model @@ -221,6 +225,7 @@ let create_libvirt_xml ?pool
source target_buses guestcaps
nic
) source.s_nics in
+ append devices nics;
(* Same as old virt-v2v, we always add a display here even if it was
* missing from the old metadata.
@@ -232,6 +237,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
| Cirrus -> e "model" [ "type",
"cirrus"; "vram", "9216" ] [] in
append_attr ("heads", "1") video_model;
e "video" [] [ video_model ] in
+ push devices video;
let graphics match source.s_display with
@@ -267,6 +273,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
| Some { s_port = None } | None ->
append_attr ("autoport", "yes") graphics;
append_attr ("port", "-1") graphics);
+ push devices graphics;
let sound match source.s_sound with
@@ -276,13 +283,14 @@ let create_libvirt_xml ?pool source target_buses guestcaps
[ e "sound" [ "model",
string_of_source_sound_model model ] [] ]
else
[] in
+ append devices sound;
- let devices = disks @ nics @ [video] @ [graphics] @ sound @
- (* Standard devices added to every guest. *) [
+ (* Standard devices added to every guest. *)
+ append devices [
e "input" ["type", "tablet"; "bus",
"usb"] [];
e "input" ["type", "mouse"; "bus",
"ps2"] [];
e "console" ["type", "pty"] [];
- ] in
+ ];
let doc : doc doc "domain" [
@@ -300,7 +308,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
e "on_reboot" [] [PCData "restart"];
e "on_crash" [] [PCData "restart"];
- e "devices" [] devices;
+ e "devices" [] !devices;
] in
doc
--
2.7.4
Pino Toscano
2016-Jul-07 15:45 UTC
Re: [Libguestfs] [PATCH v2 2/8] curl: Change the API to use an abstract data type.
On Thursday 07 July 2016 16:22:05 Richard W.M. Jones wrote:> Change the Curl module to use an ADT to store the name of the curl > binary and the arguments.Good idea. The implementation looks mostly good, although I have a couple of notes.> > Also add Curl.safe_args, a list of arguments that control redirects etc.The current implementation basically "forces" every caller to pass them to Curl.create (and indeed this patch and patch #3 do this job), which IMHO makes it easy to forget them. Since we want those arguments on by default in all the curl invocations, I'd do the following: hide Curl.safe_args, and add them automatically in Curl.to_string. If in the future there will be the need to not use them for some curl invocation, we can always add ~use_safe_args:false for Curl.create.> +type proxy > + | UnsetProxy (** The proxy is forced off. *) > + | ForcedProxy of string (** The proxy is forced to the specified URL. *) > + > +val args_of_proxy : proxy -> args > +(** Convert the proxy setting to the equivalent list of curl arguments. > + > + To use the system proxy, no additional arguments are required, so > + if you don't want to control the proxy (but just use the defaults) > + you do not need to call this function at all. > + > + Callers should append these arguments to the list of arguments > + passed to {!create}. *)Just wondering whether it makes sense a method to set the proxy for a Curl.t handle, letting Curl do the proxy -> args conversion internally (less work for users). Thanks, -- Pino Toscano
Maybe Matching Threads
- [PATCH v3 0/8] v2v: Move Curl wrapper to mllib and more.
- [PATCH v3 0/2] common/mlstdutils: Extend the List module.
- [PATCH 0/3] common/mlstdutils: Add Std_utils List and Option modules.
- [[PATCH v2 0/4] common/mlstdutils: Add Std_utils List and Option modules.
- [PATCH 0/3] Move Curl wrapper to mllib and use it for virt-builder.