forked from xapi-project/xen-api
-
Notifications
You must be signed in to change notification settings - Fork 0
/
xenguestHelper.ml
193 lines (169 loc) · 7.69 KB
/
xenguestHelper.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
(*
* Copyright (C) 2006-2009 Citrix Systems Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* 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 Lesser General Public License for more details.
*)
open Fun
open Pervasiveext
open Xenops_task
module D = Debug.Debugger(struct let name = "xenguesthelper" end)
open D
(** Where to place the last xenguesthelper debug log (just in case) *)
let last_log_file = "/tmp/xenguesthelper-log"
(* Exceptions which may propagate from the xenguest binary *)
exception Xenctrl_dom_allocate_failure of int * string
exception Xenctrl_dom_linux_build_failure of int * string
exception Xenctrl_domain_save_failure of int * string
exception Xenctrl_domain_resume_failure of int * string
exception Xenctrl_domain_restore_failure of int * string
exception Domain_builder_error of string (* function name *) * int (* error code *) * string (* message *)
(** We do all our IO through the buffered channels but pass the
underlying fds as integers to the forked helper on the commandline. *)
type t = in_channel * out_channel * Unix.file_descr * Unix.file_descr * Forkhelpers.pidty
(** Fork and run a xenguest helper with particular args, leaving 'fds' open
(in addition to internal control I/O fds) *)
let connect path domid (args: string list) (fds: (string * Unix.file_descr) list) : t =
debug "connect: args = [ %s ]" (String.concat " " args);
(* Need to send commands and receive responses from the
slave process *)
let using_xiu = Xenctrl.is_fake () in
let last_log_file = Printf.sprintf "/tmp/xenguest.%d.log" domid in
(try Unix.unlink last_log_file with _ -> ());
let slave_to_server_w_uuid = Uuid.to_string (Uuid.make_uuid ()) in
let server_to_slave_r_uuid = Uuid.to_string (Uuid.make_uuid ()) in
let slave_to_server_r, slave_to_server_w = Unix.pipe () in
let server_to_slave_r, server_to_slave_w = Unix.pipe () in
let args = [ "-controloutfd"; slave_to_server_w_uuid;
"-controlinfd"; server_to_slave_r_uuid;
"-debuglog";
last_log_file
] @ (if using_xiu then [ "-fake" ] else []) @ args in
let pid = Forkhelpers.safe_close_and_exec None None None
([ slave_to_server_w_uuid, slave_to_server_w;
server_to_slave_r_uuid, server_to_slave_r ] @ fds)
path args in
Unix.close slave_to_server_w;
Unix.close server_to_slave_r;
Unix.in_channel_of_descr slave_to_server_r,
Unix.out_channel_of_descr server_to_slave_w,
slave_to_server_r,
server_to_slave_w,
pid
(** Wait for the (hopefully dead) child process *)
let disconnect (_, _, r, w, pid) =
Unix.close r;
Unix.close w;
(* just in case *)
(try Unix.kill (Forkhelpers.getpid pid) Sys.sigterm with _ -> ());
ignore(Forkhelpers.waitpid pid)
let with_connection (task: Xenops_task.t) path domid (args: string list) (fds: (string * Unix.file_descr) list) f =
let t = connect path domid args fds in
let cancelled = ref false in
let cancel_cb () =
let _, _, _, _, pid = t in
let pid = Forkhelpers.getpid pid in
cancelled := true;
info "Cancelling task %s by killing xenguest subprocess pid: %d" task.Xenops_task.id pid;
try Unix.kill pid Sys.sigkill with _ -> () in
finally
(fun () ->
Xenops_task.with_cancel task cancel_cb
(fun () ->
try
f t
with e ->
if !cancelled
then Xenops_task.raise_cancelled task
else raise e
)
) (fun () -> disconnect t)
(** immediately write a command to the control channel *)
let send (_, out, _, _, _) txt = output_string out txt; flush out
(** Keep this in sync with xenguest_main *)
type message =
| Stdout of string (* captured stdout from libxenguest *)
| Stderr of string (* captured stderr from libxenguest *)
| Error of string (* an actual error that we detected *)
| Suspend (* request the caller suspends the domain *)
| Info of string (* some info that we want to send back *)
| Result of string (* the result of the operation *)
let string_of_message = function
| Stdout x -> "stdout:" ^ (String.escaped x)
| Stderr x -> "stderr:" ^ (String.escaped x)
| Error x -> "error:" ^ (String.escaped x)
| Suspend -> "suspend:"
| Info x -> "info:" ^ (String.escaped x)
| Result x -> "result:" ^ (String.escaped x)
let message_of_string x =
if not(String.contains x ':')
then failwith (Printf.sprintf "Failed to parse message from xenguesthelper [%s]" x);
let i = String.index x ':' in
let prefix = String.sub x 0 i
and suffix = String.sub x (i + 1) (String.length x - i - 1) in match prefix with
| "stdout" -> Stdout suffix
| "stderr" -> Stderr suffix
| "error" -> Error suffix
| "suspend" -> Suspend
| "info" -> Info suffix
| "result" -> Result suffix
| _ -> Error "uncaught exception"
(** return the next output line from the control channel *)
let receive (infd, _, _, _, _) = message_of_string (input_line infd)
(** return the next output line which is not a debug: line *)
let rec non_debug_receive ?(debug_callback=(fun s -> debug "%s" s)) cnx = match receive cnx with
| Stdout x -> debug_callback x; non_debug_receive ~debug_callback cnx
| Stderr x -> debug_callback x; non_debug_receive ~debug_callback cnx
| Info x -> debug_callback x; non_debug_receive ~debug_callback cnx
| x -> x (* Error or Result or Suspend *)
(* Dump memory statistics on failure *)
let non_debug_receive ?debug_callback cnx =
let debug_memory () =
Xenctrl.with_intf (fun xc ->
let open Memory in
let open Int64 in
let open Xenctrl in
let p = Xenctrl.physinfo xc in
let open Xenctrl.Phys_info in
error "Memory F %Ld KiB S %Ld KiB T %Ld MiB"
(p.free_pages |> of_nativeint |> kib_of_pages)
(p.scrub_pages |> of_nativeint |> kib_of_pages)
(p.total_pages |> of_nativeint |> mib_of_pages_free)
) in
try
match non_debug_receive ?debug_callback cnx with
| Error y as x ->
error "Received: %s" y;
debug_memory (); x
| x -> x
with e ->
debug_memory ();
raise e
(** For the simple case where we just want the successful result, return it.
If we get an error message (or suspend) then throw an exception. *)
let receive_success ?(debug_callback=(fun s -> debug "%s" s)) cnx =
match non_debug_receive ~debug_callback cnx with
| Error x ->
(* These error strings match those in xenguest_stubs.c *)
begin
match Stringext.String.split ~limit:3 ' ' x with
| [ "hvm_build" ; code; msg ] -> raise (Domain_builder_error ("hvm_build", int_of_string code, msg))
| [ "xc_dom_allocate" ; code; msg ] -> raise (Xenctrl_dom_allocate_failure (int_of_string code, msg))
| [ "xc_dom_linux_build"; code; msg ] -> raise (Xenctrl_dom_linux_build_failure (int_of_string code, msg))
| [ "hvm_build_params" ; code; msg ] -> raise (Domain_builder_error ("hvm_build_params", int_of_string code, msg))
| [ "hvm_build_mem" ; code; msg ] -> raise (Domain_builder_error ("hvm_build_mem", int_of_string code, msg))
| [ "xc_domain_save" ; code; msg ] -> raise (Xenctrl_domain_save_failure (int_of_string code, msg))
| [ "xc_domain_resume" ; code; msg ] -> raise (Xenctrl_domain_resume_failure (int_of_string code, msg))
| [ "xc_domain_restore" ; code; msg ] -> raise (Xenctrl_domain_restore_failure (int_of_string code, msg))
| _ -> failwith (Printf.sprintf "Error from xenguesthelper: " ^ x)
end
| Suspend -> failwith "xenguesthelper protocol failure; not expecting Suspend"
| Result x -> x
| Stdout _ | Stderr _ | Info _ -> assert false