new object lib creates domains from iso now

.gitignore

+MYMETA.json
+MYMETA.yml
+Makefile
+blib
+pm_to_blib
+t/db

lib/Ravada.pm

@@ -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;

lib/Ravada/Domain.pm

@@ -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;

lib/Ravada/Domain/KVM.pm

@@ -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;

lib/Ravada/VM.pm

@@ -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;

lib/Ravada/VM/KVM.pm

@@ -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;

sql/domains.sql → sql/mysql/domains.sql

 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,

sql/sqlite/bases.sql

+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`)
+);

sql/sqlite/domains.sql

+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`)
+);

t/20_domain_kvm.t

 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();

t/etc/ravada.conf

 sql:
-  - sql/iso_images.sql
+  - ../../sql/sqlite/iso_images.sql
+  - ../../sql/sqlite/domains.sql