]>
Commit | Line | Data |
---|---|---|
aff192e6 DM |
1 | use PVE::SourceFilter; |
2 | ||
3 | package PVE::ConfigServer; | |
4 | ||
5 | use strict; | |
6 | use vars qw(@ISA); | |
7 | use Carp; | |
8 | use PVE::SafeSyslog; | |
9 | use File::stat; | |
10 | use IO::File; | |
11 | use Fcntl qw(:flock); | |
12 | use MIME::Base64; | |
13 | use PVE::Cluster; | |
14 | use PVE::Utils; | |
15 | use PVE::Config; | |
16 | use IO::Socket::INET; | |
17 | use Digest::SHA1; | |
18 | use PVE::QemuServer; | |
19 | use PVE::APLInfo; | |
20 | use IPC::Open2; | |
21 | use PVE::OpenVZ; | |
22 | use PVE::Qemu; | |
23 | use PVE::Storage; | |
24 | ||
25 | use base 'Exporter'; | |
26 | our @EXPORT = qw($pve_config_daemon); | |
27 | our $pve_config_daemon; | |
28 | ||
29 | my $get_userid = sub { # private method | |
30 | my ($class) = @_; | |
31 | ||
32 | if ($pve_config_daemon) { | |
33 | return $pve_config_daemon->{pve}->{username}; | |
34 | } | |
35 | ||
36 | die "internal error"; | |
37 | }; | |
38 | ||
39 | my $get_ticket = sub { # private method | |
40 | my ($class) = @_; | |
41 | ||
42 | if ($pve_config_daemon) { | |
43 | return $pve_config_daemon->{pve}->{ticket}; | |
44 | } | |
45 | ||
46 | die "internal error"; | |
47 | }; | |
48 | ||
49 | sub alive { ##SOAP_EXPORT## | |
50 | my ($class) = @_; | |
51 | ||
52 | return 1; | |
53 | } | |
54 | ||
55 | sub update_ticket { ##SOAP_EXPORT## | |
56 | my ($class) = @_; | |
57 | ||
58 | # ticket is magically updated by the server before | |
59 | # this function is called. | |
60 | my $ticket = $class->$get_ticket(); | |
61 | ||
62 | return $ticket; | |
63 | } | |
64 | ||
65 | sub ping { ##SOAP_EXPORT## | |
66 | my ($class) = @_; | |
67 | ||
68 | my $userid = $class->$get_userid(); | |
69 | ||
70 | my $cinfo = PVE::Cluster::clusterinfo (); | |
71 | ||
72 | my $status = { time => time (), insync => 1 }; | |
73 | ||
74 | $status->{uptime} = PVE::Utils::get_uptime (); | |
75 | $status->{cpuinfo} = PVE::Utils::get_cpu_info (); | |
76 | $status->{meminfo} = PVE::Utils::get_memory_info (); | |
77 | $status->{hdinfo}->{root} = PVE::Utils::get_hd_info ('/'); | |
78 | ||
79 | my $procstat = PVE::Utils::read_proc_stat(); | |
80 | $status->{cpu} = $procstat->{cpu}; | |
81 | $status->{wait} = $procstat->{wait}; | |
82 | ||
83 | my $syncstatus = PVE::Config::read_file ("syncstatus"); | |
84 | ||
85 | foreach my $ni (@{$cinfo->{nodes}}) { | |
86 | my $cid = $ni->{cid}; | |
87 | next if $cinfo->{local}->{cid} == $cid; # skip local CID | |
88 | my $lastsync = defined ($syncstatus->{$cid}) ? | |
89 | $syncstatus->{$cid}->{lastsync} : 0; | |
90 | $status->{"lastsync_$cid"} = $lastsync; | |
91 | my $sdiff = time() - $lastsync; | |
92 | $sdiff = 0 if $sdiff < 0; | |
93 | $status->{insync} = 0 if ($sdiff > (60*3)); | |
94 | } | |
95 | ||
96 | return $status; | |
97 | } | |
98 | ||
99 | sub vzlist { ##SOAP_EXPORT## | |
100 | my ($class) = @_; | |
101 | ||
102 | my $userid = $class->$get_userid(); | |
103 | ||
104 | my $res = {}; | |
105 | ||
106 | # openvz | |
107 | eval { | |
108 | $res = PVE::OpenVZ::vmlist(); | |
109 | }; | |
110 | ||
111 | my $err = $@; | |
112 | ||
113 | if ($err) { | |
114 | syslog ('err', "ERROR: $err"); | |
115 | } else { | |
116 | $res->{openvz} = 1; | |
117 | } | |
118 | ||
119 | # qemu | |
120 | eval { | |
121 | ||
122 | my $qmlist = PVE::Qemu::vmlist(); | |
123 | ||
124 | foreach my $vekey (keys %$qmlist) { | |
125 | if (!$res->{$vekey}) { | |
126 | $res->{$vekey} = $qmlist->{$vekey}; | |
127 | } else { | |
128 | syslog ('err', "found duplicated ID '$vekey' - ignoring qemu instance\n"); | |
129 | } | |
130 | } | |
131 | }; | |
132 | ||
133 | $err = $@; | |
134 | ||
135 | if ($err) { | |
136 | syslog ('err', "ERROR: $err"); | |
137 | } else { | |
138 | $res->{qemu} = 1; | |
139 | } | |
140 | ||
141 | $res->{lasttime} = time(); | |
142 | ||
143 | my $pc = PVE::Config::update_file ('pcounter', 'vzlist'); | |
144 | $res->{version} = $pc->{vzlist}; | |
145 | ||
146 | return $res; | |
147 | } | |
148 | ||
149 | sub vmlogview { ##SOAP_EXPORT## | |
150 | my ($class, $cid, $veid, $service) = @_; | |
151 | ||
152 | my $userid = $class->$get_userid(); | |
153 | ||
154 | my $filename = "/var/lib/vz/private/$veid/var/log/syslog"; | |
155 | ||
156 | if ($service eq 'init') { | |
157 | $filename = "/var/lib/vz/private/$veid/var/log/init.log"; | |
158 | } elsif ($service eq 'syslog') { | |
159 | # some systems (rh,centos) logs to messages instead | |
160 | my $msglog = "/var/lib/vz/private/$veid/var/log/messages"; | |
161 | if ((! -f $filename) && (-f $msglog)) { | |
162 | $filename = $msglog; | |
163 | } | |
164 | } | |
165 | ||
166 | my $lines = []; | |
167 | ||
168 | my $limit = 200; | |
169 | ||
170 | open (TMP, "tail -$limit $filename|"); | |
171 | while (my $line = <TMP>) { | |
172 | chomp $line; | |
173 | push @$lines, $line; | |
174 | } | |
175 | close (TMP); | |
176 | ||
177 | return $lines; | |
178 | } | |
179 | ||
180 | sub vmconfig { ##SOAP_EXPORT## | |
181 | my ($class, $veid, $type) = @_; | |
182 | ||
183 | my $userid = $class->$get_userid(); | |
184 | ||
185 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
186 | ||
187 | my $res; | |
188 | ||
189 | $res->{vzlist} = $class->vzlist(); | |
190 | ||
191 | if (($type eq 'qemu') && !$res->{vzlist}->{qemu}) { | |
192 | die "unable to get qemu-server vm list - server not running?\n"; | |
193 | } | |
194 | if (($type eq 'openvz') && !$res->{vzlist}->{openvz}) { | |
195 | die "unable to get openvz vm list?\n"; | |
196 | } | |
197 | ||
198 | if (my $d = $res->{vzlist}->{"VEID_$veid"}) { | |
199 | die "virtualization type mismatch" if $type ne $d->{type}; | |
200 | ||
201 | if ($d->{type} eq 'openvz') { | |
202 | $res->{config} = PVE::Config::get_veconfig ($veid); | |
203 | } elsif ($d->{type} eq 'qemu') { | |
204 | $res->{config} = PVE::Config::get_qmconfig ($veid); | |
205 | } else { | |
206 | die "internal error"; | |
207 | } | |
208 | } else { | |
209 | die "unable to get configuration data for VEID '$veid'"; | |
210 | } | |
211 | ||
212 | return $res; | |
213 | } | |
214 | ||
215 | sub cluster_vzlist { ##SOAP_EXPORT## | |
216 | my ($class, $cid, $vzlist) = @_; | |
217 | ||
218 | my $userid = $class->$get_userid(); | |
219 | ||
220 | my $newlist = PVE::Config::update_file ('vzlist', $vzlist, $cid); | |
221 | ||
222 | my $vmops = PVE::Config::read_file ("vmops"); | |
223 | ||
224 | PVE::Utils::foreach_vmrec ($vmops, sub { | |
225 | my ($cid, $vmid, $d, $ckey, $vmkey) = @_; | |
226 | my $old = $newlist->{$ckey}->{$vmkey}; | |
227 | ||
228 | # command still running ? | |
229 | my $pstart; | |
230 | if ($old && PVE::Utils::check_process ($d->{pid}, $d->{pstart})) { | |
231 | ||
232 | $old->{status} = $d->{command}; | |
233 | ||
234 | if ($d->{command} eq 'migrate') { | |
235 | PVE::Utils::foreach_vmrec ($newlist, sub { | |
236 | my ($ncid, $nvmid, $nd) = @_; | |
237 | $nd->{status} = 'migrate' if ($nvmid eq $vmid); | |
238 | }); | |
239 | } | |
240 | } | |
241 | }); | |
242 | ||
243 | return $newlist; | |
244 | } | |
245 | ||
246 | # start long running workers | |
247 | # $data append to the returned uniquely identifier, which | |
248 | # has the following format: "UPID:$pid-$pstart:$startime:$dtype:$data" | |
249 | # STDIN is redirected to /dev/null | |
250 | # STDOUT,STDERR are redirected to the filename returned by upid_decode | |
251 | # that file is locked wit flock to make sure only one process | |
252 | # is writing it | |
253 | ||
254 | my $fork_worker = sub { # private method | |
255 | my ($class, $dtype, $data, $function) = @_; | |
256 | ||
257 | my $cpid; | |
258 | ||
259 | $dtype = 'unknown' if !defined ($dtype); | |
260 | ||
261 | $data = '' if !defined ($data); | |
262 | ||
263 | my $starttime = time (); | |
264 | ||
265 | my @psync = POSIX::pipe(); | |
266 | ||
267 | # detect filename with faked PID | |
268 | my $tmp = PVE::Utils::upid_decode ("UPID:0-0:0:$dtype:$data"); | |
269 | my $filename = $tmp->{filename}; | |
270 | ||
271 | my $lockfh; | |
272 | # lock output file | |
273 | if ($filename) { | |
274 | ||
275 | $lockfh = IO::File->new ($filename, O_WRONLY|O_CREAT) || | |
276 | die "unable to open output file - $!\n"; | |
277 | ||
278 | my $wwwid = getpwnam('www-data'); | |
279 | chown $wwwid, $filename; | |
280 | ||
281 | if (!flock ($lockfh, LOCK_EX|LOCK_NB)) { | |
282 | undef $lockfh; # close | |
283 | die "unable to lock output file\n"; | |
284 | } | |
285 | ||
286 | if (!truncate ($lockfh, 0)) { | |
287 | die "unable to truncate output file - $!\n"; | |
288 | } | |
289 | } | |
290 | ||
291 | if (($cpid = fork()) == 0) { | |
292 | ||
293 | $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub { die "received interrupt\n"; }; | |
294 | ||
295 | $SIG{CHLD} = $SIG{PIPE} = 'DEFAULT'; | |
296 | ||
297 | # set sess/process group - we want to be able to kill the | |
298 | # whole process group | |
299 | POSIX::setsid(); | |
300 | ||
301 | POSIX::close ($psync[0]); | |
302 | ||
303 | PVE::Config::inotify_close(); | |
304 | ||
305 | # we close the socket | |
306 | my $httpd = $pve_config_daemon->{_daemon}; | |
307 | $httpd->close(); | |
308 | ||
309 | # same algorythm as used inside SA | |
310 | ||
311 | # STDIN = /dev/null | |
312 | my $fd = fileno (STDIN); | |
313 | close STDIN; | |
314 | POSIX::close(0) if $fd != 0; | |
315 | ||
316 | if (!open (STDIN, "</dev/null")) { | |
317 | POSIX::_exit (1); | |
318 | kill ('KILL', $$); | |
319 | } | |
320 | ||
321 | # redirect STDOUT | |
322 | $fd = fileno(STDOUT); | |
323 | close STDOUT; | |
324 | POSIX::close (1) if $fd != 1; | |
325 | ||
326 | if ($filename) { | |
327 | if (!open (STDOUT, ">&", $lockfh)) { | |
328 | POSIX::_exit (1); | |
329 | kill ('KILL', $$); | |
330 | } | |
331 | ||
332 | STDOUT->autoflush (1); | |
333 | } else { | |
334 | if (!open (STDOUT, ">/dev/null")) { | |
335 | POSIX::_exit (1); | |
336 | kill ('KILL', $$); | |
337 | } | |
338 | } | |
339 | ||
340 | # redirect STDERR to STDOUT | |
341 | $fd = fileno (STDERR); | |
342 | close STDERR; | |
343 | POSIX::close(2) if $fd != 2; | |
344 | ||
345 | if (!open (STDERR, ">&1")) { | |
346 | POSIX::_exit (1); | |
347 | kill ('KILL', $$); | |
348 | } | |
349 | ||
350 | STDERR->autoflush (1); | |
351 | ||
352 | my $pstart = PVE::Utils::read_proc_starttime ($$) || | |
353 | die "unable to read process starttime"; | |
354 | ||
355 | my $upid = PVE::Utils::upid_encode ({ | |
356 | pid => $$, pstart => $pstart, starttime => $starttime, | |
357 | type => $dtype, data => $data }); | |
358 | ||
359 | # sync with parent | |
360 | POSIX::write ($psync[1], $upid, length ($upid)); | |
361 | POSIX::close ($psync[1]); | |
362 | ||
363 | &$function ($upid); | |
364 | ||
365 | die "should not be reached"; | |
366 | } | |
367 | ||
368 | POSIX::close ($psync[1]); | |
369 | ||
370 | # sync with child (wait until child starts) | |
371 | my $upid = ''; | |
372 | POSIX::read($psync[0], $upid, 4096); | |
373 | POSIX::close ($psync[0]); | |
374 | ||
375 | if ($lockfh) { | |
376 | undef $lockfh; # close | |
377 | } | |
378 | ||
379 | my $uh = PVE::Utils::upid_decode ($upid); | |
380 | if (!$uh || | |
381 | !($uh->{pid} == $cpid && $uh->{starttime} == $starttime && | |
382 | $uh->{type} eq $dtype && $uh->{data} eq $data)) { | |
383 | syslog ('err', "got strange upid - $upid\n"); | |
384 | } | |
385 | ||
386 | PVE::Utils::register_worker ($cpid); | |
387 | ||
388 | return $upid; | |
389 | }; | |
390 | ||
391 | # UPID: unique worker process descriptor | |
392 | # | |
393 | # general format used by fork_worker is | |
394 | # UPID:$pid-$pstart:$start:$type:$data | |
395 | # | |
396 | # $pid ... process id of worker | |
397 | # $pstart ... process start time from /proc/pid/stat | |
398 | # $start ... time (epoch) when process started | |
399 | # $type ... string to identity format of $data | |
400 | # $data ... arbitrary text | |
401 | # | |
402 | # speicalized format we use is | |
403 | # UPID:$pid-$pstart:$start:vmops:$command:$cid:$veid | |
404 | # | |
405 | # $command ... create, start, stop, destroy | |
406 | # $cid,$veid ... cluster identity of VE | |
407 | # | |
408 | # Note: PIDs are recycled, so to test if a process is still running | |
409 | # we use (PID,PSTART) pair. | |
410 | ||
411 | my $vmcommand = sub { # private method | |
412 | my ($class, $userid, $command, $cid, $veid, $code) = @_; | |
413 | ||
414 | my $remip; | |
415 | my $remcmd = []; | |
416 | ||
417 | $userid = 'unknown' if !$userid; | |
418 | ||
419 | my $cinfo = PVE::Cluster::clusterinfo (); | |
420 | ||
421 | if ($cid != $cinfo->{local}->{cid}) { | |
422 | $remip = $cinfo->{"CID_$cid"}->{ip}; | |
423 | # we force tty allocation in order to tranfer signals (kill) | |
424 | $remcmd = ['/usr/bin/ssh', '-t', '-t', '-n', '-o', 'BatchMode=yes', $remip]; | |
425 | } | |
426 | ||
427 | my $realcmd = sub { | |
428 | my $upid = shift; | |
429 | ||
430 | print "$upid\n"; | |
431 | ||
432 | my $res = -1; | |
433 | ||
434 | eval { | |
435 | $res = &$code ($upid, $remip, $remcmd, $cinfo); | |
436 | ||
437 | my $ticket = $class->$get_ticket(); | |
438 | ||
439 | my $rcon = PVE::ConfigClient::connect ($ticket, $cinfo, $cid); | |
440 | if (my $vzlist = $rcon->vzlist()->result) { | |
441 | PVE::Config::update_file ('vzlist', $vzlist, $cid); | |
442 | } | |
443 | }; | |
444 | ||
445 | my $err = $@; | |
446 | ||
447 | if ($err) { | |
448 | syslog ('err', $err); | |
449 | print STDERR "\n$err"; | |
450 | exit (-1); | |
451 | } | |
452 | ||
453 | print STDERR "\n"; # flush | |
454 | exit ($res); | |
455 | }; | |
456 | ||
457 | if (my $uid = $class->$fork_worker ('vmops', "$command:$cid:$veid:$userid", $realcmd)) { | |
458 | ||
459 | PVE::Config::update_file ("vmops", $uid); | |
460 | ||
461 | return $uid; ; | |
462 | } | |
463 | ||
464 | return undef; | |
465 | }; | |
466 | ||
467 | sub apl_start_download { ##SOAP_EXPORT## | |
468 | my ($class, $aplname) = @_; | |
469 | ||
470 | my $userid = $class->$get_userid(); | |
471 | ||
472 | my $pkglist = PVE::APLInfo::load_data(); | |
473 | ||
474 | my $data; | |
475 | ||
476 | if (!$pkglist || !$aplname || !($data = $pkglist->{'all'}->{$aplname})) { | |
477 | syslog ('err', "download failed: no aplinfo for appliance '$aplname'"); | |
478 | return; | |
479 | } | |
480 | ||
481 | my $realcmd = sub { | |
482 | my $upid = shift; | |
483 | ||
484 | print "$upid\n"; | |
485 | ||
486 | my $tmp = "/tmp/apldownload-$$-tmp.dat"; | |
487 | ||
488 | eval { | |
489 | my $msg = "starting download: $aplname"; | |
490 | syslog ('info', $msg); | |
491 | print STDERR "$msg\n"; | |
492 | ||
493 | my $src = $data->{location}; | |
494 | my $dest = "/var/lib/vz/template/cache/$aplname"; | |
495 | ||
496 | if (-f $dest) { | |
497 | my $md5 = (split (/\s/, `md5sum '$dest'`))[0]; | |
498 | ||
499 | if ($md5 && (lc($md5) eq lc($data->{md5sum}))) { | |
500 | $msg = "file already exists $md5 - no need to download"; | |
501 | syslog ('info', $msg); | |
502 | print STDERR "$msg\n"; | |
503 | return; | |
504 | } | |
505 | } | |
506 | ||
507 | local %ENV; | |
508 | my $pvecfg = PVE::Config::read_file('pvecfg'); | |
509 | if ($pvecfg && $pvecfg->{http_proxy}) { | |
510 | $ENV{http_proxy} = $pvecfg->{http_proxy}; | |
511 | } | |
512 | ||
513 | my @cmd = ('/usr/bin/wget', '--progress=dot:mega', '-O', $tmp, $src); | |
514 | if (system (@cmd) != 0) { | |
515 | die "download failed - $!\n"; | |
516 | } | |
517 | ||
518 | my $md5 = (split (/\s/, `md5sum '$tmp'`))[0]; | |
519 | ||
520 | if (!$md5 || (lc($md5) ne lc($data->{md5sum}))) { | |
521 | die "wrong checksum: $md5 != $data->{md5sum}\n"; | |
522 | } | |
523 | ||
524 | if (system ('mv', $tmp, $dest) != 0) { | |
525 | die "unable to save file - $!\n"; | |
526 | } | |
527 | }; | |
528 | ||
529 | my $err = $@; | |
530 | ||
531 | unlink $tmp; | |
532 | ||
533 | if ($err) { | |
534 | syslog ('err', $err); | |
535 | print STDERR "\n\ndownload failed: $err"; | |
536 | exit (-1); | |
537 | } | |
538 | ||
539 | syslog ('info', "download finished"); | |
540 | print STDERR "download finished\n"; | |
541 | ||
542 | exit (0); | |
543 | }; | |
544 | ||
545 | if (my $uid = $class->$fork_worker ('apldownload', "$userid:$aplname", $realcmd)) { | |
546 | return $uid; | |
547 | } | |
548 | ||
549 | return undef; | |
550 | } | |
551 | ||
552 | sub vmconfig_set { ##SOAP_EXPORT## | |
553 | my ($class, $cid, $veid, $type, $settings) = @_; | |
554 | ||
555 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
556 | ||
557 | my $userid = $class->$get_userid(); | |
558 | ||
559 | my $cinfo = PVE::Cluster::clusterinfo (); | |
560 | ||
561 | my $remip; | |
562 | my $remcmd = []; | |
563 | ||
564 | if ($cid != $cinfo->{local}->{cid}) { | |
565 | $remip = $cinfo->{"CID_$cid"}->{ip}; | |
566 | $remcmd = ['/usr/bin/ssh', '-n', '-o', 'BatchMode=yes', $remip]; | |
567 | } | |
568 | ||
569 | return if !$settings; | |
570 | ||
571 | my $param; | |
572 | ||
573 | foreach my $key (keys %$settings) { | |
574 | die "invalid key '$key'" if $key !~ m/^\w+$/; | |
575 | my $v = $settings->{$key}; | |
576 | next if !defined ($v); | |
577 | if (ref ($v) eq 'ARRAY') { | |
578 | foreach my $v1 (@$v) { | |
579 | push @$param, "--$key", $remip ? PVE::Utils::shellquote ($v1) : $v1; | |
580 | } | |
581 | } else { | |
582 | push @$param, "--$key", $remip ? PVE::Utils::shellquote ($v) : $v; | |
583 | } | |
584 | } | |
585 | ||
586 | return if scalar (@$param) == 0; | |
587 | ||
588 | $remip = 'localhost' if !$remip; | |
589 | ||
590 | syslog ('info', "apply settings to VM $veid on node $cid ($remip)"); | |
591 | ||
592 | my @cmd; | |
593 | ||
594 | if ($type eq 'openvz') { | |
595 | @cmd = (@$remcmd, '/usr/bin/pvectl', 'vzset', $veid, @$param); | |
596 | } else { | |
597 | @cmd = (@$remcmd, '/usr/sbin/qm', 'set', $veid, @$param); | |
598 | } | |
599 | ||
600 | if (system (@cmd) != 0) { | |
601 | my $cmdstr = join (' ', @cmd); | |
602 | my $msg = "unable to apply VM settings, command failed: $cmdstr\n"; | |
603 | syslog ('err', $msg); | |
604 | die "$msg\n"; | |
605 | } | |
606 | ||
607 | my $msg = "VM $veid settings applied"; | |
608 | syslog ('info', $msg); | |
609 | } | |
610 | ||
611 | # set cdrom for qemu/kvm | |
612 | sub vmconfig_setcdrom { ##SOAP_EXPORT## | |
613 | my ($class, $cid, $veid, $device, $volid) = @_; | |
614 | ||
615 | my $userid = $class->$get_userid(); | |
616 | ||
617 | my $cinfo = PVE::Cluster::clusterinfo (); | |
618 | ||
619 | my $remip; | |
620 | my $remcmd = []; | |
621 | ||
622 | if ($cid != $cinfo->{local}->{cid}) { | |
623 | $remip = $cinfo->{"CID_$cid"}->{ip}; | |
624 | $remcmd = ['/usr/bin/ssh', '-n', '-o', 'BatchMode=yes', $remip]; | |
625 | } | |
626 | ||
627 | my $param; | |
628 | ||
629 | die "invalid device name '$device'" if $device !~ m/^\w+$/; | |
630 | ||
631 | push @$param, "--$device", $remip ? PVE::Utils::shellquote ($volid) : $volid; | |
632 | ||
633 | return if scalar (@$param) == 0; | |
634 | ||
635 | $remip = 'localhost' if !$remip; | |
636 | ||
637 | syslog ('info', "setting cdrom on VM $veid on node $cid ($remip)"); | |
638 | ||
639 | my @cmd = (@$remcmd, '/usr/sbin/qm', 'cdrom', $veid, @$param); | |
640 | ||
641 | if (system (@cmd) != 0) { | |
642 | my $cmdstr = join (' ', @cmd); | |
643 | my $msg = "unable to set cdrom, command failed: $cmdstr\n"; | |
644 | syslog ('err', $msg); | |
645 | die "$msg\n"; | |
646 | } | |
647 | ||
648 | my $msg = "VM $veid set cdrom"; | |
649 | syslog ('info', $msg); | |
650 | } | |
651 | ||
652 | # delete unused qemu/kvm disk images | |
653 | sub qemu_unlink_disk { ##SOAP_EXPORT## | |
654 | my ($class, $cid, $veid, $filename) = @_; | |
655 | ||
656 | my $userid = $class->$get_userid(); | |
657 | ||
658 | my $cinfo = PVE::Cluster::clusterinfo (); | |
659 | ||
660 | my $remip; | |
661 | my $remcmd = []; | |
662 | ||
663 | if ($cid != $cinfo->{local}->{cid}) { | |
664 | $remip = $cinfo->{"CID_$cid"}->{ip}; | |
665 | $remcmd = ['/usr/bin/ssh', '-n', '-o', 'BatchMode=yes', $remip]; | |
666 | } | |
667 | ||
668 | $remip = 'localhost' if !$remip; | |
669 | ||
670 | syslog ('info', "delete image '$filename' on VM $veid on node $cid ($remip)"); | |
671 | ||
672 | my @cmd = (@$remcmd, '/usr/sbin/qm', 'unlink', $veid, $filename); | |
673 | ||
674 | if (system (@cmd) != 0) { | |
675 | my $cmdstr = join (' ', @cmd); | |
676 | my $msg = "unable to delete image, command failed: $cmdstr\n"; | |
677 | syslog ('err', $msg); | |
678 | die "$msg\n"; | |
679 | } | |
680 | ||
681 | my $msg = "VM $veid image '$filename' successfuly deleted"; | |
682 | syslog ('info', $msg); | |
683 | } | |
684 | ||
685 | sub vmcommand_create { ##SOAP_EXPORT## | |
686 | my ($class, $cid, $veid, $type, $settings) = @_; | |
687 | ||
688 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
689 | ||
690 | my $userid = $class->$get_userid(); | |
691 | ||
692 | return $class->$vmcommand ($userid, 'create', $cid, $veid, sub { | |
693 | my ($upid, $remip, $remcmd, $cinfo) = @_; | |
694 | ||
695 | ||
696 | my @cmd; | |
697 | ||
698 | if ($type eq 'openvz') { | |
699 | @cmd = (@$remcmd, '/usr/bin/pvectl', 'vzcreate', $veid); | |
700 | } else { | |
701 | @cmd = (@$remcmd, '/usr/sbin/qm', 'create', $veid); | |
702 | } | |
703 | ||
704 | foreach my $key (keys %$settings) { | |
705 | die "invalid key '$key'" if $key !~ m/^\w+$/; | |
706 | my $v = $settings->{$key}; | |
707 | next if !defined ($v); | |
708 | if (ref ($v) eq 'ARRAY') { | |
709 | foreach my $v1 (@$v) { | |
710 | push @cmd, "--$key", $remip ? PVE::Utils::shellquote ($v1) : $v1; | |
711 | } | |
712 | } else { | |
713 | push @cmd, "--$key", $remip ? PVE::Utils::shellquote ($v) : $v; | |
714 | } | |
715 | } | |
716 | ||
717 | $remip = 'localhost' if !$remip; | |
718 | ||
719 | syslog ('info', "creating new VM $veid on node $cid ($remip)"); | |
720 | ||
721 | my $cmdstr = join (' ', @cmd); | |
722 | print "$cmdstr\n"; | |
723 | ||
724 | if (system (@cmd) != 0) { | |
725 | ||
726 | my $msg = "unable to apply VM settings - $!"; | |
727 | syslog ('err', $msg); | |
728 | print "$msg\n"; | |
729 | return -1; | |
730 | } | |
731 | ||
732 | my $msg = "VM $veid created"; | |
733 | syslog ('info', $msg); | |
734 | print "$msg\n"; | |
735 | ||
736 | return 0; | |
737 | }); | |
738 | } | |
739 | ||
740 | sub vmcommand_destroy { ##SOAP_EXPORT## | |
741 | my ($class, $cid, $veid, $type) = @_; | |
742 | ||
743 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
744 | ||
745 | my $userid = $class->$get_userid(); | |
746 | ||
747 | return $class->$vmcommand ($userid, 'destroy', $cid, $veid, sub { | |
748 | my ($upid, $remip, $remcmd, $cinfo) = @_; | |
749 | ||
750 | $remip = 'localhost' if !$remip; | |
751 | ||
752 | syslog ('info', "destroying VM $veid on node $cid ($remip)"); | |
753 | ||
754 | my @cmd; | |
755 | ||
756 | if ($type eq 'openvz') { | |
757 | @cmd = (@$remcmd, '/usr/sbin/vzctl', 'destroy', $veid); | |
758 | } else { | |
759 | @cmd = (@$remcmd, '/usr/sbin/qm', 'destroy', $veid); | |
760 | } | |
761 | ||
762 | my $cmdstr = join (' ', @cmd); | |
763 | ||
764 | print "$cmdstr\n"; | |
765 | ||
766 | if (system (@cmd) != 0) { | |
767 | my $msg = "VM $veid destroy failed - $!"; | |
768 | syslog ('err', $msg); | |
769 | print "$msg\n"; | |
770 | return -1; | |
771 | } | |
772 | ||
773 | my $msg = "VM $veid destroyed"; | |
774 | syslog ('info', $msg); | |
775 | print "$msg\n"; | |
776 | ||
777 | return 0; | |
778 | }); | |
779 | } | |
780 | ||
781 | sub vmcommand_stop { ##SOAP_EXPORT## | |
782 | my ($class, $cid, $veid, $type, $force) = @_; | |
783 | ||
784 | my $userid = $class->$get_userid(); | |
785 | ||
786 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
787 | ||
788 | return $class->$vmcommand ($userid, 'stop', $cid, $veid, sub { | |
789 | my ($upid, $remip, $remcmd, $cinfo) = @_; | |
790 | ||
791 | $remip = 'localhost' if !$remip; | |
792 | ||
793 | syslog ('info', "stopping VM $veid on node $cid ($remip)"); | |
794 | ||
795 | my @cmd; | |
796 | ||
797 | if ($type eq 'openvz') { | |
798 | @cmd = (@$remcmd, '/usr/sbin/vzctl', 'stop', $veid); | |
799 | push @cmd, '--fast' if $force; | |
800 | } else { | |
801 | @cmd = (@$remcmd, '/usr/sbin/qm', $force ? 'stop' : 'shutdown', $veid); | |
802 | } | |
803 | ||
804 | my $cmdstr = join (' ', @cmd); | |
805 | ||
806 | print "$cmdstr\n"; | |
807 | ||
808 | if (system (@cmd) != 0) { | |
809 | my $msg = "VM $veid stop failed - $!"; | |
810 | syslog ('err', $msg); | |
811 | print "$msg\n"; | |
812 | return -1; | |
813 | } | |
814 | ||
815 | my $msg = "VM $veid stopped"; | |
816 | syslog ('info', $msg); | |
817 | print "$msg\n"; | |
818 | ||
819 | return 0; | |
820 | }); | |
821 | } | |
822 | ||
823 | sub vmcommand_umount { ##SOAP_EXPORT## | |
824 | my ($class, $cid, $veid, $type) = @_; | |
825 | ||
826 | die "unknown virtualization type '$type'\n" if $type ne 'openvz'; | |
827 | ||
828 | my $userid = $class->$get_userid(); | |
829 | ||
830 | return $class->$vmcommand ($userid, 'umount', $cid, $veid, sub { | |
831 | my ($upid, $remip, $remcmd, $cinfo) = @_; | |
832 | ||
833 | $remip = 'localhost' if !$remip; | |
834 | ||
835 | syslog ('info', "unmounting VM $veid on node $cid ($remip)"); | |
836 | ||
837 | my @cmd; | |
838 | ||
839 | @cmd = (@$remcmd, '/usr/sbin/vzctl', 'umount', $veid); | |
840 | ||
841 | my $cmdstr = join (' ', @cmd); | |
842 | ||
843 | print "$cmdstr\n"; | |
844 | ||
845 | if (system (@cmd) != 0) { | |
846 | my $msg = "VM $veid umount failed - $!"; | |
847 | syslog ('err', $msg); | |
848 | print "$msg\n"; | |
849 | return -1; | |
850 | } | |
851 | ||
852 | my $msg = "VM $veid unmounted"; | |
853 | syslog ('info', $msg); | |
854 | print "$msg\n"; | |
855 | ||
856 | return 0; | |
857 | }); | |
858 | } | |
859 | ||
860 | sub vmcommand_start { ##SOAP_EXPORT## | |
861 | my ($class, $cid, $veid, $type) = @_; | |
862 | ||
863 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
864 | ||
865 | my $userid = $class->$get_userid(); | |
866 | ||
867 | return $class->$vmcommand ($userid, 'start', $cid, $veid, sub { | |
868 | my ($upid, $remip, $remcmd, $cinfo) = @_; | |
869 | ||
870 | $remip = 'localhost' if !$remip; | |
871 | ||
872 | syslog ('info', "starting VM $veid on node $cid ($remip)"); | |
873 | ||
874 | my @cmd; | |
875 | ||
876 | if ($type eq 'openvz') { | |
877 | @cmd = (@$remcmd, '/usr/sbin/vzctl', 'start', $veid); | |
878 | } else { | |
879 | @cmd = (@$remcmd, '/usr/sbin/qm', 'start', $veid); | |
880 | } | |
881 | ||
882 | my $cmdstr = join (' ', @cmd); | |
883 | ||
884 | print "$cmdstr\n"; | |
885 | ||
886 | if (system (@cmd) != 0) { | |
887 | my $msg = "VM $veid start failed - $!"; | |
888 | syslog ('err', $msg); | |
889 | print "$msg\n"; | |
890 | return -1; | |
891 | } | |
892 | ||
893 | my $msg = "VM $veid started"; | |
894 | syslog ('info', $msg); | |
895 | print "$msg\n"; | |
896 | ||
897 | return 0; | |
898 | }); | |
899 | } | |
900 | ||
901 | sub vmcommand_restart { ##SOAP_EXPORT## | |
902 | my ($class, $cid, $veid, $type) = @_; | |
903 | ||
904 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
905 | ||
906 | my $userid = $class->$get_userid(); | |
907 | ||
908 | return $class->$vmcommand ($userid, 'restart', $cid, $veid, sub { | |
909 | my ($upid, $remip, $remcmd, $cinfo) = @_; | |
910 | ||
911 | $remip = 'localhost' if !$remip; | |
912 | ||
913 | syslog ('info', "restarting VM $veid on node $cid ($remip)"); | |
914 | ||
915 | my @cmd; | |
916 | ||
917 | if ($type eq 'openvz') { | |
918 | @cmd = (@$remcmd, '/usr/sbin/vzctl', 'restart', $veid); | |
919 | } else { | |
920 | @cmd = (@$remcmd, '/usr/sbin/qm', 'reset', $veid); | |
921 | } | |
922 | my $cmdstr = join (' ', @cmd); | |
923 | ||
924 | print "$cmdstr\n"; | |
925 | ||
926 | if (system (@cmd) != 0) { | |
927 | my $msg = "VM $veid restart failed - $!"; | |
928 | syslog ('err', $msg); | |
929 | print "$msg\n"; | |
930 | return -1; | |
931 | } | |
932 | ||
933 | my $msg = "VM $veid restarted"; | |
934 | syslog ('info', $msg); | |
935 | print "$msg\n"; | |
936 | ||
937 | return 0; | |
938 | }); | |
939 | } | |
940 | ||
941 | sub vmcommand_migrate { ##SOAP_EXPORT## | |
942 | my ($class, $cid, $veid, $type, $target, $online) = @_; | |
943 | ||
944 | die "unknown virtualization type '$type'\n" if !($type eq 'openvz' || $type eq 'qemu'); | |
945 | ||
946 | my $userid = $class->$get_userid(); | |
947 | ||
948 | my $cinfo = PVE::Cluster::clusterinfo (); | |
949 | ||
950 | return $class->$vmcommand ($userid, 'migrate', $cid, $veid, sub { | |
951 | my ($upid, $remip, $remcmd, $cinfo) = @_; | |
952 | ||
953 | $remip = 'localhost' if !$remip; | |
954 | ||
955 | my $targetip = $cinfo->{"CID_$target"}->{ip}; | |
956 | ||
957 | syslog ('info', "migrating VM $veid from node $cid ($remip) to node $target ($targetip)"); | |
958 | ||
959 | my @cmd; | |
960 | ||
961 | if ($type eq 'openvz') { | |
962 | @cmd = (@$remcmd, '/usr/sbin/vzmigrate'); | |
963 | push @cmd, '--online' if $online; | |
964 | push @cmd, $targetip; | |
965 | push @cmd, $veid; | |
966 | } else { | |
967 | @cmd = (@$remcmd, '/usr/sbin/qmigrate'); | |
968 | push @cmd, '--online' if $online; | |
969 | push @cmd, $targetip; | |
970 | push @cmd, $veid; | |
971 | } | |
972 | ||
973 | my $cmdstr = join (' ', @cmd); | |
974 | ||
975 | print "$cmdstr\n"; | |
976 | ||
977 | if (system (@cmd) != 0) { | |
978 | my $msg = "VM $veid migration failed - $!"; | |
979 | syslog ('err', $msg); | |
980 | print "$msg\n"; | |
981 | return -1; | |
982 | } | |
983 | ||
984 | my $msg = "VM $veid migration done"; | |
985 | syslog ('info', $msg); | |
986 | print "$msg\n"; | |
987 | ||
988 | return 0; | |
989 | }); | |
990 | } | |
991 | ||
992 | my $next_vnc_port = sub { # private method | |
993 | ||
994 | for (my $p = 5900; $p < 6000; $p++) { | |
995 | ||
996 | my $sock = IO::Socket::INET->new (Listen => 5, | |
997 | LocalAddr => 'localhost', | |
998 | LocalPort => $p, | |
999 | ReuseAddr => 1, | |
1000 | Proto => 0); | |
1001 | ||
1002 | if ($sock) { | |
1003 | close ($sock); | |
1004 | return $p; | |
1005 | } | |
1006 | } | |
1007 | ||
1008 | die "unable to find free vnc port"; | |
1009 | }; | |
1010 | ||
1011 | sub create_vnc_proxy { ##SOAP_EXPORT## | |
1012 | my ($class, $cid, $veid) = @_; | |
1013 | ||
1014 | my $remip; | |
1015 | my $remcmd = []; | |
1016 | ||
1017 | my $userid = $class->$get_userid(); | |
1018 | ||
1019 | my $cinfo = PVE::Cluster::clusterinfo (); | |
1020 | ||
1021 | if ($cid != $cinfo->{local}->{cid}) { | |
1022 | $remip = $cinfo->{"CID_$cid"}->{ip}; | |
1023 | $remcmd = ['/usr/bin/ssh', '-T', '-o', 'BatchMode=yes', $remip]; | |
1024 | } | |
1025 | ||
1026 | my $port = $class->$next_vnc_port(); | |
1027 | # generate ticket, olny first 8 character used by vnc | |
1028 | my $ticket = Digest::SHA1::sha1_base64 ($userid, rand(), time()); | |
1029 | ||
1030 | my $timeout = 30; | |
1031 | ||
1032 | my $realcmd = sub { | |
1033 | my $upid = shift; | |
1034 | ||
1035 | syslog ('info', "starting vnc proxy $upid\n"); | |
1036 | ||
1037 | my $qmcmd = [@$remcmd, "/usr/sbin/qm", 'vncproxy', $veid , $ticket]; | |
1038 | ||
1039 | my $qmstr = join (' ', @$qmcmd); | |
1040 | ||
1041 | # also redirect stderr (else we get RFB protocol errors) | |
1042 | my @cmd = ('/bin/nc', '-l', '-p', $port, '-w', $timeout, '-c', "$qmstr 2>/dev/null"); | |
1043 | ||
1044 | my $cmdstr = join (' ', @cmd); | |
1045 | syslog ('info', "CMD: $cmdstr"); | |
1046 | ||
1047 | if (system (@cmd) != 0) { | |
1048 | my $msg = "VM $veid vnc proxy failed - $?"; | |
1049 | syslog ('err', $msg); | |
1050 | exit (-1); | |
1051 | } | |
1052 | ||
1053 | exit (0); | |
1054 | }; | |
1055 | ||
1056 | if (my $uid = $class->$fork_worker ('vncproxy', "$cid:$veid:$userid:$port:$ticket", $realcmd)) { | |
1057 | return { port => $port, ticket => $ticket}; | |
1058 | } | |
1059 | ||
1060 | return undef; | |
1061 | ||
1062 | } | |
1063 | ||
1064 | sub create_vnc_console { ##SOAP_EXPORT## | |
1065 | my ($class, $cid, $veid, $type, $status) = @_; | |
1066 | ||
1067 | my $userid = $class->$get_userid(); | |
1068 | ||
1069 | my $remip; | |
1070 | my $remcmd = []; | |
1071 | ||
1072 | $userid = 'unknown' if !$userid; | |
1073 | ||
1074 | my $cinfo = PVE::Cluster::clusterinfo (); | |
1075 | ||
1076 | if ($cid != $cinfo->{local}->{cid}) { | |
1077 | $remip = $cinfo->{"CID_$cid"}->{ip}; | |
1078 | $remcmd = ['/usr/bin/ssh', '-t', $remip]; | |
1079 | } | |
1080 | ||
1081 | my $port = $class->$next_vnc_port(); | |
1082 | # generate ticket, olny first 8 character used by vnc | |
1083 | my $ticket = Digest::SHA1::sha1_base64 ($userid, rand(), time()); | |
1084 | ||
1085 | my $timeout = 1; # immediately exit when last client disconnects | |
1086 | ||
1087 | my $realcmd = sub { | |
1088 | my $upid = shift; | |
1089 | ||
1090 | syslog ('info', "starting vnc console $upid\n"); | |
1091 | ||
1092 | # fixme: use ssl | |
1093 | ||
1094 | my $pwfile = "/tmp/.vncpwfile.$$"; | |
1095 | ||
1096 | my $vzcmd; | |
1097 | ||
1098 | if ($type eq 'openvz') { | |
1099 | if ($status eq 'running') { | |
1100 | $vzcmd = [ '/usr/sbin/vzctl', 'enter', $veid ]; | |
1101 | } elsif ($status eq 'mounted') { | |
1102 | $vzcmd = [ "/usr/bin/pvebash", $veid, 'root']; | |
1103 | } else { | |
1104 | $vzcmd = [ "/usr/bin/pvebash", $veid, 'private']; | |
1105 | } | |
1106 | } elsif ($type eq 'qemu') { | |
1107 | $vzcmd = [ "/usr/sbin/qm", 'monitor', $veid ]; | |
1108 | } else { | |
1109 | $vzcmd = [ '/bin/true' ]; # should not be reached | |
1110 | } | |
1111 | ||
1112 | my @cmd = ('/usr/bin/vncterm', '-rfbport', $port, | |
1113 | '-passwdfile', "rm:$pwfile", | |
1114 | '-timeout', $timeout, '-c', @$remcmd, @$vzcmd); | |
1115 | ||
1116 | my $cmdstr = join (' ', @cmd); | |
1117 | syslog ('info', "CMD: $cmdstr"); | |
1118 | ||
1119 | my $fh = IO::File->new ($pwfile, "w", 0600); | |
1120 | print $fh "$ticket\n"; | |
1121 | $fh->close; | |
1122 | ||
1123 | if (system (@cmd) != 0) { | |
1124 | my $msg = "VM $veid console viewer failed - $?"; | |
1125 | syslog ('err', $msg); | |
1126 | exit (-1); | |
1127 | } | |
1128 | ||
1129 | exit (0); | |
1130 | }; | |
1131 | ||
1132 | if (my $uid = $class->$fork_worker ('vncview', "$cid:$veid:$userid:$port:$ticket", $realcmd)) { | |
1133 | ||
1134 | #PVE::Config::update_file ("vncview", $uid); | |
1135 | ||
1136 | return { port => $port, ticket => $ticket}; | |
1137 | } | |
1138 | ||
1139 | return undef; | |
1140 | ||
1141 | } | |
1142 | ||
1143 | sub service_cmd { ##SOAP_EXPORT## | |
1144 | my ($class, $service, $cmd) = @_; | |
1145 | ||
1146 | my $userid = $class->$get_userid(); | |
1147 | ||
1148 | eval { | |
1149 | my $res = PVE::Utils::service_cmd ($service, $cmd); | |
1150 | syslog ('info', $res) if $res; | |
1151 | syslog ('info', "service command '$service $cmd' successful"); | |
1152 | }; | |
1153 | ||
1154 | if (my $err = $@) { | |
1155 | syslog ('err', "service command '$service $cmd' failed : $err"); | |
1156 | } | |
1157 | } | |
1158 | ||
1159 | my $service_list = { | |
1160 | apache => { short => 'WWW', long => 'Web Server' }, | |
1161 | pvetunnel => { short => 'ClusterTunnel', | |
1162 | long => 'PVE Cluster Tunnel Daemon' }, | |
1163 | pvemirror => { short => 'ClusterSync', | |
1164 | long => 'PVE Cluster Synchronization Daemon' }, | |
1165 | postfix => { short => 'SMTP', long => 'Simple Mail Tranfer Protocol' }, | |
1166 | ntpd => { short => 'NTP', long => 'Network Time Protocol' }, | |
1167 | sshd => { short => 'SSH', long => 'Secure Shell Daemon' }, | |
1168 | # bind => { short => 'BIND', long => 'Local DNS Cache' }, | |
1169 | # pvedaemon => { short => 'NodeManager', long => 'PVE Node Manager Daemon' }, | |
1170 | }; | |
1171 | ||
1172 | sub service_state_all { ##SOAP_EXPORT## | |
1173 | my ($class) = @_; | |
1174 | ||
1175 | my $userid = $class->$get_userid(); | |
1176 | ||
1177 | my $res = {}; | |
1178 | ||
1179 | foreach my $s (keys %{$service_list}) { | |
1180 | $res->{$s} = $service_list->{$s}; | |
1181 | $res->{$s}->{status} = PVE::Utils::service_state ($s); | |
1182 | } | |
1183 | ||
1184 | return $res; | |
1185 | } | |
1186 | ||
1187 | sub restart_server { ##SOAP_EXPORT## | |
1188 | my ($class, $poweroff) = @_; | |
1189 | ||
1190 | my $userid = $class->$get_userid(); | |
1191 | ||
1192 | if ($poweroff) { | |
1193 | system ("(sleep 2;/sbin/poweroff)&"); | |
1194 | } else { | |
1195 | system ("(sleep 2;shutdown -r now)&"); | |
1196 | } | |
1197 | } | |
1198 | ||
1199 | sub check_worker { ##SOAP_EXPORT## | |
1200 | my ($class, $upid, $killit) = @_; | |
1201 | ||
1202 | my $userid = $class->$get_userid(); | |
1203 | ||
1204 | if (my $upid_hash = PVE::Utils::upid_decode ($upid)) { | |
1205 | ||
1206 | my $pid = $upid_hash->{pid}; | |
1207 | ||
1208 | # test if still running | |
1209 | return 0 if !PVE::Utils::check_process ($pid, $upid_hash->{pstart}); | |
1210 | ||
1211 | if ($killit) { | |
1212 | ||
1213 | # send kill to process group (negative pid) | |
1214 | my $kpid = -$pid; | |
1215 | ||
1216 | kill (15, $kpid); # send TERM signal | |
1217 | ||
1218 | # give max 5 seconds to shut down | |
1219 | # note: waitpid only work for child processes, but not | |
1220 | # for processes spanned by other processes, so we use | |
1221 | # kill to detect if the worker is still running | |
1222 | for (my $i = 0; $i < 5; $i++) { | |
1223 | last if !kill (0, $kpid); | |
1224 | sleep (1); | |
1225 | } | |
1226 | ||
1227 | if (kill (0, $kpid)) { | |
1228 | kill (9, $kpid); # kill if still alive | |
1229 | } | |
1230 | ||
1231 | return 0; # killed, not running | |
1232 | } else { | |
1233 | return 1; # running | |
1234 | } | |
1235 | } | |
1236 | ||
1237 | return 0; | |
1238 | } | |
1239 | ||
1240 | sub kvm_version { ##SOAP_EXPORT## | |
1241 | my ($class) = @_; | |
1242 | ||
1243 | my $userid = $class->$get_userid(); | |
1244 | ||
1245 | return PVE::QemuServer::kvm_version(); | |
1246 | } | |
1247 | ||
1248 | sub install_template { ##SOAP_EXPORT## | |
1249 | my ($class, $storeid, $type, $tmpname, $filename) = @_; | |
1250 | ||
1251 | my $userid = $class->$get_userid(); | |
1252 | ||
1253 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1254 | ||
1255 | PVE::Storage::install_template ($cfg, $storeid, $type, $tmpname, $filename); | |
1256 | } | |
1257 | ||
1258 | sub delete_volume { ##SOAP_EXPORT## | |
1259 | my ($class, $volid) = @_; | |
1260 | ||
1261 | my $userid = $class->$get_userid(); | |
1262 | ||
1263 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1264 | ||
1265 | PVE::Storage::vdisk_free ($cfg, $volid); | |
1266 | } | |
1267 | ||
1268 | sub get_config_data { ##SOAP_EXPORT## | |
1269 | my ($class, $id, $full) = @_; | |
1270 | ||
1271 | my $userid = $class->$get_userid(); | |
1272 | ||
1273 | return PVE::Config::read_file ($id, $full); | |
1274 | } | |
1275 | ||
1276 | sub set_config_data { ##SOAP_EXPORT## | |
1277 | my ($class, $id, $data, $full) = @_; | |
1278 | ||
1279 | my $userid = $class->$get_userid(); | |
1280 | ||
1281 | return PVE::Config::write_file ($id, $data, $full); | |
1282 | } | |
1283 | ||
1284 | sub update_config_data { ##SOAP_EXPORT## | |
1285 | my ($class, $id, $data, @param) = @_; | |
1286 | ||
1287 | my $userid = $class->$get_userid(); | |
1288 | ||
1289 | return PVE::Config::update_file ($id, $data, @param); | |
1290 | } | |
1291 | ||
1292 | sub discard_config_changes { ##SOAP_EXPORT## | |
1293 | my ($class, $id, $full) = @_; | |
1294 | ||
1295 | my $userid = $class->$get_userid(); | |
1296 | ||
1297 | return PVE::Config::discard_changes ($id, $full); | |
1298 | } | |
1299 | ||
1300 | sub modify_user { ##SOAP_EXPORT## | |
1301 | my ($class, $username, $group, $pw, $comment) = @_; | |
1302 | ||
1303 | my $userid = $class->$get_userid(); | |
1304 | ||
1305 | return PVE::Utils::modify_user ($username, $group, $pw, $comment); | |
1306 | } | |
1307 | ||
1308 | sub storage_list_volumes { ##SOAP_EXPORT## | |
1309 | my ($class, $storeid) = @_; | |
1310 | ||
1311 | my $userid = $class->$get_userid(); | |
1312 | ||
1313 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1314 | ||
1315 | return PVE::Storage::vdisk_list ($cfg, $storeid); | |
1316 | } | |
1317 | ||
1318 | sub storage_list_iso { ##SOAP_EXPORT## | |
1319 | my ($class, $storeid) = @_; | |
1320 | ||
1321 | my $userid = $class->$get_userid(); | |
1322 | ||
1323 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1324 | ||
1325 | return PVE::Storage::template_list ($cfg, $storeid, 'iso'); | |
1326 | } | |
1327 | ||
1328 | sub storage_list_vztmpl { ##SOAP_EXPORT## | |
1329 | my ($class, $storeid) = @_; | |
1330 | ||
1331 | my $userid = $class->$get_userid(); | |
1332 | ||
1333 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1334 | ||
1335 | return PVE::Storage::template_list ($cfg, $storeid, 'vztmpl'); | |
1336 | } | |
1337 | ||
1338 | sub storage_list_backups { ##SOAP_EXPORT## | |
1339 | my ($class, $storeid) = @_; | |
1340 | ||
1341 | my $userid = $class->$get_userid(); | |
1342 | ||
1343 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1344 | ||
1345 | return PVE::Storage::template_list ($cfg, $storeid, 'backup'); | |
1346 | } | |
1347 | ||
1348 | sub storage_list_vgs { ##SOAP_EXPORT## | |
1349 | my ($class) = @_; | |
1350 | ||
1351 | my $userid = $class->$get_userid(); | |
1352 | ||
1353 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1354 | ||
1355 | return PVE::Storage::lvm_vgs (); | |
1356 | } | |
1357 | ||
1358 | sub storage_add { ##SOAP_EXPORT## | |
1359 | my ($class, $storeid, $type, $param) = @_; | |
1360 | ||
1361 | my $userid = $class->$get_userid(); | |
1362 | ||
1363 | PVE::Storage::storage_add ($storeid, $type, $param); | |
1364 | } | |
1365 | ||
1366 | sub storage_set { ##SOAP_EXPORT## | |
1367 | my ($class, $storeid, $param, $digest) = @_; | |
1368 | ||
1369 | my $userid = $class->$get_userid(); | |
1370 | ||
1371 | PVE::Storage::storage_set ($storeid, $param, $digest); | |
1372 | } | |
1373 | ||
1374 | sub storage_remove { ##SOAP_EXPORT## | |
1375 | my ($class, $storeid, $digest) = @_; | |
1376 | ||
1377 | my $userid = $class->$get_userid(); | |
1378 | ||
1379 | PVE::Storage::storage_remove ($storeid, $digest); | |
1380 | } | |
1381 | ||
1382 | sub storage_enable { ##SOAP_EXPORT## | |
1383 | my ($class, $storeid, $digest) = @_; | |
1384 | ||
1385 | my $userid = $class->$get_userid(); | |
1386 | ||
1387 | PVE::Storage::storage_enable ($storeid, $digest); | |
1388 | } | |
1389 | ||
1390 | sub storage_disable { ##SOAP_EXPORT## | |
1391 | my ($class, $storeid, $digest) = @_; | |
1392 | ||
1393 | my $userid = $class->$get_userid(); | |
1394 | ||
1395 | PVE::Storage::storage_disable ($storeid, $digest); | |
1396 | } | |
1397 | ||
1398 | sub storage_scan_nfs { ##SOAP_EXPORT## | |
1399 | my ($class, $server) = @_; | |
1400 | ||
1401 | my $userid = $class->$get_userid(); | |
1402 | ||
1403 | return PVE::Storage::scan_nfs ($server); | |
1404 | } | |
1405 | ||
1406 | sub storage_scan_iscsi { ##SOAP_EXPORT## | |
1407 | my ($class, $portal, $skip_used) = @_; | |
1408 | ||
1409 | my $userid = $class->$get_userid(); | |
1410 | ||
1411 | my $res = PVE::Storage::scan_iscsi ($portal); | |
1412 | ||
1413 | return $res if !$skip_used; | |
1414 | ||
1415 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1416 | ||
1417 | my $unused = {}; | |
1418 | foreach my $target (keys %$res) { | |
1419 | if (!PVE::Storage::target_is_used ($cfg, $target)) { | |
1420 | $unused->{$target} = $res->{target} | |
1421 | } | |
1422 | } | |
1423 | return $unused; | |
1424 | } | |
1425 | ||
1426 | sub storage_user_info { ##SOAP_EXPORT## | |
1427 | my ($class, $vmid) = @_; | |
1428 | ||
1429 | my $userid = $class->$get_userid(); | |
1430 | ||
1431 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1432 | ||
1433 | my $info = PVE::Storage::storage_info ($cfg); | |
1434 | ||
1435 | my $res = { cfg => $cfg }; | |
1436 | ||
1437 | foreach my $storeid (PVE::Storage::storage_ids ($cfg)) { | |
1438 | my $scfg = PVE::Storage::storage_config ($cfg, $storeid); | |
1439 | ||
1440 | next if $scfg->{disable}; | |
1441 | ||
1442 | # fixme: check user access rights - pass username with connection? | |
1443 | ||
1444 | $res->{info}->{$storeid} = $info->{$storeid}; | |
1445 | ||
1446 | if ($scfg->{content}->{rootdir}) { | |
1447 | $res->{rootdir}->{$storeid} = 1; | |
1448 | $res->{rootdir_default} = $storeid | |
1449 | if !$res->{rootdir_default}; | |
1450 | } | |
1451 | ||
1452 | if ($scfg->{content}->{vztmpl}) { | |
1453 | $res->{vztmpl}->{$storeid} = 1; | |
1454 | $res->{vztmpl_default} = $storeid | |
1455 | if !$res->{vztmpl_default}; | |
1456 | } | |
1457 | ||
1458 | if ($scfg->{content}->{images}) { | |
1459 | $res->{images}->{$storeid} = 1; | |
1460 | $res->{images_default} = $storeid | |
1461 | if !$res->{images_default}; | |
1462 | } | |
1463 | ||
1464 | if ($scfg->{content}->{iso}) { | |
1465 | $res->{iso}->{$storeid} = 1; | |
1466 | $res->{iso_default} = $storeid | |
1467 | if !$res->{iso_default}; | |
1468 | } | |
1469 | ||
1470 | if ($scfg->{content}->{backup}) { | |
1471 | $res->{backup}->{$storeid} = 1; | |
1472 | $res->{backup_default} = $storeid | |
1473 | if !$res->{backup_default}; | |
1474 | } | |
1475 | } | |
1476 | ||
1477 | # include disk list | |
1478 | if ($vmid) { | |
1479 | $res->{imagelist} = PVE::Storage::vdisk_list ($cfg, undef, $vmid); | |
1480 | } | |
1481 | ||
1482 | ||
1483 | return $res; | |
1484 | } | |
1485 | ||
1486 | sub get_storage_status { ##SOAP_EXPORT## | |
1487 | my ($class) = @_; | |
1488 | ||
1489 | my $userid = $class->$get_userid(); | |
1490 | ||
1491 | # fixme: check user access rights | |
1492 | ||
1493 | my $cfg = PVE::Config::read_file ("storagecfg"); | |
1494 | ||
1495 | my $info = PVE::Storage::storage_info ($cfg); | |
1496 | ||
1497 | return { cfg => $cfg, info => $info }; | |
1498 | } | |
1499 | ||
1500 | ##FILTER_DATA## do not remove this line | |
1501 | ||
1502 | package PVE::SOAPSerializer; | |
1503 | ||
1504 | use strict; | |
1505 | use SOAP::Lite; | |
1506 | use vars qw(@ISA); | |
1507 | use HTML::Entities; | |
1508 | ||
1509 | @ISA = qw (SOAP::Serializer); | |
1510 | ||
1511 | sub new { | |
1512 | my $class = shift; | |
1513 | ||
1514 | my $self = $class->SUPER::new (@_); | |
1515 | ||
1516 | # SOAP Serializer bug fix: | |
1517 | # "a string with embeded URI 'http://exsample.com'" is encoded as URI! | |
1518 | # should be a string instead | |
1519 | # 'anyURI' => | |
1520 | # [95, sub { $_[0] =~ /^(urn:)|(http:\/\/)/i; }, 'as_anyURI'], | |
1521 | # regex should be: /^((urn:)|(http:\/\/))/i; | |
1522 | # so we disbale that | |
1523 | delete $self->{_typelookup}->{'anyURI'}; | |
1524 | ||
1525 | # SOAP Serializer bug fix: | |
1526 | # by default utf8 strings are serialized as base64Binary - unfortunately | |
1527 | # that way the utf8 flags gets lost, so we provide our own encoding | |
1528 | # see bug #2860559 on sourgeforge project page | |
1529 | $self->{_typelookup}->{'utf8string'} = | |
1530 | [5, sub { Encode::is_utf8($_[0]) }, 'as_utf8string'], | |
1531 | ||
1532 | return $self; | |
1533 | } | |
1534 | ||
1535 | sub as_utf8string { | |
1536 | my ($self, $value, $name, $type, $attr) = @_; | |
1537 | ||
1538 | return [ | |
1539 | $name, | |
1540 | {'xsi:type' => 'xsd:string', %$attr}, | |
1541 | HTML::Entities::encode_entities_numeric ($value) | |
1542 | ]; | |
1543 | } | |
1544 | ||
1545 | package PVE::SOAPTransport; | |
1546 | ||
1547 | use strict; | |
1548 | use vars qw(@ISA); | |
1549 | use SOAP::Transport::HTTP; | |
1550 | use MIME::Base64; | |
1551 | use PVE::SafeSyslog; | |
1552 | use PVE::Config; | |
1553 | use POSIX qw(EINTR); | |
1554 | use POSIX ":sys_wait_h"; | |
1555 | use IO::Handle; | |
1556 | use IO::Select; | |
1557 | use vars qw(@ISA); | |
1558 | ||
1559 | # This is a quite simple pre-fork server | |
1560 | ||
1561 | @ISA = qw(SOAP::Transport::HTTP::Daemon); | |
1562 | ||
1563 | my $workers = {}; | |
1564 | ||
1565 | my $max_workers = 2; # pre-forked worker processes | |
1566 | my $max_requests = 500; # max requests per worker | |
1567 | ||
1568 | sub worker_finished { | |
1569 | my $cpid = shift; | |
1570 | ||
1571 | syslog ('info', "worker $cpid finished"); | |
1572 | } | |
1573 | ||
1574 | sub finish_workers { | |
1575 | local $!; local $?; | |
1576 | foreach my $cpid (keys %$workers) { | |
1577 | my $waitpid = waitpid ($cpid, WNOHANG); | |
1578 | if (defined($waitpid) && ($waitpid == $cpid)) { | |
1579 | delete ($workers->{$cpid}); | |
1580 | worker_finished ($cpid); | |
1581 | } | |
1582 | } | |
1583 | } | |
1584 | ||
1585 | sub test_workers { | |
1586 | foreach my $cpid (keys %$workers) { | |
1587 | if (!kill(0, $cpid)) { | |
1588 | waitpid($cpid, POSIX::WNOHANG()); | |
1589 | delete $workers->{$cpid}; | |
1590 | worker_finished ($cpid); | |
1591 | } | |
1592 | } | |
1593 | } | |
1594 | ||
1595 | sub start_workers { | |
1596 | my $self = shift; | |
1597 | ||
1598 | my $count = 0; | |
1599 | foreach my $cpid (keys %$workers) { | |
1600 | $count++; | |
1601 | } | |
1602 | ||
1603 | my $need = $max_workers - $count; | |
1604 | ||
1605 | return if $need <= 0; | |
1606 | ||
1607 | syslog ('info', "starting $need worker(s)"); | |
1608 | ||
1609 | while ($need > 0) { | |
1610 | my $pid = fork; | |
1611 | ||
1612 | if (!defined ($pid)) { | |
1613 | syslog ('err', "can't fork worker"); | |
1614 | sleep (1); | |
1615 | } elsif ($pid) { #parent | |
1616 | $workers->{$pid} = 1; | |
1617 | $0 = 'pvedaemon worker'; | |
1618 | syslog ('info', "worker $pid started"); | |
1619 | $need--; | |
1620 | } else { | |
1621 | $SIG{TERM} = $SIG{QUIT} = 'DEFAULT'; | |
1622 | ||
1623 | $SIG{USR1} = sub { | |
1624 | $self->{reload_config} = 1; | |
1625 | }; | |
1626 | ||
1627 | eval { | |
1628 | # try to init inotify | |
1629 | PVE::Config::inotify_init(); | |
1630 | ||
1631 | $self->handle_requests (); | |
1632 | }; | |
1633 | syslog ('err', $@) if $@; | |
1634 | ||
1635 | ||
1636 | exit (0); | |
1637 | } | |
1638 | } | |
1639 | } | |
1640 | ||
1641 | sub terminate_server { | |
1642 | ||
1643 | foreach my $cpid (keys %$workers) { | |
1644 | kill (15, $cpid); # TERM childs | |
1645 | } | |
1646 | ||
1647 | # nicely shutdown childs (give them max 10 seconds to shut down) | |
1648 | my $previous_alarm = alarm (10); | |
1649 | eval { | |
1650 | local $SIG{ALRM} = sub { die "Timed Out!\n" }; | |
1651 | ||
1652 | 1 while ((my $pid = waitpid (-1, 0)) > 0); | |
1653 | ||
1654 | }; | |
1655 | alarm ($previous_alarm); | |
1656 | ||
1657 | foreach my $cpid (keys %$workers) { | |
1658 | !kill (0, $cpid) || kill (9, $cpid); # KILL childs still alive! | |
1659 | } | |
1660 | } | |
1661 | ||
1662 | sub handle { | |
1663 | my $self = shift; | |
1664 | my $daemon = $self->new; | |
1665 | ||
1666 | $self->{httpdaemon} = $daemon; | |
1667 | ||
1668 | eval { | |
1669 | my $old_sig_chld = $SIG{CHLD}; | |
1670 | local $SIG{CHLD} = sub { | |
1671 | finish_workers (); | |
1672 | &$old_sig_chld(@_); | |
1673 | }; | |
1674 | ||
1675 | my $old_sig_term = $SIG{TERM}; | |
1676 | local $SIG{TERM} = sub { | |
1677 | terminate_server (); | |
1678 | &$old_sig_term(@_); | |
1679 | }; | |
1680 | local $SIG{QUIT} = sub { | |
1681 | terminate_server(); | |
1682 | &$old_sig_term(@_); | |
1683 | }; | |
1684 | ||
1685 | local $SIG{USR1} = 'IGNORE'; | |
1686 | ||
1687 | local $SIG{HUP} = sub { | |
1688 | syslog ("info", "received reload request"); | |
1689 | foreach my $cpid (keys %$workers) { | |
1690 | kill (10, $cpid); # SIGUSR1 childs | |
1691 | } | |
1692 | }; | |
1693 | ||
1694 | for (;;) { # forever | |
1695 | $self->start_workers (); | |
1696 | sleep (5); | |
1697 | $self->test_workers (); | |
1698 | } | |
1699 | }; | |
1700 | my $err = $@; | |
1701 | ||
1702 | if ($err) { | |
1703 | syslog ('err', "ERROR: $err"); | |
1704 | } | |
1705 | } | |
1706 | ||
1707 | sub send_basic_auth_request { | |
1708 | my ($c) = @_; | |
1709 | ||
1710 | my $realm = 'PVE SOAP Server'; | |
1711 | my $auth_request_res = HTTP::Response->new(401, 'Unauthorized'); | |
1712 | $auth_request_res->header('WWW-Authenticate' => qq{Basic realm="$realm"}); | |
1713 | $auth_request_res->is_error(1); | |
1714 | $auth_request_res->error_as_HTML(1); | |
1715 | $c->send_response($auth_request_res); | |
1716 | } | |
1717 | ||
1718 | sub send_error { | |
1719 | my ($c, $code, $msg) = @_; | |
1720 | ||
1721 | $c->send_response(HTTP::Response->new($code, $msg)); | |
1722 | } | |
1723 | ||
1724 | sub decode_basic_auth { | |
1725 | my ($h) = @_; | |
1726 | ||
1727 | my $authtxt = $h->header('Authorization'); | |
1728 | return undef if !$authtxt; | |
1729 | my ($test, $auth) = split /\s+/, $authtxt; | |
1730 | return undef if !$auth; | |
1731 | ||
1732 | my $enc = MIME::Base64::decode ($auth); | |
1733 | ||
1734 | return $enc; | |
1735 | } | |
1736 | ||
1737 | sub extract_auth_cookie { | |
1738 | my ($h) = @_; | |
1739 | ||
1740 | my $txt = $h->header('Cookie') || ''; | |
1741 | ||
1742 | return ($txt =~ /(?:^|\s)PVEAuthTicket=([^;]*)/)[0]; | |
1743 | } | |
1744 | ||
1745 | sub ident_user { | |
1746 | my ($peerport, $sockport) = @_; | |
1747 | ||
1748 | my $filename = "/proc/net/tcp"; | |
1749 | ||
1750 | my $fh = IO::File->new($filename, "r") || | |
1751 | die "unable to open file '$filename'\n"; | |
1752 | ||
1753 | my $user; | |
1754 | ||
1755 | my $remoteaddr = sprintf "0100007F:%04X", $sockport; | |
1756 | my $localaddr = sprintf "0100007F:%04X", $peerport; | |
1757 | ||
1758 | while (defined (my $line = <$fh>)) { | |
1759 | $line =~ s/^\s+//; | |
1760 | my @data = split (/\s+/, $line); | |
1761 | if ($data[1] eq $localaddr && | |
1762 | $data[2] eq $remoteaddr) { | |
1763 | my $uid = $data[7]; | |
1764 | $user = getpwuid ($uid); | |
1765 | last; | |
1766 | } | |
1767 | } | |
1768 | ||
1769 | close ($fh); | |
1770 | ||
1771 | die "unable to identify user connection\n" if !$user; | |
1772 | ||
1773 | return $user; | |
1774 | } | |
1775 | ||
1776 | sub handle_login { | |
1777 | my ($daemon, $c, $r) = @_; | |
1778 | ||
1779 | # my $cuser = ident_user ($c->peerport, $c->sockport); | |
1780 | ||
1781 | my $h = $r->headers; | |
1782 | my $action = $h->header('SOAPAction'); | |
1783 | if ($action !~ m|^(\"?)http://proxmox.com/PVE/ConfigServer\#(\w+)(\"?)$|) { | |
1784 | send_error($c, 400, "Invalid SOAPAction"); | |
1785 | return undef; | |
1786 | } | |
1787 | my $method = $2; | |
1788 | my $ticket = extract_auth_cookie($h); | |
1789 | my $authheader = $h->header('Authorization'); | |
1790 | ||
1791 | if (!$ticket) { | |
1792 | if (!$authheader || $authheader !~ m/^Basic\s+\S+$/) { | |
1793 | send_basic_auth_request ($c); | |
1794 | return undef; | |
1795 | } | |
1796 | } | |
1797 | ||
1798 | my ($user, $group); | |
1799 | ||
1800 | $daemon->request($r); | |
1801 | ||
1802 | my $update; | |
1803 | ||
1804 | if ($authheader) { | |
1805 | my $auth = (split /\s+/, $authheader)[1]; | |
1806 | my $enc = MIME::Base64::decode ($auth); | |
1807 | my $pw; | |
1808 | ($user, $pw) = split (/:/, $enc, 2); | |
1809 | if ($group = PVE::Utils::is_valid_user ($user, $pw)) { | |
1810 | $ticket = PVE::Utils::create_auth_ticket ($daemon->{pve}->{secret}, $user, $group); | |
1811 | $update = 1; | |
1812 | } else { | |
1813 | $daemon->make_fault($SOAP::Constants::FAULT_CLIENT, | |
1814 | 'Basic authentication failed'); | |
1815 | $c->send_response($daemon->response); | |
1816 | return undef; | |
1817 | } | |
1818 | } elsif ($ticket) { | |
1819 | ($user, $group) = PVE::Utils::verify_ticket ($daemon->{pve}->{secret}, $ticket); | |
1820 | if (!($user && $group)) { | |
1821 | $daemon->make_fault($SOAP::Constants::FAULT_CLIENT, | |
1822 | "Ticket authentication failed - invalid ticket '$ticket'"); | |
1823 | $c->send_response($daemon->response); | |
1824 | return undef; | |
1825 | } | |
1826 | if ($method eq 'update_ticket') { | |
1827 | $ticket = PVE::Utils::create_auth_ticket ($daemon->{pve}->{secret}, $user, $group); | |
1828 | } | |
1829 | } else { | |
1830 | $daemon->make_fault($SOAP::Constants::FAULT_CLIENT, | |
1831 | 'Ticket authentication failed - no ticket'); | |
1832 | $c->send_response($daemon->response); | |
1833 | return undef; | |
1834 | } | |
1835 | ||
1836 | return ($user, $group, $ticket, $update); | |
1837 | } | |
1838 | ||
1839 | sub handle_requests { | |
1840 | my $self = shift; | |
1841 | ||
1842 | my $daemon = $self->{httpdaemon}; | |
1843 | ||
1844 | my $rcount = 0; | |
1845 | ||
1846 | my $sel = IO::Select->new(); | |
1847 | $sel->add ($daemon->{_daemon}); | |
1848 | ||
1849 | my $timeout = 5; | |
1850 | my @ready; | |
1851 | while (1) { | |
1852 | if (scalar (@ready = $sel->can_read($timeout))) { | |
1853 | ||
1854 | if (!$daemon->{pve}->{secret} || $self->{reload_config}) { | |
1855 | $self->{reload_config} = undef; | |
1856 | syslog ("info", "reloading configuration") | |
1857 | if $self->{reload_config}; | |
1858 | $daemon->{pve}->{secret} = PVE::Utils::load_auth_secret(); | |
1859 | } | |
1860 | ||
1861 | my $c; | |
1862 | while (($c = $daemon->accept) || ($! == EINTR)) { | |
1863 | next if !$c; # EINTR | |
1864 | ||
1865 | $c->timeout(5); | |
1866 | ||
1867 | $daemon->{pve}->{username} = undef; | |
1868 | $daemon->{pve}->{groupname} = undef; | |
1869 | $daemon->{pve}->{ticket} = undef; | |
1870 | ||
1871 | # handle requests | |
1872 | while (my $r = $c->get_request) { | |
1873 | ||
1874 | my ($user, $group, $ticket, $update) = handle_login ($daemon, $c, $r); | |
1875 | last if !$user; | |
1876 | ||
1877 | $daemon->{pve}->{username} = $user; | |
1878 | $daemon->{pve}->{groupname} = $group; | |
1879 | $daemon->{pve}->{ticket} = $ticket; | |
1880 | $daemon->SOAP::Transport::HTTP::Server::handle; | |
1881 | ||
1882 | if ($update) { | |
1883 | $daemon->response->header ("Set-Cookie" => "PVEAuthTicket=$ticket"); | |
1884 | } | |
1885 | ||
1886 | $c->send_response($daemon->response); | |
1887 | } | |
1888 | $rcount++; | |
1889 | ||
1890 | # we only handle one request per connection, because | |
1891 | # we want to minimize the number of connections | |
1892 | ||
1893 | $c->shutdown(2); | |
1894 | $c->close(); | |
1895 | last; | |
1896 | } | |
1897 | ||
1898 | last if !$c || ($rcount >= $max_requests); | |
1899 | ||
1900 | } else { | |
1901 | # timeout | |
1902 | PVE::Config::poll(); # read inotify events | |
1903 | } | |
1904 | } | |
1905 | } | |
1906 | ||
1907 | package PVE::ConfigClient; | |
1908 | ||
1909 | use SOAP::Lite; | |
1910 | use HTTP::Cookies; | |
1911 | use HTTP::Headers; | |
1912 | use PVE::Config; | |
1913 | ||
1914 | my ($soaphost, $soapport) = PVE::Config::soap_host_port(); | |
1915 | ||
1916 | sub __create_soaplite { | |
1917 | my ($timeout, $port, $ticket, $username, $password) = @_; | |
1918 | ||
1919 | my $cookie_jar = HTTP::Cookies->new (ignore_discard => 1); | |
1920 | ||
1921 | if ($ticket) { | |
1922 | $cookie_jar->set_cookie(0, 'PVEAuthTicket', $ticket, '/', $soaphost); | |
1923 | } | |
1924 | ||
1925 | my $soap = SOAP::Lite | |
1926 | -> serializer (PVE::SOAPSerializer->new) | |
1927 | -> ns('http://proxmox.com/PVE/ConfigServer') | |
1928 | -> on_fault (sub { | |
1929 | my($soap, $res) = @_; | |
1930 | die ref $res ? $res->faultstring : $soap->transport->status, "\n"; | |
1931 | }) | |
1932 | -> proxy("http://$soaphost:$port", timeout => $timeout, | |
1933 | cookie_jar => $cookie_jar); | |
1934 | ||
1935 | if ($username && defined($password)) { | |
1936 | $soap->proxy->credentials ("$soaphost:$port", 'PVE SOAP Server', | |
1937 | $username, $password); | |
1938 | } | |
1939 | ||
1940 | return $soap; | |
1941 | } | |
1942 | ||
1943 | sub connect { | |
1944 | my ($ticket, $cinfo, $cid) = @_; | |
1945 | ||
1946 | die "no ticket specified" if !$ticket; | |
1947 | ||
1948 | # set longet timeout for local connection | |
1949 | my $timeout = $cid ? 10 : 120; | |
1950 | ||
1951 | my $port = $soapport; | |
1952 | ||
1953 | if ($cid) { | |
1954 | die "invalid cluster ID '$cid'" | |
1955 | if $cid !~ m/^\d+$/; | |
1956 | my $ni; | |
1957 | die "no config for cluster node '$cid'" | |
1958 | if !($cinfo && ($ni = $cinfo->{"CID_$cid"})); | |
1959 | ||
1960 | $port = $ni->{configport}; | |
1961 | } | |
1962 | ||
1963 | return __create_soaplite ($timeout, $port, $ticket); | |
1964 | } | |
1965 | ||
1966 | sub update_ticket { | |
1967 | my ($ticket) = @_; | |
1968 | ||
1969 | die "no ticket specified" if !$ticket; | |
1970 | ||
1971 | ||
1972 | if ($ticket !~ m/^((\S+)::\w+::\d+::[0-9a-f]{40})(::[0-9a-f]{40})?$/) { | |
1973 | die "got invalid ticket '$ticket'\n"; | |
1974 | } | |
1975 | ||
1976 | $ticket = $1; # strip second checksum used by PVE::AuthCookieHandler | |
1977 | ||
1978 | my $username = $2; | |
1979 | ||
1980 | my $timeout = 120; | |
1981 | ||
1982 | my $soap = __create_soaplite ($timeout, $soapport, $ticket); | |
1983 | ||
1984 | my $nt = $soap->update_ticket()->result; | |
1985 | ||
1986 | if ($ticket !~ m/^${username}::\w+::\d+::[0-9a-f]{40}$/) { | |
1987 | die "got invalid ticket '$ticket'\n"; | |
1988 | } | |
1989 | ||
1990 | return $nt; | |
1991 | } | |
1992 | ||
1993 | sub request_ticket { | |
1994 | my ($username, $password) = @_; | |
1995 | ||
1996 | die "no username specified\n" if !$username; | |
1997 | die "no password specified for user '$username'\n" if !defined ($password); | |
1998 | ||
1999 | my $timeout = 120; | |
2000 | ||
2001 | my $soap = __create_soaplite ($timeout, $soapport, undef, $username, $password); | |
2002 | ||
2003 | my $ticket = $soap->update_ticket()->result; | |
2004 | ||
2005 | if ($ticket !~ m/^${username}::\w+::\d+::[0-9a-f]{40}$/) { | |
2006 | die "got invalid ticket '$ticket'\n"; | |
2007 | } | |
2008 | ||
2009 | return $ticket | |
2010 | } | |
2011 | ||
2012 | 1; |