wip(backend): graphics video controllers for KVM

issue #1195

lib/Ravada.pm

@@ -577,6 +577,11 @@ sub _update_domain_drivers_types($self) {
             ,name => 'disk'
             ,vm => 'KVM'
         }
+        ,graphics => {
+            id => 10
+            ,name => 'graphics'
+            ,vm => 'KVM'
+        }
 
     };
     $self->_update_table('domain_drivers_types','id',$data);
@@ -590,6 +595,7 @@ sub _update_domain_drivers_types($self) {
 
 sub _update_domain_drivers_options($self) {
 
+    my $n = 33;
     my $data = {
         qxl => {
             id => 1,
@@ -747,6 +753,19 @@ sub _update_domain_drivers_options($self) {
             ,name => 'off'
            ,value => 'mode="off"'
         }
+        ,spice => {
+            id => $n++
+            ,id_driver_type => 10,
+            ,name => 'spice'
+            ,value => 'spice'
+        }
+        ,vnc => {
+            id => $n++
+            ,id_driver_type => 10,
+            ,name => 'vnc'
+            ,value => 'vnc'
+        }
+
     };
     $self->_update_table('domain_drivers_options','id',$data);
 }

lib/Ravada/Domain.pm

@@ -1341,7 +1341,7 @@ sub info($self, $user) {
         die "Field $_ already in info" if exists $info->{$_};
         $info->{$_} = $internal_info->{$_};
     }
-    for (qw(disk network)) {
+    for (qw(disk network graphics)) {
         $info->{drivers}->{$_} = $self->drivers($_,undef,1);
     }
     $info->{bases} = $self->_bases_vm();
@@ -3105,7 +3105,7 @@ sub get_controller {
     my $sub = $self->get_controller_by_name($name);
 #    my $sub = $GET_CONTROLLER_SUB{$name};
     
-    die "I can't get controller $name for domain ".$self->name
+    confess "I can't get controller $name for domain ".$self->name
         if !$sub;
 
     return $sub->($self);

lib/Ravada/Domain/KVM.pm

@@ -65,22 +65,26 @@ our %SET_DRIVER_SUB = (
 our %GET_CONTROLLER_SUB = (
     usb => \&_get_controller_usb
     ,disk => \&_get_controller_disk
+    ,graphics => \&_get_controller_graphics
     ,network => \&_get_controller_network
     );
 our %SET_CONTROLLER_SUB = (
     usb => \&_set_controller_usb
     ,disk => \&_set_controller_disk
+    ,graphics => \&_set_controller_graphics
     ,network => \&_set_controller_network
     );
 our %REMOVE_CONTROLLER_SUB = (
     usb => \&_remove_controller_usb
     ,disk => \&_remove_controller_disk
+    ,graphics => \&_remove_controller_graphics
     ,network => \&_remove_controller_network
     );
 
 our %CHANGE_HARDWARE_SUB = (
     disk => \&_change_hardware_disk
     ,network => \&_change_hardware_network
+    ,graphics => \&_change_hardware_graphics
 );
 ##################################################
 
@@ -1933,6 +1937,53 @@ sub _set_controller_network($self, $number, $data) {
       $self->domain->attach_device($device, Sys::Virt::Domain::DEVICE_MODIFY_CONFIG);
 }
 
+sub _set_graphics_spice_xml($self, $graphics) {
+    my %settings = (
+        image => { compression => 'auto_glz'}
+        ,jpeg => { compression => 'auto' }
+        ,zlib => { compression => 'auto' }
+        ,playback => { compression => 'on' }
+        ,streaming => { mode => 'filter' }
+    );
+    $self->_set_device_settings_xml($graphics, \%settings);
+}
+
+sub _set_device_settings_xml($self, $graphics, $settings) {
+    for my $name( keys %$settings ) {
+        my $node= $graphics->addNewChild(undef,$name);
+        for my $attrib ( keys %{$settings->{$name}} ) {
+            $node->setAttribute( $attrib => $settings->{$name}->{$attrib});
+        }
+    }
+
+}
+
+sub _set_graphics_vnc_xml($self, $graphics) {
+    #TODO find out recommended VNC settings
+    my %settings = ();
+    $self->_set_device_settings_xml($graphics, \%settings);
+}
+
+sub _set_controller_graphics($self, $number, $data) {
+    my $type = ( delete $data->{driver} or 'spice' );
+
+    my $doc = XML::LibXML->load_xml(string => $self->xml_description_inactive);
+    my ($devices) = $doc->findnodes('/domain/devices');
+    my $graphics = $devices->addNewChild(undef,'graphics');
+    $graphics->setAttribute(type => $type);
+    $graphics->setAttribute(autoport=> 'yes');
+
+    if ($type eq 'spice') {
+        $self->_set_graphics_spice_xml($graphics);
+    } elsif ($type eq 'vnc') {
+        $self->_set_graphics_vnc_xml($graphics);
+    }
+
+    $self->_vm->connect if !$self->_vm->vm;
+    my $new_domain = $self->_vm->vm->define_domain($doc->toString);
+    $self->domain($new_domain);
+}
+
 sub remove_controller($self, $name, $index=0) {
     my $sub = $REMOVE_CONTROLLER_SUB{$name};
     
@@ -1994,6 +2045,10 @@ sub _remove_controller_network($self, $index) {
     $self->_remove_device($index,'interface', type => qr'(bridge|network)');
 }
 
+sub _remove_controller_graphics($self, $index) {
+    $self->_remove_device($index,'graphics');
+}
+
 =head2 pre_remove
 
 Code to run before removing the domain. It can be implemented in each domain.
@@ -2245,6 +2300,32 @@ sub _change_hardware_network($self, $index, $data) {
     $self->_post_change_hardware($doc);
 }
 
+sub _change_hardware_graphics($self, $index, $data) {
+    confess if !defined $index;
+
+    my $doc = XML::LibXML->load_xml(string => $self->xml_description);
+
+    my $driver = lc(delete $data->{driver} or '');
+    my $type = lc(delete $data->{type} or '');
+
+    die "Error: Unknown arguments ".Dumper($data) if keys %$data;
+
+    my $count = 0;
+    my $changed = 0;
+
+    for my $interface ($doc->findnodes('/domain/devices/graphics')) {
+        next if $count++ != $index;
+        $interface->setAttribute(type => $type) if $type;
+        $interface->setAttribute(type => $driver) if $driver;
+        $changed++;
+    }
+
+    die "Error: interface $index not found in ".$self->name if !$changed;
+
+    $self->_post_change_hardware($doc);
+
+}
+
 
 
 sub _post_change_hardware($self, $doc) {

lib/Ravada/Front/Domain/KVM.pm

@@ -14,6 +14,7 @@ use feature qw(signatures);
 our %GET_CONTROLLER_SUB = (
     usb => \&_get_controller_usb
     ,disk => \&_get_controller_disk
+    ,graphics => \&_get_controller_graphics
     ,network => \&_get_controller_network
     );
 
@@ -90,6 +91,40 @@ sub _get_controller_network($self) {
     return @ret;
 }
 
+sub _get_controller_graphics($self) {
+    $self->xml_description if !$self->readonly();
+    my $doc = XML::LibXML->load_xml(string => $self->_data_extra('xml'));
+
+    my @ret;
+
+    for my $device ($doc->findnodes('/domain/devices/graphics')) {
+        my $screen = _fetch_xml_nodes($device);
+        $screen->{driver} = $screen->{type};
+        $screen->{name} = $screen->{type}." ".scalar(@ret);
+        push @ret,($screen);
+    }
+
+    return @ret;
+
+}
+
+sub _fetch_xml_attributes($element) {
+    my $device = {};
+    for my $attrib ($element->attributes) {
+        $device->{$attrib->name}=$attrib->value;
+    }
+    return $device;
+}
+
+sub _fetch_xml_nodes($element) {
+    my $entry = _fetch_xml_attributes($element);
+    for my $node ( $element->findnodes('*') ) {
+        my $attributes = _fetch_xml_attributes($node);
+        $entry->{$node->nodeName} = $attributes;
+    }
+    return $entry;
+}
+
 sub _get_controller_disk($self) {
     return Ravada::Front::Domain::_get_controller_disk($self);
 }