virt-v2v/lib/qemuNBD.ml
Richard W.M. Jones 8ad152afc4 Rework Std_utils.Option so it works like the OCaml stdlib module
OCaml 4.08 introduces a stdlib Option module which looks a bit like
ours but has a number of differences.  In particular our functions
Option.may and Option.default have no corresponding functions in
stdlib, although there are close enough equivalents.

This change was automated using this command:

$ perl -pi.bak \
  -e 's/Option.may/Option.iter/g; s/Option.default /Option.value ~default:/g' \
  `git ls-files`

Update common module to include:

  commit cffa077323fafcdfcf78e230c022afa891a6b3ff
  Author: Richard W.M. Jones <rjones@redhat.com>
  Date:   Mon Feb 20 12:11:51 2023 +0000

    mlstdutils: Rework the Option module to be compatible with stdlib

  commit 007d0506c538db0a43fec7e9986a95ecdcd48b56
  Author: Richard W.M. Jones <rjones@redhat.com>
  Date:   Mon Feb 20 12:18:29 2023 +0000

    mltools: Replace Option.may with Option.iter
2023-02-20 12:21:47 +00:00

152 lines
4.5 KiB
OCaml
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(* virt-v2v
* Copyright (C) 2009-2021 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.
*)
(* qemu-nbd as an abstract data type. *)
open Unix
open Printf
open Common_gettext.Gettext
open Std_utils
open Tools_utils
open Unix_utils
open Utils
let is_installed =
let test = lazy (Sys.command "qemu-nbd --version >/dev/null 2>&1" = 0) in
fun () -> Lazy.force test
let qemu_nbd_has_selinux_label_option =
let test = lazy (Sys.command "qemu-nbd --help |& grep -sq selinux" = 0) in
fun () -> Lazy.force test
type version = int * int * int
let version =
let rex = PCRE.compile "(\\d+)\\.(\\d+)\\.(\\d+)" in
fun config ->
let lines = external_command "qemu-nbd --version" in
let line = List.hd lines in
if not (PCRE.matches rex line) then
error (f_"qemu-nbd: unexpected version in --version: %s") line;
let major = int_of_string (PCRE.sub 1)
and minor = int_of_string (PCRE.sub 2)
and release = int_of_string (PCRE.sub 3) in
debug "qemu-nbd version: %d.%d.%d" major minor release;
(major, minor, release)
type cmd = {
disk : string;
mutable snapshot : bool;
mutable format : string option;
mutable imgopts : bool;
}
let create disk = { disk; snapshot = false; format = None; imgopts = false }
let set_snapshot cmd snap = cmd.snapshot <- snap
let set_format cmd format = cmd.format <- format
let set_image_opts cmd imgopts = cmd.imgopts <- imgopts
let run_unix socket { disk; snapshot; format; imgopts } =
assert (disk <> "");
(* Create a temporary directory where we place the PID file. *)
let piddir = Mkdtemp.temp_dir "v2vqemunbd." in
On_exit.rm_rf piddir;
let id = unique () in
let pidfile = piddir // sprintf "qemunbd%d.pid" id in
(* Construct the qemu-nbd command line. *)
let args = ref [] in
List.push_back_list args
["qemu-nbd";
"-t";
"--shared=0";
"--discard=unmap";
"--pid-file"; pidfile;
"--socket"; socket];
(* -s adds a protective overlay. *)
if snapshot then List.push_back args "-s";
(* --image-opts reinterprets the filename parameter as a set of
* image options.
*)
if imgopts then List.push_back args "--image-opts";
if have_selinux && qemu_nbd_has_selinux_label_option () then (
List.push_back args "--selinux-label";
List.push_back args "system_u:object_r:svirt_socket_t:s0"
);
Option.iter (
fun format ->
List.push_back args "--format";
List.push_back args format
) format;
List.push_back args disk;
(* Print the full command we are about to run when debugging. *)
if verbose () then (
eprintf "running qemu-nbd:\n";
List.iter (fun arg -> eprintf " %s" (quote arg)) !args;
prerr_newline ()
);
let args = Array.of_list !args in
let pid = fork () in
if pid = 0 then (
(* Child process. *)
execvp "qemu-nbd" args
);
(* Wait for qemu-nbd to write a PID file. *)
if not (wait_for_file pidfile 30) then (
if verbose () then
error (f_"qemu-nbd did not start up. See previous debugging messages for problems.")
else
error (f_"qemu-nbd did not start up. There may be errors printed by qemu-nbd above.
If the messages above are not sufficient to diagnose the problem then add the virt-v2v -v -x options and examine the debugging output carefully.")
);
if have_selinux then (
(* Note that Unix domain sockets have both a file label and
* a socket/process label. Using --selinux-label above
* only set the socket label, but we must also set the file
* label.
*)
ignore (run_command ["chcon"; "system_u:object_r:svirt_image_t:s0";
socket]);
);
(* Set the regular Unix permissions, in case qemu is
* running as another user.
*)
chown_for_libvirt_rhbz_1045069 socket;
chmod socket 0o700;
(* We don't need the PID file any longer. *)
unlink pidfile;
socket, pid