diff --git a/PVE/QemuServer.pm b/PVE/QemuServer.pm index ad8dff1a..e41f8ddc 100644 --- a/PVE/QemuServer.pm +++ b/PVE/QemuServer.pm @@ -15,6 +15,7 @@ use Digest::SHA; use Fcntl ':flock'; use Cwd 'abs_path'; use IPC::Open3; +use JSON; use Fcntl; use PVE::SafeSyslog; use Storable qw(dclone); @@ -2061,6 +2062,10 @@ sub config_to_command { push @$cmd, '-chardev', "socket,id=monitor,path=$socket,server,nowait"; push @$cmd, '-mon', "chardev=monitor,mode=readline"; + my $qmpsocket = qmp_socket($vmid); + push @$cmd, '-chardev', "socket,id=qmp,path=$qmpsocket,server,nowait"; + push @$cmd, '-mon', "chardev=qmp,mode=control"; + $socket = vnc_socket($vmid); push @$cmd, '-vnc', "unix:$socket,x509,password"; @@ -2326,6 +2331,11 @@ sub monitor_socket { return "${var_run_tmpdir}/$vmid.mon"; } +sub qmp_socket { + my ($vmid) = @_; + return "${var_run_tmpdir}/$vmid.qmp"; +} + sub pidfile_name { my ($vmid) = @_; return "${var_run_tmpdir}/$vmid.pid"; @@ -2668,6 +2678,34 @@ sub vm_start { }); } +sub qmp__read_avail { + my ($fh, $timeout) = @_; + + my $sel = new IO::Select; + $sel->add($fh); + + my $res = ''; + my $buf; + + my @ready; + while (scalar (@ready = $sel->can_read($timeout))) { + my $count; + if ($count = $fh->sysread($buf, 8192)) { + $res .= $buf; + last; + } else { + if (!defined($count)) { + die "$!\n"; + } + last; + } + } + + die "qmp read timeout\n" if !scalar(@ready); + my $obj = from_json($res); + return $obj; +} + sub __read_avail { my ($fh, $timeout) = @_; @@ -2774,6 +2812,95 @@ sub vm_monitor_command { return $res; } +sub vm_qmp_command { + my ($vmid, $cmdstr, $nocheck) = @_; + #http://git.qemu.org/?p=qemu.git;a=blob;f=qmp-commands.hx;h=db980fa811325aeca8ad43472ba468702d4a25a2;hb=HEAD + my $res; + + eval { + die "VM $vmid not running\n" if !check_running($vmid, $nocheck); + + my $sname = qmp_socket($vmid); + my $sock = IO::Socket::UNIX->new( Peer => $sname ) || + die "unable to connect to VM $vmid socket - $!\n"; + + + my $timeout = 3; + + # maybe this works with qmp, need to be tested + + # hack: migrate sometime blocks the monitor (when migrate_downtime + # is set) + #if ($cmdstr =~ m/^(info\s+migrate|migrate\s)/) { + # $timeout = 60*60; # 1 hour + #} + + # read banner; + my $data = qmp__read_avail($sock, $timeout); + # '{"QMP": {"version": {"qemu": {"micro": 93, "minor": 0, "major": 1}, "package": " (qemu-kvm-devel)"}, "capabilities": []}} '; + die "got unexpected qemu qmp banner\n" if !$data->{QMP}; + + my $sel = new IO::Select; + $sel->add($sock); + + #negociation + my $negociation = '{ "execute": "qmp_capabilities" }'; + + if (!scalar(my @ready = $sel->can_write($timeout))) { + die "monitor write error - timeout"; + } + + my $b; + if (!($b = $sock->syswrite($negociation)) || ($b != length($negociation))) { + die "monitor write error - $!"; + } + + $res = qmp__read_avail($sock, $timeout); + # res = '{"return": {}} + die "qmp negociation error\n" if !$res->{return}; + + + $timeout = 20; + + + my $fullcmd = undef; + #generate json from hash for complex cmd + if (ref($cmdstr) eq "HASH") { + $fullcmd = to_json($cmdstr); + + if ($fullcmd->{execute} =~ m/^(info\s+migrate|migrate\s)/) { + $timeout = 60*60; # 1 hour + } elsif ($fullcmd->{execute} =~ m/^(eject|change)/) { + $timeout = 60; # note: cdrom mount command is slow + } + } + #execute command for simple action + else { + $fullcmd = '{ "execute": "'.$cmdstr.'" }'; + } + + if (!($b = $sock->syswrite($fullcmd)) || ($b != length($fullcmd))) { + die "monitor write error - $!"; + } + + if (ref($cmdstr) ne "HASH") { + return if ($cmdstr eq 'q') || ($cmdstr eq 'quit'); + } + + $res = qmp__read_avail($sock, $timeout); + + }; + + my $err = $@; + + if ($err) { + syslog("err", "VM $vmid qmp command failed - $err"); + die $err; + } + + return $res; +} + sub vm_commandline { my ($storecfg, $vmid) = @_; diff --git a/control.in b/control.in index df6ee9cf..1c672494 100644 --- a/control.in +++ b/control.in @@ -3,7 +3,7 @@ Version: @@VERSION@@-@@PKGRELEASE@@ Section: admin Priority: optional Architecture: @@ARCH@@ -Depends: libc6 (>= 2.7-18), perl (>= 5.10.0-19), libterm-readline-gnu-perl, pve-qemu-kvm (>= 0.11.1) | pve-qemu-kvm-2.6.18, netcat-traditional, libpve-storage-perl, pve-cluster, redhat-cluster-pve +Depends: libc6 (>= 2.7-18), perl (>= 5.10.0-19), libterm-readline-gnu-perl, pve-qemu-kvm (>= 0.11.1) | pve-qemu-kvm-2.6.18, netcat-traditional, libpve-storage-perl, pve-cluster, redhat-cluster-pve, libjson-perl, libjson-xs-perl Conflicts: netcat-openbsd Maintainer: Proxmox Support Team Description: Qemu Server Tools