[#33] Reading display ip from VM or main config

If the current VM has a host we get the IP from there.
Added display_ip configuration support.

lib/Ravada.pm

@@ -93,28 +93,16 @@ sub _connect_dbh {
 
 }
 
-sub display_ip {
-    my $ip = $CONFIG->{display_ip};
-    return $ip if $ip;
+=head2 display_ip
 
-    my $name = hostname() or die "CRITICAL: I can't find the hostname.\n";
-    $ip = inet_ntoa(inet_aton($name)) 
-        or die "CRITICAL: I can't find IP of $name in the DNS.\n";
+Returns the default display IP read from the config file
 
-    if (!$ip || $ip =~ /^127./) {
-        #TODO Net:DNS
-        $ip= `host $name`;
-        chomp $ip;
-        $ip =~ s/.*?address (\d+)/$1/;
-    }
-    if ( !$ip || $ip =~ /^127./ || $ip !~ /^\d+\..*\.\d+$/) {
-        warn "WARNING: I can't find IP with hostname $name ( $ip )"
-            .", using localhost\n";
-        $ip='127.0.0.1';
-    }
-
-    return $ip;
+=cut
 
+sub display_ip {
+    my $ip = $CONFIG->{display_ip};
+    
+    return $ip if $ip;
 }
 
 sub _init_config {
@@ -829,6 +817,25 @@ sub _cmd_prepare_base {
 
 }
 
+sub _cmd_remove_base {
+    my $self = shift;
+    my $request = shift;
+
+    $request->status('working');
+    my $id_domain = $request->id_domain or confess "Missing request id_domain";
+    my $uid = $request->args('uid')     or confess "Missing argument uid";
+
+    my $user = Ravada::Auth::SQL->search_by_id( $uid);
+
+    my $domain = $self->search_domain_by_id($id_domain);
+
+    die "Unknown domain id '$id_domain'\n" if !$domain;
+
+    $domain->remove_base($user);
+
+}
+
+
 
 sub _cmd_shutdown {
     my $self = shift;
@@ -880,6 +887,7 @@ sub _req_method {
       ,shutdown => \&_cmd_shutdown
     ,domdisplay => \&_cmd_domdisplay
     ,screenshot => \&_cmd_screenshot
+   ,remove_base => \&_cmd_remove_base
   ,ping_backend => \&_cmd_ping_backend
   ,prepare_base => \&_cmd_prepare_base
  ,list_vm_types => \&_cmd_list_vm_types

lib/Ravada/Domain.pm

@@ -56,6 +56,13 @@ has 'storage' => (
     ,isa => 'Object'
     ,required => 0
 );
+
+has '_vm' => (
+    is => 'ro',
+    ,isa => 'Object'
+    ,required => 1
+);
+
 ##################################################################################3
 #
 
@@ -88,6 +95,7 @@ before 'pause' => \&_allow_manage;
 before 'resume' => \&_allow_manage;
 before 'shutdown' => \&_allow_manage_args;
 
+before 'remove_base' => \&_can_remove_base;
 after 'remove_base' => \&_remove_base_db;
 
 sub _preconditions{
@@ -548,6 +556,11 @@ sub remove_base {
     $self->storage_refresh()    if $self->storage();
 }
 
+sub _can_remove_base {
+    _allow_manage(@_);
+    _check_has_clones(@_);
+}
+
 sub _remove_base_db {
     my $self = shift;
 

lib/Ravada/Domain/KVM.pm

@@ -26,8 +26,8 @@ has 'storage' => (
 
 has '_vm' => (
     is => 'ro'
-    ,isa => 'Sys::Virt'
-    ,required => 0
+    ,isa => 'Ravada::VM::KVM'
+    ,required => 1
 );
 
 ##################################################
@@ -553,7 +553,7 @@ sub screenshot {
     my $self = shift;
     my $file = (shift or $self->_file_screenshot);
 
-    my $stream = $self->{_vm}->new_stream();
+    my $stream = $self->{_vm}->vm->new_stream();
 
     my $mimetype = $self->domain->screenshot($stream,0);
 

lib/Ravada/Domain/Void.pm

@@ -41,7 +41,7 @@ sub name {
 sub display {
     my $self = shift;
 
-    my $ip = (Ravada::display_ip() or '127.0.0.1');
+    my $ip = $self->_vm->ip();
     return "void://$ip:0000/";
 }
 

lib/Ravada/Request.pm

@@ -33,6 +33,7 @@ our %VALID_ARG = (
        ,id_owner => 1
     ,id_template => 1
     }
+      ,remove_base => $args_prepare
      ,prepare_base => $args_prepare
      ,pause_domain => $args_manage
     ,resume_domain => $args_manage
@@ -289,6 +290,37 @@ sub prepare_base {
 
 }
 
+=head2 remove_base
+
+Returns a new request for making a base regular domain. It marks it
+as 'non base' and removes the files.
+
+It must have not clones. All clones must be removed before calling
+this method.
+
+  my $req = Ravada::Request->remove_base( $name );
+
+=cut
+
+sub remove_base {
+    my $proto = shift;
+    my $class=ref($proto) || $proto;
+
+    my %args = @_;
+    confess "Missing uid"           if !$args{uid};
+
+    my $args = _check_args('remove_base', @_);
+
+    my $self = {};
+    bless($self,$class);
+
+    return $self->_new_request(command => 'remove_base' 
+        , id_domain => $args{id_domain}
+        , args => encode_json( $args ));
+
+}
+
+
 =head2 ping_backend
 
 Returns wether the backend is alive or not

lib/Ravada/VM.pm

@@ -5,13 +5,16 @@ package Ravada::VM;
 
 use Carp qw(croak);
 use Data::Dumper;
+use Socket qw( inet_aton inet_ntoa );
 use Moose::Role;
+use Sys::Hostname;
 
 requires 'connect';
 
 # global DB Connection
 
 our $CONNECTOR = \$Ravada::CONNECTOR;
+our $CONFIG = \$Ravada::CONFIG;
 
 # domain
 requires 'create_domain';
@@ -119,5 +122,41 @@ sub search_domain_by_id {
     return $self->search_domain($name);
 }
 
+=head2 ip
+
+Returns the external IP this for this VM
+
+=cut
+
+sub ip {
+    my $self = shift;
+
+    my $name = $self->host();
+    my $ip = inet_ntoa(inet_aton($name)) ;
+
+    return $ip if $ip && $ip !~ /^127\./;
+
+    $name = Ravada::display_ip();
+
+    if ($name) {
+        if ($name =~ /^\d+\.\d+\.\d+\.\d+$/) {
+            $ip = $name;
+        } else {
+            $ip = inet_ntoa(inet_aton($name));
+        }
+    }
+    return $ip if $ip && $ip !~ /^127\./;
+
+    $name = hostname();
+    $ip = `host $name`;
+    chomp $ip;
+    $ip =~ s/.*?address (\d+)/$1/;
+    return $ip if $ip && $ip !~ /^127\./;
+
+    warn "WARNING: I can't find the IP of host $name, using localhost."
+        ." This virtual machine won't be available from the network.";
+
+    return '127.0.0.1';
+}
 
 1;

lib/Ravada/VM/KVM.pm

@@ -10,8 +10,6 @@ use Hash::Util qw(lock_hash);
 use IPC::Run3 qw(run3);
 use LWP::UserAgent;
 use Moose;
-use Socket qw( inet_aton inet_ntoa );
-use Sys::Hostname;
 use Sys::Virt;
 use URI;
 use XML::LibXML;
@@ -50,7 +48,6 @@ our $DIR_XML = "etc/xml";
 
 our $DEFAULT_DIR_IMG;
 our $XML = XML::LibXML->new();
-our $IP = _init_ip();
 
 #-----------
 #
@@ -181,7 +178,7 @@ sub search_domain {
                 domain => $dom
                 ,storage => $self->storage_pool
                 ,readonly => $self->readonly
-                ,_vm => $self->vm
+                ,_vm => $self
             );
         };
         warn $@ if $@;
@@ -209,6 +206,7 @@ sub list_domains {
         eval { $domain = Ravada::Domain::KVM->new(
                           domain => $name
                         ,storage => $self->storage_pool
+                        ,_vm => $self
                     );
              $id = $domain->id();
         };
@@ -310,7 +308,7 @@ sub _domain_create_from_iso {
 
 
     my $domain = Ravada::Domain::KVM->new(domain => $dom , storage => $self->storage_pool
-                , _vm => $self->vm
+                , _vm => $self
     );
 
     $domain->_insert_db(name => $args{name}, id_owner => $args{id_owner});
@@ -397,14 +395,15 @@ sub _domain_create_from_base {
     _xml_modify_disk($xml, \@device_disk);
     $self->_xml_modify_mac($xml);
     $self->_xml_modify_uuid($xml);
-    _xml_modify_spice_port($xml);
+    $self->_xml_modify_spice_port($xml);
     _xml_modify_video($xml);
 
 
     my $dom = $self->vm->define_domain($xml->toString());
     $dom->create;
 
-    my $domain = Ravada::Domain::KVM->new(domain => $dom , storage => $self->storage_pool);
+    my $domain = Ravada::Domain::KVM->new(domain => $dom , storage => $self->storage_pool
+        , _vm => $self);
 
     $domain->_insert_db(name => $args{name}, id_base => $base->id, id_owner => $args{id_owner});
     return $domain;
@@ -530,7 +529,7 @@ sub _define_xml {
 
     $self->_xml_modify_mac($doc);
     $self->_xml_modify_uuid($doc);
-    _xml_modify_spice_port($doc);
+    $self->_xml_modify_spice_port($doc);
     _xml_modify_video($doc);
 
     return $doc;
@@ -560,13 +559,14 @@ sub _xml_modify_video {
 }
 
 sub _xml_modify_spice_port {
-    my $doc = shift;
+    my $self = shift;
+    my $doc = shift or confess "Missing XML doc";
 
     my ($graph) = $doc->findnodes('/domain/devices/graphics') 
         or die "ERROR: I can't find graphic";
     $graph->setAttribute(type => 'spice');
     $graph->setAttribute(autoport => 'yes');
-    $graph->setAttribute(listen=> $IP );
+    $graph->setAttribute(listen=> $self->ip() );
 
     my ($listen) = $doc->findnodes('/domain/devices/graphics/listen');
 
@@ -575,7 +575,7 @@ sub _xml_modify_spice_port {
     }
 
     $listen->setAttribute(type => 'address');
-    $listen->setAttribute(address => $IP);
+    $listen->setAttribute(address => $self->ip());
 
 }
 
@@ -706,29 +706,4 @@ sub _xml_modify_mac {
     $if_mac->setAttribute(address => $new_mac);
 }
 
-
-#############################################################################
-#
-# inits
-#
-sub _init_ip {
-    my $name = hostname() or die "CRITICAL: I can't find the hostname.\n";
-    my $ip = inet_ntoa(inet_aton($name)) 
-        or die "CRITICAL: I can't find IP of $name in the DNS.\n";
-
-    if (!$ip || $ip =~ /^127./) {
-        #TODO Net:DNS
-        $ip= `host $name`;
-        chomp $ip;
-        $ip =~ s/.*?address (\d+)/$1/;
-    }
-    if ( !$ip || $ip =~ /^127./ || $ip !~ /^\d+\..*\.\d+$/) {
-        warn "WARNING: I can't find IP with hostname $name ( $ip )"
-            .", using localhost\n";
-        $ip='127.0.0.1';
-    }
-
-    return $ip;
-}
-
 1;

lib/Ravada/VM/Void.pm

@@ -33,6 +33,7 @@ sub create_domain {
     my $domain = Ravada::Domain::Void->new(name => $args{name}, domain => $args{name}
                                                             , id_owner => $args{id_owner}
                                            , id_base => $args{id_base}
+                                           , _vm => $self
     );
     $domain->_insert_db(name => $args{name} , id_owner => $args{id_owner}
         , id_base => $args{id_base} );
@@ -81,6 +82,7 @@ sub search_domain {
         my $domain = Ravada::Domain::Void->new( 
             domain => $name
             ,readonly => $self->readonly
+                 ,_vm => $self
         );
         my $id;
 

t/30_request.t

@@ -187,6 +187,8 @@ sub test_unread_messages {
 eval { $ravada = Ravada->new(connector => $test->connector) };
 
 ok($ravada,"I can't launch a new Ravada");# or exit;
+remove_old_domains();
+remove_old_disks();
 
 for my $vm_name ( qw(Void KVM)) {
     my $vm;

t/request/40_base.t

@@ -206,6 +206,64 @@ sub test_volumes {
 
 }
 
+sub check_files_exist {
+    my $vm_name = shift;
+    for my $file (@_) {
+        ok(-e $file
+            ,"[$vm_name] File '$file' , expected exists , got ".(-e $file));
+    }
+}
+
+sub check_files_removed {
+    my $vm_name = shift;
+    for my $file (@_) {
+        ok(!-e $file
+            ,"[$vm_name] File '$file' , expected removed, got ".(-e $file));
+    }
+}
+
+
+sub test_req_remove_base {
+    my ($vm_name, $domain_base, $domain_clone) = @_;
+
+    ok($domain_base->is_base,"[$vm_name] expecting domain ".$domain_base->id
+        ." is base , got ".$domain_base->is_base) or return;
+
+    my @files_base = $domain_base->list_files_base();
+    ok(scalar @files_base,"Expecting files base, got none") or return;
+
+    my $req = Ravada::Request->remove_base(id_domain => $domain_base->id
+        , uid => $USER->id
+    );
+
+    ok($req->status eq 'requested');
+    $ravada->process_requests();
+    wait_request($req);
+
+    ok($req->status eq 'done', "Expected req->status 'done', got "
+                                ."'".$req->status."'");
+
+    ok($req->error =~ /has \d+ clones/i, "[$vm_name] Expected error 'has X clones'"
+            .", got : '".$req->error."'");
+
+    check_files_exist(@files_base);
+    $domain_clone->remove($USER);
+    check_files_exist(@files_base);
+
+    $req->status('requested');
+    $ravada->process_requests();
+    wait_request($req);
+
+    ok($req->status eq 'done', "[$vm_name] Expected req->status 'done', got "
+                                ."'".$req->status."'");
+
+    ok(!$req->error, "Expected error ''"
+            .", got : '".$req->error."'");
+
+    ok(!$domain_base->is_base());
+    check_files_removed(@files_base);
+}
+
 ################################################
 eval { $ravada = Ravada->new(connector => $test->connector) };
 
@@ -226,11 +284,13 @@ for my $vm_name ( qw(Void KVM)) {
         remove_old_domains();
         remove_old_disks();
     
-        my $domain_base = test_req_create_domain($vm);
-        test_req_prepare_base($vm, $domain_base->name)                  if $domain_base;
-        my $domain_clone = test_req_create_from_base($vm, $domain_base) if $domain_base;
-        test_volumes($vm_name,$domain_base, $domain_clone)              if $domain_base;
+        my $domain_base = test_req_create_domain($vm) or next;
+        test_req_prepare_base($vm, $domain_base->name);
+        my $domain_clone = test_req_create_from_base($vm, $domain_base) 
+            or next;
+        test_volumes($vm_name,$domain_base, $domain_clone);
     
+        test_req_remove_base($vm_name, $domain_base, $domain_clone);
     };
 }
 

t/vm/20_base.t

@@ -81,9 +81,19 @@ sub test_display {
     my ($ip) = $display =~ m{^\w+://(.*):\d+};
     ok($ip,"Expecting an IP from $display, got none") or return;
 
-    ok($ip ne '127.0.0.1', "Expecting IP no '127.0.0.1', got '$ip'");
+    ok($ip ne '127.0.0.1', "[$vm_name] Expecting IP no '127.0.0.1', got '$ip'") or exit;
 
-    my $expected_ip =  $RAVADA::CONFIG->{display_ip} or die "Missing display_ip in ravada.conf";
+
+    # only test this for Void, it will fail on real VMs
+    return if $vm_name ne 'Void';
+
+    $Ravada::CONFIG->{display_ip} = $DISPLAY_IP;
+    $display = $domain->display($USER);
+    ($ip) = $display =~ m{^\w+://(.*):\d+};
+
+    my $expected_ip =  Ravada::display_ip();
+    ok($expected_ip,"[$vm_name] Expecting display_ip '$DISPLAY_IP' , got none in config "
+        .Dumper($Ravada::CONFIG)) or exit;
 
     ok($ip eq $expected_ip,"Expecting display IP '$expected_ip', got '$ip'");
 
@@ -119,8 +129,6 @@ sub test_prepare_base {
 
     my $name_clone = new_domain_name();
 
-    $RAVADA::CONFIG->{display_ip} = $DISPLAY_IP;
-
     my $domain_clone = $RVD_BACK->create_domain(
         name => $name_clone
         ,id_owner => $USER->id
@@ -246,13 +254,54 @@ sub test_remove_base {
     }
 }
 
+sub test_dont_remove_base_cloned {
+    my $vm_name = shift;
+
+    my $domain = test_create_domain($vm_name);
+    $domain->prepare_base($USER);
+    ok($domain->is_base,"[$vm_name] expecting domain is base, got "
+                        .$domain->is_base);
+
+    my @files = $domain->list_files_base();
+
+    my $name_clone = new_domain_name();
+
+    my $clone = rvd_back()->create_domain( name => $name_clone
+            ,id_owner => $USER->id
+            ,id_base => $domain->id
+            ,vm => $vm_name
+    );
+    eval {$domain->remove_base($USER)};
+    ok($@,"Expecting error removing base with clones, got '$@'");
+    ok($domain->is_base,"[$vm_name] expecting domain is base, got "
+                        .$domain->is_base);
+    for my $file (@files) {
+        ok(-e $file,"[$vm_name] Expecting file base '$file' not removed" );
+    }
+
+    ##################################################################3
+    # now we remove the clone, it should work
+
+    $clone->remove($USER);
+
+    eval {$domain->remove_base($USER)};
+    ok(!$@,"Expecting not error removing base with clones, got '$@'");
+    ok(!$domain->is_base,"[$vm_name] expecting domain is base, got "
+                        .$domain->is_base);
+    for my $file (@files) {
+        ok(!-e $file,"[$vm_name] Expecting file base '$file' removed" );
+    }
+
+}
+
+
 #######################################################################33
 
 
 remove_old_domains();
 remove_old_disks();
 
-for my $vm_name (@VMS) {
+for my $vm_name (reverse sort @VMS) {
 
     diag("Testing $vm_name VM");
     my $CLASS= "Ravada::VM::$vm_name";
@@ -275,6 +324,7 @@ for my $vm_name (@VMS) {
         test_prepare_base($vm_name, $domain);
         test_prepare_base_active($vm_name);
         test_remove_base($vm_name);
+        test_dont_remove_base_cloned($vm_name);
     }
 }
 

t/vm/30_remove.t

@@ -69,7 +69,7 @@ sub test_remove_domain {
     ok(!$domain_missing,"Domain ".$domain->name." should be missing");
 }
 
-sub test_remove_base {
+sub test_remove_domain_base {
     my $vm_name = shift;
 
     my $domain = test_create_domain($vm_name);
@@ -82,6 +82,7 @@ sub test_remove_base {
 
 }
 
+
 sub test_dont_remove_father {
     my $vm_name = shift;
 
@@ -188,7 +189,7 @@ for my $vm_name (@VMS) {
         skip $msg,10    if !$vm;
 
         test_remove_domain($vm_name);
-        test_remove_base($vm_name);
+        test_remove_domain_base($vm_name);
         test_dont_remove_father($vm_name);
     }
 }