Skip to content
GitLab
Commit e29c17ac authored by Francesc Guasch's avatar Francesc Guasch
Browse files

Requests create and remove domains now

parent 99badc35
Hide whitespace changes
Inline Side-by-side
.gitignore
View file @ e29c17ac
......@@ -4,3 +4,4 @@ Makefile
blib
pm_to_blib
t/db
db
lib/Ravada.pm
View file @ e29c17ac
......@@ -3,6 +3,7 @@ package Ravada;
use warnings;
use strict;
use Data::Dumper;
use DBIx::Connector;
use Moose;
use YAML;
......@@ -63,6 +64,15 @@ sub create_domain {
return $self->vm->[0]->create_domain(@_);
}
sub remove_domain {
my $self = shift;
my $name = shift or confess "Missing domain name";
my $domain = $self->search_domain($name)
or confess "ERROR: I can't find domain $name";
$domain->remove();
}
sub search_domain {
my $self = shift;
my $name = shift;
......@@ -93,4 +103,35 @@ sub remove_volume {
}
}
sub process_requests {
my $self = shift;
my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests WHERE status='requested'");
$sth->execute;
while (my ($id)= $sth->fetchrow) {
$self->_execute(Ravada::Request->open($id));
}
$sth->finish;
}
sub _execute {
my $self = shift;
my $request = shift;
if ($request->command() eq 'create' ) {
$request->status('working');
eval { $self->create_domain(%{$request->args}) };
$request->status('done');
$request->error($@);
} elsif ($request->command eq 'remove') {
$request->status('working');
eval { $self->remove_domain($request->args('name')) };
$request->status('done');
$request->error($@);
} else {
die "Unknown command ".$request->command;
}
}
1;
lib/Ravada/Domain/KVM.pm
View file @ e29c17ac
......@@ -3,6 +3,7 @@ package Ravada::Domain::KVM;
use warnings;
use strict;
use Carp qw(cluck croak);
use Data::Dumper;
use IPC::Run3 qw(run3);
use Moose;
......@@ -92,15 +93,18 @@ sub remove_disks {
sub vol_remove {
my $self = shift;
my $file = shift;
my $warning = shift;
my ($name) = $file =~ m{.*/(.*)} if $file =~ m{/};
my $vol;
eval { $vol = $self->storage->get_volume_by_name($name) };
if (!$vol) {
warn "WARNING: I can't find volumne $name\n";
# cluck "WARNING: I can't find volume $name" if !$warning;
return;
}
$vol->delete();
return 1;
}
sub remove {
......@@ -109,19 +113,33 @@ sub remove {
$self->_wait_down();
$self->vol_remove($self->file_base_img) if $self->file_base_img();
$self->vol_remove($self->file_base_img,1) if $self->file_base_img();
$self->domain->destroy if $self->domain->is_active();
$self->remove_disks();
$self->remove_file_image();
$self->domain->undefine();
$self->_remove_domain_db();
}
sub _remove_domain_db {
my $self = shift;
my $sth = $self->connector->dbh->prepare("DELETE FROM domains "
." WHERE id=?");
$sth->execute($self->id);
$sth->finish;
}
sub remove_file_image {
my $self = shift;
my $file = $self->file_base_img;
$self->vol_remove($file) if $file;
return if !$file;
$self->vol_remove($file,1);
unlink $file or die "$! $file" if -e $file;
}
......
lib/Ravada/Request.pm 0 → 100644
View file @ e29c17ac
package Ravada::Request;
use strict;
use warnings;
use Carp qw(confess);
use JSON::XS;
use Ravada;
use vars qw($AUTOLOAD);
=pod
Request a command to the ravada backend
=cut
our %FIELD = map { $_ => 1 } qw(error);
our %FIELD_RO = map { $_ => 1 } qw(name);
our $CONNECTOR = $Ravada::CONNECTOR;
sub request {
my $proto = shift;
my $class=ref($proto) || $proto;
my $self = {};
bless ($self, $class);
return $self;
}
sub open {
my $proto = shift;
my $class = ref($proto) || $proto;
my $id = shift or confess "Missing request id";
my $sth = $CONNECTOR->dbh->prepare("SELECT * FROM requests "
." WHERE id=?");
$sth->execute($id);
my $row = $sth->fetchrow_hashref;
confess "I can't find id=$id " if !defined $row;
$sth->finish;
my $args = decode_json($row->{args}) if $row->{args};
$args = {} if !$args;
$row->{args} = $args;
bless ($row,$class);
return $row;
}
=head2 create_domain
my $req = Ravada::Request->create_domain( name => 'bla'
, id_iso => 1
);
=cut
sub create_domain {
my $proto = shift;
my $class=ref($proto) || $proto;
my %args = @_;
confess "Missing domain name "
if !$args{name};
my $self = {};
bless($self,$class);
return $self->_new_request(command => 'create' , args => encode_json(\%args));
}
=head2 remove_domain
my $req = Ravada::Request->create_domain( name => 'bla'
, id_iso => 1
);
=cut
sub remove_domain {
my $proto = shift;
my $class=ref($proto) || $proto;
my $name = shift;
$name = $name->name if ref($name) =~ /Domain/;
my %args = ( name => $name ) or confess "Missing domain name";
my $self = {};
bless($self,$class);
return $self->_new_request(command => 'remove' , args => encode_json({ name => $name }));
}
sub _new_request {
my $self = shift;
my %args = @_;
$args{status} = 'requested';
if ($args{name}) {
$args{domain_name} = $args{name};
delete $args{name};
}
$CONNECTOR = $Ravada::CONNECTOR if !defined$CONNECTOR;
my $sth = $CONNECTOR->dbh->prepare(
"INSERT INTO requests (".join(",",sort keys %args).")"
." VALUES ( "
.join(",", map { '?' } keys %args)
." )"
);
$sth->execute(map { $args{$_} } sort keys %args);
$sth->finish;
$self->{id} = $self->last_insert_id();
return $self->open($self->{id});
}
sub last_insert_id {
my $self = shift;
my $sth = $CONNECTOR->dbh->prepare("SELECT last_insert_rowid()");
$sth->execute;
my ($id) = $sth->fetchrow;
$sth->finish;
return $id;
}
sub status {
my $self = shift;
my $status = shift;
if (!defined $status) {
my $sth = $CONNECTOR->dbh->prepare("SELECT * FROM requests "
." WHERE id=?");
$sth->execute($self->{id});
my $row = $sth->fetchrow_hashref;
$sth->finish;
return ($row->{status} or 'unknown');
}
my $sth = $CONNECTOR->dbh->prepare("UPDATE requests set status=? "
." WHERE id=?");
$sth->execute($status, $self->{id});
$sth->finish;
return $status;
}
sub command {
my $self = shift;
return $self->{command};
}
sub args {
my $self = shift;
my $name = shift;
return $self->{args} if !$name;
confess "Unknown argument $name"
if !exists $self->{args}->{name};
return $self->{args}->{$name};
}
sub AUTOLOAD {
my $self = shift;
my $name = $AUTOLOAD;
my $value = shift;
$name =~ s/.*://;
$name =~ tr/[a-z]/_/c;
confess "ERROR: Unknown field $name "
if !exists $self->{$name} || !exists $FIELD{$name};
if (!defined $value) {
my $sth = $CONNECTOR->dbh->prepare("SELECT * FROM requests "
." WHERE id=?");
$sth->execute($self->{id});
my $row = $sth->fetchrow_hashref;
$sth->finish;
return $row->{$name};
}
confess "ERROR: field $name is read only"
if $FIELD_RO{$name};
my $sth = $CONNECTOR->dbh->prepare("UPDATE requests set $name=? "
." WHERE id=?");
$sth->execute($value, $self->{id});
$sth->finish;
return $value;
}
1;
lib/Ravada/VM.pm
View file @ e29c17ac
......@@ -4,6 +4,7 @@ use strict;
package Ravada::VM;
use Carp qw(croak);
use Data::Dumper;
use Moose::Role;
requires 'connect';
......@@ -67,11 +68,16 @@ sub _domain_insert_db {
my %field = @_;
croak "Field name is mandatory ".Dumper(\%field)
if !exists $field{name};
my $sth = $self->connector->dbh->prepare("INSERT INTO domains "
my $query = "INSERT INTO domains "
."(" . join(",",sort keys %field )." )"
." VALUES (". join(",", map { '?' } keys %field )." ) "
);
$sth->execute( map { $field{$_} } sort keys %field );
;
my $sth = $self->connector->dbh->prepare($query);
eval { $sth->execute( map { $field{$_} } sort keys %field ) };
if ($@) {
warn "$query\n".Dumper(\%field);
die $@;
}
$sth->finish;
}
......
sql/sqlite/requests.sql 0 → 100644
View file @ e29c17ac
CREATE TABLE `requests` (
`id` integer primary key AUTOINCREMENT ,
`command` char(32) DEFAULT NULL,
`args` char(255) DEFAULT NULL,
`date_req` datetime DEFAULT NULL,
`date_changed` datetime default current_timestamp ,
`status` char(1) DEFAULT NULL,
`error` varchar(255) DEFAULT NULL,
`id_domain` int(11) DEFAULT NULL,
`domain_name` char(80) DEFAULT NULL
);
t/20_domain_kvm.t
View file @ e29c17ac
......@@ -34,12 +34,36 @@ sub test_remove_domain {
die "I can't remove old domain $name"
if $domain;
ok(!search_domain_db($name),"Domain $name still in db");
}
sub test_remove_domain_by_name {
my $name = shift;
diag("Removing domain $name");
$ravada->remove_domain($name);
my $domain = $ravada->search_domain($name);
die "I can't remove old domain $name"
if $domain;
}
sub search_domain_db {
my $name = shift;
my $sth = $test->dbh->prepare("SELECT * FROM domains WHERE name=? ");
$sth->execute($name);
my $row = $sth->fetchrow_hashref;
return $row;
}
sub test_new_domain {
my ($name) = $0 =~ m{.*/(.*)};
my ($name) = $0 =~ m{.*/(.*)\.t};
test_remove_domain($name);
diag("Creating domain $name");
my $domain = $ravada->create_domain(name => $name, id_iso => 1);
ok($domain,"Domain not created");
......@@ -52,11 +76,8 @@ sub test_new_domain {
run3(\@cmd,\$in,\$out,\$err);
ok(!$?,"@cmd \$?=$? , it should be 0 $err $out");
my $sth = $test->dbh->prepare("SELECT * FROM domains WHERE name=? ");
$sth->execute($domain->name);
my $row = $sth->fetchrow_hashref;
my $row = search_domain_db($domain->name);
ok($row->{name} && $row->{name} eq $domain->name,"I can't find the domain at the db");
$sth->finish;
return $domain;
}
......@@ -75,11 +96,22 @@ sub test_prepare_base {
################################################################
test_vm_kvm();
my $domain = test_new_domain();
{
my $domain = test_new_domain();
if (ok($domain,"test domain not created")) {
test_prepare_base($domain);
test_remove_domain($domain->name);
if (ok($domain,"test domain not created")) {
test_prepare_base($domain);
test_remove_domain($domain->name);
}
}
{
my $domain = test_new_domain();
if (ok($domain,"test domain not created")) {
test_remove_domain_by_name($domain->name);
}
}
done_testing();
t/30_request.t 0 → 100644
View file @ e29c17ac
use warnings;
use strict;
use Test::More;
use Test::SQL::Data;
use_ok('Ravada');
use_ok('Ravada::Request');
my $test = Test::SQL::Data->new(config => 't/etc/ravada.conf');
my $ravada = Ravada->new(connector => $test->connector);
my ($DOMAIN_NAME) = $0 =~ m{.*/(.*)\.};
my $DOMAIN_NAME_SON=$DOMAIN_NAME."_son";
sub test_empty_request {
my $request = $ravada->request();
ok($request);
}
sub test_remove_domain {
my $name = shift;
my $domain = $name if ref($name);
$domain = $ravada->search_domain($name);
if ($domain) {
diag("Removing domain $name");
eval { $domain->remove() };
ok(!$@ , "Error removing domain $name : $@") or exit;
ok(! -e $domain->file_base_img ,"Image file was not removed "
. $domain->file_base_img )
if $domain->file_base_img;
}
$domain = $ravada->search_domain($name);
ok(!$domain, "I can't remove old domain $name") or exit;
}
sub test_req_create_domain_iso {
my $name = $DOMAIN_NAME."_iso";
my $req = Ravada::Request->create_domain(
name => $name
,id_iso => 1
);
ok($req);
ok($req->status);
ok(defined $req->args->{name}
&& $req->args->{name} eq $name
,"Expecting args->{name} eq $name "
." ,got '".($req->args->{name} or '<UNDEF>')."'");
ok($req->status eq 'requested'
,"Status of request is ".$req->status." it should be requested");
$ravada->process_requests();
ok($req->status eq 'done'
,"Status of request is ".$req->status." it should be done");
ok(!$req->error,"Error ".$req->error." creating domain ".$name);
my $domain = $ravada->search_domain($name);
ok($domain,"I can't find domain $name");
return $domain;
}
sub test_req_remove_domain_obj {
my $domain = shift;
my $req = Ravada::Request->remove_domain($domain);
$ravada->process_requests();
my $domain2 = $ravada->search_domain($domain->name);
ok(!$domain2,"Domain ".$domain->name." should be removed");
ok(!$req->error,"Error ".$req->error." removing domain ".$domain->name);
}
sub test_req_remove_domain_name {
my $name = shift;
my $req = Ravada::Request->remove_domain($name);
$ravada->process_requests();
my $domain = $ravada->search_domain($name);
ok(!$domain,"Domain $name should be removed");
ok(!$req->error,"Error ".$req->error." removing domain $name");
}
################################################
test_remove_domain($DOMAIN_NAME."_iso");
{
my $domain = test_req_create_domain_iso();
test_req_remove_domain_obj($domain) if $domain;
}
{
my $domain = test_req_create_domain_iso();
test_req_remove_domain_name($domain->name) if $domain;
}
test_remove_domain($DOMAIN_NAME."_iso");
done_testing();
t/etc/ravada.conf
View file @ e29c17ac
sql:
- ../../sql/sqlite/iso_images.sql
- ../../sql/sqlite/domains.sql
- ../../sql/sqlite/requests.sql
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment