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
193
194
|
(*
* 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.
*)
(* Functions to safely fork potentially long-running sub-processes without
leaking file descriptors or accidentally deadlocking the parent process. *)
(* Functions should:
1. Arrange to close all fds except the ones they actually want to keep open
2. Not access any ocaml library or runtime function which might touch a lock
(since that would cause deadlock) *)
(* XXX: this is a work in progress *)
let default_path = [ "/sbin"; "/usr/sbin"; "/bin"; "/usr/bin" ]
open Pervasiveext
type pidty = (Unix.file_descr * int) (* The forking executioner has been used, therefore we need to tell *it* to waitpid *)
let string_of_pidty (fd, pid) = Printf.sprintf "(FEFork (%d,%d))" (Unixext.int_of_file_descr fd) pid
exception Subprocess_failed of int
exception Subprocess_killed of int
let waitpid (sock, pid) =
let status = Fecomms.read_raw_rpc sock in
Unix.close sock;
begin match status with
| Fe.Finished (Fe.WEXITED n) -> (pid,Unix.WEXITED n)
| Fe.Finished (Fe.WSIGNALED n) -> (pid,Unix.WSIGNALED n)
| Fe.Finished (Fe.WSTOPPED n) -> (pid,Unix.WSTOPPED n)
end
let waitpid_nohang ((sock, _) as x) =
(match Unix.select [sock] [] [] 0.0 with
| ([s],_,_) -> waitpid x
| _ -> (0,Unix.WEXITED 0))
let dontwaitpid (sock, pid) =
Unix.close sock
let waitpid_fail_if_bad_exit ty =
let (_,status) = waitpid ty in
match status with
| (Unix.WEXITED 0) -> ()
| (Unix.WEXITED n) -> raise (Subprocess_failed n)
| (Unix.WSIGNALED n) -> raise (Subprocess_killed n)
| (Unix.WSTOPPED n) -> raise (Subprocess_killed n)
let getpid (sock, pid) = pid
type 'a result = Success of string * 'a | Failure of string * exn
(** Creates a temporary file and opens it for logging. The fd is passed to the function
'f'. The logfile is guaranteed to be closed afterwards, and unlinked if either the delete flag is set or the call fails. If the
function 'f' throws an error then the log file contents are read in *)
let with_logfile_fd ?(delete = true) prefix f =
let logfile = Filename.temp_file prefix ".log" in
let read_logfile () =
let contents = Unixext.string_of_file logfile in
Unix.unlink logfile;
contents in
let log_fd = Unix.openfile logfile [ Unix.O_WRONLY; Unix.O_CREAT ] 0o0 in
try
let result = f log_fd in
Unix.close log_fd;
Success((if delete then read_logfile() else logfile), result)
with e ->
Unix.close log_fd;
Failure(read_logfile(), e)
exception Spawn_internal_error of string * string * Unix.process_status
let id = ref 0
type syslog_stdout_t =
| NoSyslogging
| Syslog_DefaultKey
| Syslog_WithKey of string
(** Safe function which forks a command, closing all fds except a whitelist and
having performed some fd operations in the child *)
let safe_close_and_exec ?env stdin stdout stderr (fds: (string * Unix.file_descr) list) ?(syslog_stdout=NoSyslogging)
(cmd: string) (args: string list) =
let sock = Fecomms.open_unix_domain_sock_client "/var/lib/xcp/forker/main" in
let stdinuuid = Uuid.to_string (Uuid.make_uuid ()) in
let stdoutuuid = Uuid.to_string (Uuid.make_uuid ()) in
let stderruuid = Uuid.to_string (Uuid.make_uuid ()) in
let fds_to_close = ref [] in
let add_fd_to_close_list fd = fds_to_close := fd :: !fds_to_close in
let remove_fd_from_close_list fd = fds_to_close := List.filter (fun fd' -> fd' <> fd) !fds_to_close in
let close_fds () = List.iter (fun fd -> Unix.close fd) !fds_to_close in
finally (fun () ->
let maybe_add_id_to_fd_map id_to_fd_map (uuid,fd,v) =
match v with
| Some _ -> (uuid, fd)::id_to_fd_map
| None -> id_to_fd_map
in
let predefined_fds = [
(stdinuuid, Some 0, stdin);
(stdoutuuid, Some 1, stdout);
(stderruuid, Some 2, stderr)]
in
(* We don't care what fd these end up as - they're named in the argument list for us, and the
forking executioner will sort it out. *)
let dest_named_fds = List.map (fun (uuid,_) -> (uuid,None)) fds in
let id_to_fd_map = List.fold_left maybe_add_id_to_fd_map dest_named_fds predefined_fds in
let env = match env with
| Some e -> e
| None -> [| "PATH=" ^ (String.concat ":" default_path) |]
in
let syslog_stdout = match syslog_stdout with
| NoSyslogging -> {Fe.enabled=false; Fe.key=None}
| Syslog_DefaultKey -> {Fe.enabled=true; Fe.key=None}
| Syslog_WithKey k -> {Fe.enabled=true; Fe.key=Some k}
in
Fecomms.write_raw_rpc sock (Fe.Setup {Fe.cmdargs=(cmd::args); env=(Array.to_list env); id_to_fd_map = id_to_fd_map; syslog_stdout = syslog_stdout});
let response = Fecomms.read_raw_rpc sock in
let s = match response with
| Fe.Setup_response s -> s
| _ -> failwith "Failed to communicate with forking executioner"
in
let fd_sock = Fecomms.open_unix_domain_sock_client s.Fe.fd_sock_path in
add_fd_to_close_list fd_sock;
let send_named_fd uuid fd =
Fecomms.send_named_fd fd_sock uuid fd;
in
List.iter (fun (uuid,_,srcfdo) ->
match srcfdo with Some srcfd -> send_named_fd uuid srcfd | None -> ()) predefined_fds;
List.iter (fun (uuid,srcfd) ->
send_named_fd uuid srcfd) fds;
Fecomms.write_raw_rpc sock Fe.Exec;
match Fecomms.read_raw_rpc sock with Fe.Execed pid -> (sock, pid))
close_fds
let execute_command_get_output_inner ?env ?stdin ?(syslog_stdout=NoSyslogging) cmd args =
let stdinandpipes = Opt.map (fun str ->
let (x,y) = Unix.pipe () in
(str,x,y)) stdin in
Pervasiveext.finally (fun () ->
match with_logfile_fd "execute_command_get_out" (fun out_fd ->
with_logfile_fd "execute_command_get_err" (fun err_fd ->
let (sock,pid) = safe_close_and_exec ?env (Opt.map (fun (_,fd,_) -> fd) stdinandpipes) (Some out_fd) (Some err_fd) [] ~syslog_stdout cmd args in
Opt.map (fun (str,_,wr) -> Unixext.really_write_string wr str) stdinandpipes;
match Fecomms.read_raw_rpc sock with
| Fe.Finished x -> Unix.close sock; x
| _ -> Unix.close sock; failwith "Communications error"
)) with
| Success(out,Success(err,(status))) ->
begin
match status with
| Fe.WEXITED 0 -> (out,err)
| Fe.WEXITED n -> raise (Spawn_internal_error(err,out,Unix.WEXITED n))
| Fe.WSTOPPED n -> raise (Spawn_internal_error(err,out,Unix.WSTOPPED n))
| Fe.WSIGNALED n -> raise (Spawn_internal_error(err,out,Unix.WSIGNALED n))
end
| Success(_,Failure(_,exn))
| Failure(_, exn) ->
raise exn)
(fun () -> Opt.iter (fun (_,x,y) -> Unix.close x; Unix.close y) stdinandpipes)
let execute_command_get_output ?env ?(syslog_stdout=NoSyslogging) cmd args =
execute_command_get_output_inner ?env ?stdin:None ~syslog_stdout cmd args
let execute_command_get_output_send_stdin ?env ?(syslog_stdout=NoSyslogging) cmd args stdin =
execute_command_get_output_inner ?env ~stdin ~syslog_stdout cmd args
|
