Commit 1db6e301 authored by Francesc Guasch's avatar Francesc Guasch
Browse files

new object lib creates domains from iso now

parent 76a306d6
MYMETA.json
MYMETA.yml
Makefile
blib
pm_to_blib
t/db
......@@ -54,12 +54,22 @@ sub _init_config {
sub _create_vm {
my $self = shift;
return [ Ravada::VM::KVM->new( ) ];
return [ Ravada::VM::KVM->new( connector => $self->connector ) ];
}
sub domain_create {
sub create_domain {
my $self = shift;
$self->vm->[0]->domain_create(@_);
return $self->vm->[0]->create_domain(@_);
}
sub search_domain {
my $self = shift;
my $name = shift;
for my $vm (@{$self->vm}) {
my $domain = $vm->search_domain($name);
return $domain if $domain;
}
}
1;
......@@ -5,9 +5,41 @@ use strict;
use Moose::Role;
has 'name' => (
isa => 'Str'
requires 'name';
requires 'remove';
has 'domain' => (
isa => 'Object'
,is => 'ro'
);
sub id {
my $self = shift;
return $self->{id} if exists $self->{id};
my $sth = $self->connector->dbh->prepare("SELECT id FROM domains "
." WHERE name=?"
);
$sth->execute($self->name);
my ($id) = $sth->fetchrow;
$sth->finish;
$self->{id} = $id;
return $id;
}
sub _prepare_base_db {
my $self = shift;
my $file_img = shift;
my $sth = $self->connector->dbh->prepare(
"UPDATE domains set is_base='y',file_base_img=? "
." WHERE id=?"
);
$sth->execute($file_img , $self->id);
$sth->finish;
}
1;
......@@ -3,8 +3,178 @@ package Ravada::Domain::KVM;
use warnings;
use strict;
use IPC::Run3 qw(run3);
use Moose;
use XML::LibXML;
with 'Ravada::Domain';
has 'domain' => (
is => 'ro'
,isa => 'Sys::Virt::Domain'
,required => 1
);
has 'storage' => (
is => 'ro'
,isa => 'Sys::Virt::StoragePool'
,required => 1
);
has 'connector' => (
is => 'ro'
,isa => 'DBIx::Connector'
,required => 1
);
#################################################3
#
our $TIMEOUT_SHUTDOWN = 20;
##################################################
#
=head2 name
Returns the name of the domain
=cut
sub name {
my $self = shift;
return $self->domain->get_name;
}
sub _wait_down {
my $self = shift;
my $seconds = (shift or $TIMEOUT_SHUTDOWN);
for my $sec ( 0 .. $seconds) {
return if !$self->domain->is_active;
print "Waiting for ".$self->domain->get_name." to shutdown." if !$sec;
print ".";
sleep 1;
}
print "\n";
}
sub remove_disks {
my $self = shift;
my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description);
my $removed = 0;
for my $disk ($doc->findnodes('/domain/devices/disk')) {
next if $disk->getAttribute('device') ne 'disk';
for my $child ($disk->childNodes) {
if ($child->nodeName eq 'source') {
my $file = $child->getAttribute('file');
if (! -e $file ) {
warn "WARNING: $file already removed for ".$self->domain->get_name."\n";
next;
}
$self->vol_remove($file);
if ( -e $file ) {
unlink $file or die "$! $file";
}
$removed++;
}
}
}
warn "WARNING: No disk files removed for ".$self->domain->get_name."\n"
if !$removed;
}
sub vol_remove {
my $self = shift;
my $file = shift;
my ($name) = $file =~ m{.*/(.*)} if $file =~ m{/};
my $vol = $self->storage->get_volume_by_name($name);
if (!$vol) {
warn "WARNING: I can't find volumne $name\n";
return;
}
$vol->delete();
}
sub remove {
my $self = shift;
$self->domain->shutdown if $self->domain->is_active();
$self->_wait_down();
$self->domain->destroy if $self->domain->is_active();
$self->remove_disks();
$self->domain->undefine();
}
sub _disk_device {
my $self = shift;
my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description)
or die "ERROR: $!\n";
my $cont = 0;
my $img;
my $list_disks = '';
for my $disk ($doc->findnodes('/domain/devices/disk')) {
next if $disk->getAttribute('device') ne 'disk';
$list_disks .= $disk->toString();
die "ERROR: base disks only can have one device\n"
.$list_disks
if $cont++>1;
for my $child ($disk->childNodes) {
if ($child->nodeName eq 'source') {
# die $child->toString();
$img = $child->getAttribute('file');
$cont++;
}
}
}
return $img;
}
sub _create_qcow_base {
my $self = shift;
my $base_name = $self->name;
my $base_img = $self->_disk_device();
my $qcow_img = $base_img;
$qcow_img =~ s{\.\w+$}{\.ro.qcow2};
my @cmd = ('qemu-img','convert',
'-O','qcow2', $base_img
,$qcow_img
);
my ($in, $out, $err);
run3(\@cmd,\$in,\$out,\$err);
warn $out if $out;
warn $err if $err;
if (! -e $qcow_img) {
warn "ERROR: Output file $qcow_img not created at ".join(" ",@cmd)."\n";
exit;
}
chmod 0555,$qcow_img;
return $qcow_img;
}
sub prepare_base {
my $self = shift;
my $file_qcow = $self->_create_qcow_base();
#update domains set is_base='y' , img = $file_qcow
$self->_prepare_base_db($file_qcow);
}
1;
......@@ -3,6 +3,7 @@ use strict;
package Ravada::VM;
use Carp qw(croak);
use Moose::Role;
requires 'connect';
......@@ -11,12 +12,11 @@ requires 'connect';
# domain
requires 'domain_create';
requires 'domain_remove_vm';
requires 'prepare_base';
requires 'create_domain';
requires 'search_domain';
# storage volume
requires 'volume_create';
requires 'create_volume';
############################################################
......@@ -54,7 +54,7 @@ sub _build_connector { die "Database not connected" if !$Ravada::CONNECTOR;
############################################################
#
sub domain_remove_db {
sub _domain_remove_db {
my $self = shift;
my $name = shift;
my $sth = $self->connector->dbh->prepare("DELETE FROM domains WHERE name=?");
......@@ -62,10 +62,24 @@ sub domain_remove_db {
$sth->finish;
}
sub _domain_insert_db {
my $self = shift;
my %field = @_;
croak "Field name is mandatory ".Dumper(\%field)
if !exists $field{name};
my $sth = $self->connector->dbh->prepare("INSERT INTO domains "
."(" . join(",",sort keys %field )." )"
." VALUES (". join(",", map { '?' } keys %field )." ) "
);
$sth->execute( map { $field{$_} } sort keys %field );
$sth->finish;
}
sub domain_remove {
my $self = shift;
$self->domain_remove_vm();
$self->domain_remove_bd();
$self->_domain_remove_bd();
}
1;
......@@ -15,9 +15,17 @@ use Sys::Virt;
use URI;
use XML::LibXML;
use Ravada::Domain::KVM;
with 'Ravada::VM';
##########################################################################
#
has connector => (
is => 'ro'
,isa => 'DBIx::Connector'
,required => 1
);
has vm => (
isa => 'Sys::Virt'
......@@ -85,20 +93,88 @@ sub _load_storage_pool {
}
sub domain_create {
=head2 create_domain
Creates a domain.
$dom = $vm->create_domain(name => $name , id_iso => $id_iso);
$dom = $vm->create_domain(name => $name , id_base => $id_base);
=cut
sub create_domain {
my $self = shift;
my %args = @_;
lock_hash(%args);
croak "argument name required" if !$args{name};
croak "argument id_iso_image or id_base required"
croak "argument id_iso or id_base required"
if !$args{id_iso} && !$args{id_base};
my $domain;
my @fields = ( name => $args{name} );
if ($args{id_iso}) {
return $self->_domain_create_from_iso(@_);
$domain = $self->_domain_create_from_iso(@_);
} elsif($args{id_base}) {
$domain = $self->_domain_create_from_base(@_);
push @fields, ( id_base => $args{id_base} );
} else {
confess "TODO";
}
$self->_domain_insert_db(@fields);
return $domain;
}
=head2 search_domain
Returns true or false if domain exists.
$domain = $vm->search_domain($domain_name);
=cut
sub search_domain {
my $self = shift;
my $name = shift;
for ($self->vm->list_all_domains()) {
return Ravada::Domain::KVM->new(
domain => $_
,storage => $self->storage_pool
,connector => $self->connector
) if $_->get_name eq $name;
}
}
=head2 create_volume
Creates a new storage volume. It requires a name and a xml template file defining the volume
my $vol = $vm->create_volume($name, $file_xml);
=cut
sub create_volume {
my $self = shift;
my ($name, $file_xml) = @_;
confess "Missing volume name" if !$name;
confess "Missing xml template" if !$file_xml;
open my $fh,'<', $file_xml or die "$! $file_xml";
my $dir_img = $DEFAULT_DIR_IMG;
my $doc = $XML->load_xml(IO => $fh);
$doc->findnodes('/volume/name/text()')->[0]->setData("$name.img");
$doc->findnodes('/volume/key/text()')->[0]->setData("$dir_img/$name.img");
$doc->findnodes('/volume/target/path/text()')->[0]->setData(
"$dir_img/$name.img");
my $vol = $self->storage_pool->create_volume($doc->toString);
warn "volume $dir_img/$name.img does not exists after creating volume"
if ! -e "$dir_img/$name.img";
return "$dir_img/$name.img";
}
......@@ -109,18 +185,28 @@ sub _domain_create_from_iso {
croak "argument id_iso required"
if !$args{id_iso};
die "Domain $args{name} already exists"
if $self->search_domain($args{name});
my $vm = $self->vm;
my $storage = $self->storage_pool;
my $iso = $self->_search_iso($args{id_iso});
my $device_cdrom = _iso_name($iso);
my $device_disk = ( $args{device_disk} or undef );
my $device_disk = $self->create_volume($args{name}, $DIR_XML."/".$iso->{xml_volume});
my $xml = $self->_define_xml($args{name} , "$DIR_XML/$iso->{xml}");
_xml_modify_cdrom($xml, $device_cdrom);
_xml_modify_disk($xml, $device_disk) if $device_disk;
my $dom = $self->vm->define_domain($xml->toString());
$dom->create;
return Ravada::Domain::KVM->new(domain => $dom , storage => $self->storage_pool
,connector => $self->connector
);
}
sub _iso_name {
......@@ -394,10 +480,4 @@ sub _init_ip {
return $ip;
}
sub domain_remove_vm {}
sub prepare_base {}
sub volume_create {}
1;
CREATE TABLE `domains` (
`id` int(11) NOT NULL AUTO_INCREMENT,
`id_base` int(11) NOT NULL,
`id_base` int(11),
`name` char(80) NOT NULL,
`created` char(1) NOT NULL DEFAULT 'n',
`error` varchar(200) DEFAULT NULL,
......
CREATE TABLE `bases` (
`id` int(11) NOT NULL AUTO_INCREMENT,
`name` varchar(80) NOT NULL,
`image` varchar(255) DEFAULT NULL,
PRIMARY KEY (`id`),
UNIQUE KEY `name` (`name`)
);
CREATE TABLE `domains` (
`id` integer primary key AUTOINCREMENT,
`id_base` int(11) ,
`name` char(80) NOT NULL,
`created` char(1) NOT NULL DEFAULT 'n',
`error` varchar(200) DEFAULT NULL,
`uri` varchar(250) DEFAULT NULL,
`is_base` char(1) NOT NULL DEFAULT 'n',
`file_base_img` varchar(255) DEFAULT NULL,
UNIQUE (`id_base`,`name`),
UNIQUE (`name`)
);
use warnings;
use strict;
use IPC::Run3;
use Test::More;
use Test::SQL::Data;
......@@ -23,34 +24,62 @@ sub test_remove_domain {
my $name = shift;
my $domain;
eval {$domain = $ravada->domain_search($name) };
$domain = $ravada->search_domain($name);
if ($domain) {
diag("Removing domain $name");
$domain->remove();
}
eval {$domain = $ravada->domain_search($name) };
$domain = $ravada->search_domain($name);
die "I can't remove old domain $name"
if $domain;
}
sub test_new_domain {
my $name = "test_domain_$0";
my ($name) = $0 =~ m{.*/(.*)};
test_remove_domain($name);
my $domain = $ravada->domain_create(name => $name, id_iso => 1);
my $domain = $ravada->create_domain(name => $name, id_iso => 1);
ok($domain,"Domain not created");
ok(ref $domain =~ /Sys::Virt/, "Expecting Sys::Virt, got ".ref($domain))
my $exp_ref= 'Ravada::Domain::KVM';
ok(ref $domain eq $exp_ref, "Expecting $exp_ref , got ".ref($domain))
if $domain;
my @cmd = ('virsh','desc',$name);
my ($in,$out,$err);
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;
ok($row->{name} && $row->{name} eq $domain->name,"I can't find the domain at the db");
$sth->finish;
return $domain;
}
sub test_prepare_base {
my $domain = shift;
$domain->prepare_base();
my $sth = $test->dbh->prepare("SELECT * FROM domains WHERE name=? AND is_base='y'");
$sth->execute($domain->name);
my $row = $sth->fetchrow_hashref;
ok($row->{name} && $row->{name} eq $domain->name);
$sth->finish;
}
################################################################
test_vm_kvm();
my $domain = test_new_domain();
test_remove_domain($domain->name) if $domain;
if (ok($domain,"test domain not created")) {
test_prepare_base($domain);
test_remove_domain($domain->name);
}
done_testing();
No preview for this file type
sql:
- sql/iso_images.sql
- ../../sql/sqlite/iso_images.sql
- ../../sql/sqlite/domains.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