Feature: compact (#1453)

feature: compact volumes

lib/Ravada.pm

@@ -1570,6 +1570,8 @@ sub _upgrade_tables {
     $self->_upgrade_table('domains','shared_storage','varchar(254)');
     $self->_upgrade_table('domains','post_shutdown','int not null default 0');
     $self->_upgrade_table('domains','post_hibernated','int not null default 0');
+    $self->_upgrade_table('domains','is_compacted','int not null default 0');
+    $self->_upgrade_table('domains','has_backups','int not null default 0');
 
     $self->_upgrade_table('domains_network','allowed','int not null default 1');
 
@@ -3786,6 +3788,42 @@ sub _cmd_set_time($self, $request) {
     die "$@ , retry.\n" if $@;
 }
 
+sub _cmd_compact($self, $request) {
+    my $id_domain = $request->args('id_domain');
+    my $domain = Ravada::Domain->open($id_domain)
+        or do {
+            $request->retry(0);
+            Ravada::Request->refresh_vms();
+            die "Error: domain $id_domain not found\n";
+        };
+
+    my $uid = $request->args('uid');
+    my $user = Ravada::Auth::SQL->search_by_id($uid);
+
+    die "Error: user ".$user->name." not allowed to compact ".$domain->name
+    unless $user->is_operator || $uid == $domain->_data('id_owner');
+
+    $domain->compact($request);
+}
+
+sub _cmd_purge($self, $request) {
+    my $id_domain = $request->args('id_domain');
+    my $domain = Ravada::Domain->open($id_domain)
+        or do {
+            $request->retry(0);
+            Ravada::Request->refresh_vms();
+            die "Error: domain $id_domain not found\n";
+        };
+
+    my $uid = $request->args('uid');
+    my $user = Ravada::Auth::SQL->search_by_id($uid);
+
+    die "Error: user ".$user->name." not allowed to compact ".$domain->name
+    unless $user->is_operator || $uid == $domain->_data('id_owner');
+
+    $domain->purge($request);
+}
+
 sub _migrate_base($self, $domain, $node, $uid, $request) {
     my $base = Ravada::Domain->open($domain->id_base);
     return if $base->base_in_vm($node->id);
@@ -4160,6 +4198,8 @@ sub _req_method {
 ,remove_hardware => \&_cmd_remove_hardware
 ,change_hardware => \&_cmd_change_hardware
 ,set_time => \&_cmd_set_time
+,compact => \&_cmd_compact
+,purge => \&_cmd_purge
 
 # Domain ports
 ,expose => \&_cmd_expose

lib/Ravada/Domain.pm

@@ -1586,7 +1586,7 @@ sub info($self, $user) {
         ,volatile_clones => $self->volatile_clones
         ,id_vm => $self->_data('id_vm')
     };
-    for (qw(comment screenshot id_owner shutdown_disconnected)) {
+    for (qw(comment screenshot id_owner shutdown_disconnected is_compacted has_backups)) {
         $info->{$_} = $self->_data($_);
     }
     if ($is_active) {
@@ -3169,12 +3169,14 @@ sub _post_start {
     my $set_time = delete $arg{set_time};
     $set_time = 1 if !defined $set_time;
 
-    $self->_data('status','active') if $self->is_active();
+    if ( $self->is_active() ) {
+        $self->_data('status','active');
+    }
     my $sth = $$CONNECTOR->dbh->prepare(
-        "UPDATE domains set start_time=? "
+        "UPDATE domains set start_time=?,is_compacted=? "
         ." WHERE id=?"
     );
-    $sth->execute(time, $self->id);
+    $sth->execute(time, 0, $self->id);
     $sth->finish;
 
     $self->_data('internal_id',$self->internal_id);
@@ -5347,4 +5349,52 @@ sub _domain_in_nodes($self) {
     return $self->list_instances > 1;
 }
 
+sub compact($self, $request=undef) {
+    #first check if active, that will trigger status refresh
+    die "Error: ".$self->name." can't be compacted because it is active\n"
+    if $self->is_active;
+
+    # now check the status, it may be hibernated or in some other
+    my $status = $self->_data('status');
+    die "Error: ".$self->name." can't be compacted because it is $status\n"
+    unless $status eq 'shutdown';
+
+    my $keep_backup = 1;
+    $keep_backup = $request->defined_arg('keep_backup') if $request;
+    $keep_backup = 1 if !defined $keep_backup;
+
+    my $backed_up = '';
+    $backed_up = " [backed up]" if $keep_backup;
+
+    my $out = '';
+    for my $vol ( $self->list_volumes_info ) {
+        next if !$vol->file || $vol->file =~ /iso$/;
+        if ( !$self->is_active ) {
+            my $vm = $self->_vm->new ( host => 'localhost' );
+            $vol->vm($vm);
+        }
+        $request->error("compacting ".$vol->file."$backed_up") if $request;
+        $out .= $vol->info->{target}." ".($vol->compact($keep_backup) or '');
+    }
+    $request->error($out) if $request;
+    $self->_data('is_compacted' => 1);
+
+    $self->_data('has_backups' => $self->_data('has_backups') +1 ) if $keep_backup;
+}
+
+sub purge($self, $request=undef) {
+    my $vm = $self->_vm->new ( host => 'localhost' );
+    for my $vol ( $self->list_volumes_info ) {
+        next if !$vol->file || $vol->file =~ /iso$/;
+        my ($dir, $file) = $vol->file =~ m{(.*)/(.*)};
+        my ($out, $err) = $vm->run_command("ls",$dir);
+        die $err if $err;
+        my @found = grep { /^$file/ } $out =~ m{^(.*backup)}mg;
+        for my $file_backup ( @found ) {
+            $vm->remove_file("$dir/$file_backup");
+        }
+    }
+    $self->_data( 'has_backups' => 0 );
+}
+
 1;

lib/Ravada/Request.pm

@@ -114,6 +114,8 @@ our %VALID_ARG = (
     ,migrate => { uid => 1, id_node => 1, id_domain => 1, start => 2, remote_ip => 2
         ,shutdown => 2, shutdown_timeout => 2
     }
+    ,compact => { uid => 1, id_domain => 1 , keep_backup => 2 }
+      ,purge => { uid => 1, id_domain => 1 }
 
     #users
     ,post_login => { user => 1, locale => 2 }
@@ -170,6 +172,7 @@ our %COMMAND = (
                     , 'remove_base_vm'
                     , 'screenshot'
                     , 'cleanup'
+                    , 'compact'
                 ]
         ,priority => 20
     }

lib/Ravada/VM.pm

@@ -441,6 +441,7 @@ sub _around_create_domain {
     my $domain = $self->$orig(%args_create, volatile => $volatile);
     $self->_add_instance_db($domain->id);
     $domain->add_volume_swap( size => $swap )   if $swap;
+    $domain->_data('is_compacted' => 1);
 
     if ($id_base) {
         $domain->run_timeout($base->run_timeout)

lib/Ravada/Volume/Class.pm

@@ -96,4 +96,14 @@ sub copy_file($self, $src, $dst) {
     die $err if $err;
 }
 
+sub backup($self) {
+    my $vol_backup = $self->file.".".time.".backup";
+    my ($out, $err) = $self->vm->run_command("cp","--preserve=all",$self->file,$vol_backup);
+        if ($err) {
+        $self->vm->remove_file($vol_backup);
+        die "Error: I can't backup $vol_backup $err";
+    }
+    return $vol_backup;
+}
+
 1;

lib/Ravada/Volume/QCOW2.pm

@@ -187,4 +187,32 @@ sub _qemu_info($self, $field=undef) {
     return $info{$field};
 }
 
+sub compact($self, $keep_backup=1) {
+    my $vol_backup = $self->backup();
+
+    my @cmd = ( "virt-sparsify"
+        , "--in-place"
+        , $self->file
+    );
+    my ($out, $err) = $self->vm->run_command(@cmd);
+    die "Error: I can't sparsify ".$self->file." , backup file stored on $vol_backup : $err"
+    if $err;
+
+    @cmd = ("qemu-img", "check", $self->file);
+    ($out, $err) = $self->vm->run_command(@cmd);
+    die "Error: problem checking ".$self->file." after virt-sparsify $err" if $err;
+
+    my ($du_backup, $du_backup_err) = $self->vm->run_command("du","-m",$vol_backup);
+    my ($du, $du_err) = $self->vm->run_command("du","-m",$self->file);
+    chomp $du_backup;
+    $du_backup =~ s/(^\d+).*/$1/;
+    chomp $du;
+    $du =~ s/(^\d+).*/$1/;
+
+    unlink $vol_backup or die "$! $vol_backup"
+    if !$keep_backup;
+
+    return int(100*($du_backup-$du)/$du_backup)." % compacted. ";
+}
+
 1;

lib/Ravada/Volume/Void.pm

@@ -102,4 +102,9 @@ sub block_commit($self) {
 
 }
 
+sub compact($self, $keep_backup) {
+    $self->backup() if $keep_backup;
+
+    return $self->info->{target}." 100% compacted. ";
+}
 1;

script/rvd_front

@@ -750,6 +750,14 @@ get '/machine/move_access/(#id_domain)/(#id_access)/(#position)' => sub {
 
 };
 
+get '/machine/compact/(#id_domain)' => sub($c) {
+    my $req = Ravada::Request->compact(
+        id_domain => $c->stash('id_domain')
+        ,uid => $USER->id
+    );
+    return $c->render(json => { request => $req->id });
+};
+
 get '/node/exists/#name' => sub {
     my $c = shift;
     my $name = $c->stash('name');

t/lib/Test/Ravada.pm

@@ -682,7 +682,7 @@ sub _remove_old_disks_kvm {
             sleep 1;
         }
         for my $volume  ( @volumes ) {
-            next if $volume->get_name !~ /^${name}_\d+.*\.(img|raw|ro\.qcow2|qcow2|void)$/;
+            next if $volume->get_name !~ /^${name}_\d+.*\.(img|raw|ro\.qcow2|qcow2|void|backup)$/;
 
             eval { $volume->delete() };
             warn $@ if $@;

t/vm/compact.t

+use warnings;
+use strict;
+
+use Carp qw(confess);
+use Data::Dumper;
+use Test::More;
+
+no warnings "experimental::signatures";
+use feature qw(signatures);
+
+use lib 't/lib';
+use Test::Ravada;
+
+sub test_compact($vm) {
+    my $domain = create_domain($vm);
+    $domain->add_volume(type => 'TMP' , format => 'qcow2', size => 1024 * 10);
+    is($domain->_data('is_compacted'),1) or exit;
+    $domain->start(user_admin);
+    is($domain->_data('is_compacted'),0) or exit;
+
+    eval { $domain->compact() };
+    like($@,qr/is active/);
+
+    is($domain->_data('is_compacted'),0);
+
+    $domain->shutdown_now(user_admin);
+    is($domain->_data('is_compacted'),0);
+
+    $domain->compact();
+    is($domain->_data('is_compacted'),1);
+
+    $domain->_data('is_compacted' => 0);
+    my $req = Ravada::Request->compact(
+        id_domain => $domain->id
+        ,uid => user_admin->id
+    );
+
+    wait_request( check_error => 0);
+    is($req->status,'done');
+    like($req->error, qr'compacted'i);
+
+    delete $domain->{_data};
+    is($domain->_data('is_compacted'),1);
+
+    for my $vol ($domain->list_volumes) {
+        next if $vol =~ /iso$/;
+        my ($dir, $file) = $vol =~ m{(.*)/(.*)};
+        my ($out, $err) = $vm->run_command("ls",$dir);
+        die $err if $err;
+        my @found = grep { /^$file/ } $out =~ m{^(.*backup)}mg;
+        is(scalar(@found),2) or die Dumper($vol,\@found);
+    }
+
+    $domain->start(user_admin);
+    $domain->hibernate(user_admin);
+
+    eval { $domain->compact() };
+    like($@,qr/t be compacted because it is/);
+
+    is($domain->_data('has_backups'),2);
+
+    $domain->purge();
+    is($domain->_data('has_backups'),0);
+    for my $vol ($domain->list_volumes) {
+        next if $vol =~ /iso$/;
+        my ($dir, $file) = $vol =~ m{(.*)/(.*)};
+        my ($out, $err) = $vm->run_command("ls",$dir);
+        die $err if $err;
+        my @found = grep { /^$file/ } $out =~ m{^(.*backup)}mg;
+        is(scalar(@found),0) or die Dumper($vol,\@found);
+    }
+
+    $domain->remove(user_admin);
+
+}
+
+#######################################################
+
+clean();
+
+for my $vm_name (vm_names() ) {
+    ok($vm_name);
+    SKIP: {
+        my $vm = rvd_back->search_vm($vm_name);
+        my $msg = "SKIPPED: No virtual managers found";
+        if ($vm && $vm_name =~ /kvm/i && $>) {
+            $msg = "SKIPPED: Test must run as root";
+            $vm = undef;
+        }
+
+        skip($msg,10)   if !$vm;
+
+        diag("test compact on $vm_name");
+        test_compact($vm);
+    }
+}
+
+end();
+done_testing();

templates/main/vm_actions.html.ep

@@ -42,4 +42,44 @@
     <br><br>
   </div>
 
+  <hr>
+
+<div class="container">
+
+  <div class="row mt-2">
+    <div class="col-lg-2" align="right">
+      <button class="btn btn-outline-dark"
+        ng-disabled="showmachine.is_compacted"
+        ng-click="request('compact',{'id_domain': showmachine.id , 'keep_backup': true })"
+        ><%=l 'Compact' %></button>
+    </div>
+    <div class="col-md-7">
+        <div><%=l 'Compact disk volumes' %></div>
+        <div ng-show="showmachine.is_compacted">
+            This virtual machine has already been compacted
+        </div>
+    </div>
+  </div>
+
+  <div class="row mt-2">
+    <div class="col-lg-2" align="right">
+      <button class="btn btn-outline-dark"
+        ng-disabled="!showmachine.has_backups"
+        ng-click="request('purge',{'id_domain': showmachine.id })"
+        ><%=l 'Purge' %></button>
+    </div>
+    <div class="col-md-7">
+        <span><%=l 'Purge disk volumes' %></span>
+        <div ng-hide="showmachine.has_backups">
+            This virtual machine has no backups to purge
+        </div>
+    </div>
+  </div>
+
+</div>
+
+  <div ng-show="pending_request">
+    %= include "/main/pending_request"
+  </div>
+
 </div>