KVM.pm 62 KB
Newer Older
joelalju's avatar
joelalju committed
1

2
3
package Ravada::VM::KVM;

4
5
6
7
8
9
10
11
12
use warnings;
use strict;

=head1 NAME

Ravada::VM::KVM - KVM Virtual Managers library for Ravada

=cut

13
14
15
16
17
use Carp qw(croak carp cluck);
use Data::Dumper;
use Digest::MD5;
use Encode;
use Encode::Locale;
18
use File::Path qw(make_path);
19
20
21
22
23
24
use File::Temp qw(tempfile);
use Fcntl qw(:flock O_WRONLY O_EXCL O_CREAT);
use Hash::Util qw(lock_hash);
use IPC::Run3 qw(run3);
use IO::Interface::Simple;
use JSON::XS;
25
use Mojo::DOM;
26
use Mojo::UserAgent;
27
28
29
30
31
use Moose;
use Sys::Virt;
use URI;
use XML::LibXML;

Francesc Guasch's avatar
Francesc Guasch committed
32
33
34
use feature qw(signatures);
no warnings "experimental::signatures";

35
36
37
use Ravada::Domain::KVM;
use Ravada::NetInterface::KVM;
use Ravada::NetInterface::MacVTap;
38
use Ravada::Utils;
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

with 'Ravada::VM';

##########################################################################
#

has vm => (
#    isa => 'Sys::Virt'
    is => 'rw'
    ,builder => '_connect'
    ,lazy => 1
);

has type => (
    isa => 'Str'
    ,is => 'ro'
55
    ,default => 'KVM'
56
57
58
59
60
);

#########################################################################3
#

61
#TODO use config file for DIR_XML
62
our $DIR_XML = "etc/xml";
63
$DIR_XML = "/var/lib/ravada/xml/" if $0 =~ m{^/usr/sbin};
64

Francesc Guasch's avatar
Francesc Guasch committed
65
66
our $FILE_CONFIG_QEMU = "/etc/libvirt/qemu.conf";

67
68
69
70
71
72
73
74
75
76
our $XML = XML::LibXML->new();

#-----------
#
# global download vars
#
our ($DOWNLOAD_FH, $DOWNLOAD_TOTAL);

our $CONNECTOR = \$Ravada::CONNECTOR;

Francesc Guasch's avatar
Francesc Guasch committed
77
78
79
our $WGET = `which wget`;
chomp $WGET;

80
our $CACHE_DOWNLOAD = 1;
Francesc Guasch's avatar
Francesc Guasch committed
81
our $VERIFY_ISO = 1;
Francesc Guasch's avatar
Francesc Guasch committed
82

Francesc Guasch's avatar
Francesc Guasch committed
83
our %_CREATED_DEFAULT_STORAGE = ();
84
85
86
87
88
89
90
91
92
##########################################################################


sub _connect {
    my $self = shift;

    my $vm;
    confess "undefined host" if !defined $self->host;

93
94
95
    my $con_type = $self->type;
    $con_type = 'qemu' if $self->type eq 'KVM';

96
    if ($self->host eq 'localhost') {
97
        $vm = Sys::Virt->new( address => $con_type.":///system" , readonly => $self->readonly);
98
    } else {
99
100
        confess "Error: You can't connect to remote VMs in readonly mode"
            if $self->readonly;
101
        my $transport = 'ssh';
102
103
104
        my $address = $con_type."+".$transport
                                            ."://".'root@'.$self->host
                                            ."/system";
105
        eval {
106
107
            $vm = Sys::Virt->new(
                                address => $address
108
109
110
111
112
                              ,auth => 1
                              ,credlist => [
                                  Sys::Virt::CRED_AUTHNAME,
                                  Sys::Virt::CRED_PASSPHRASE,
                              ]
113
                          );
114
         };
115
         confess $@ if $@;
116
    }
Francesc Guasch's avatar
Francesc Guasch committed
117
118
    if ( ! $vm->list_storage_pools && !$_CREATED_DEFAULT_STORAGE{$self->host}) {
	    warn "WARNING: No storage pools creating default\n";
119
    	$self->_create_default_pool($vm);
Francesc Guasch's avatar
Francesc Guasch committed
120
        $_CREATED_DEFAULT_STORAGE{$self->host}++;
121
    }
122
    $self->_check_networks($vm);
123
124
125
    return $vm;
}

126
127
128
129
130
131
132
133
134
135
136
137
138
sub _check_networks {
    my $self = shift;
    my $vm = shift;

    for my $net ($vm->list_all_networks) {
        next if $net->is_active;

        warn "INFO: Activating KVM network ".$net->get_name."\n";
        $net->create;
        $net->set_autostart(1);
    }
}

139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
=head2 disconnect

Disconnect from the Virtual Machine Manager

=cut

sub disconnect {
    my $self = shift;

    $self->vm(undef);
}

=head2 connect

Connect to the Virtual Machine Manager

=cut

sub connect {
    my $self = shift;
159
    return 1 if $self->vm;
160
    return 1 if $self->is_alive;
161

162
    return $self->vm($self->_connect);
163
164
165
#    $self->storage_pool($self->_load_storage_pool);
}

166
167
168
169
170
sub _reconnect($self) {
    $self->vm(undef);
    return $self->connect();
}

171
172
173
sub _load_storage_pool {
    my $self = shift;

174
175
    confess "no hi ha vm" if !$self->vm;

176
177
178
    my $vm_pool;
    my $available;

Francesc Guasch's avatar
Francesc Guasch committed
179
    if ($self->default_storage_pool_name) {
180
181
182
183
        return( $self->vm->get_storage_pool_by_name($self->default_storage_pool_name)
            or confess "ERROR: Unknown storage pool: ".$self->default_storage_pool_name);
    }

184
185
186
    for my $pool ($self->vm->list_storage_pools) {
        my $info = $pool->get_info();
        next if defined $available
187
                && $info->{available} <= $available;
188
189
190
191
192
193
194
195
196
197

        my $doc = $XML->load_xml(string => $pool->get_xml_description);

        my ($path) =$doc->findnodes('/pool/target/path/text()');
        next if !$path;

        $vm_pool = $pool;
        $available = $info->{available};

    }
Francesc Guasch's avatar
Francesc Guasch committed
198
    confess "I can't find /pool/target/path in the storage pools xml\n"
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
        if !$vm_pool;

    return $vm_pool;

}

=head2 storage_pool

Returns a storage pool usable by the domain to store new volumes.

=cut

sub storage_pool {
    my $self = shift;

    return $self->_load_storage_pool();
}

217
218
219
220
221
=head2 search_volume

Searches for a volume in all the storage pools known to the Virtual Manager

Argument: the filenaname;
Francesc Guasch's avatar
Francesc Guasch committed
222
223
Returns the volume as a Sys::Virt::StorageGol. If called in array context returns a
list of all the volumes.
224
225
226
227
228
229
230

    my $iso = $vm->search_volume("debian-8.iso");

    my @disk = $vm->search_volume("windows10-clone.img");

=cut

Francesc Guasch's avatar
Francesc Guasch committed
231
sub search_volume($self,$file,$refresh=0) {
232
    confess "ERROR: undefined file" if !defined $file;
Francesc Guasch's avatar
Francesc Guasch committed
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

    my ($name) = $file =~ m{.*/(.*)};
    $name = $file if !defined $name;

    my $vol;
    for my $pool ($self->vm->list_storage_pools) {
        if ($refresh) {
            $pool->refresh();
            sleep 1;
        }
        eval { $vol = $pool->get_volume_by_name($name) };
        die $@ if $@ && $@ !~ /^libvirt error code: 50,/;
    }

    return $self->search_volume_re(qr(^$name$),$refresh);
Francesc Guasch's avatar
Francesc Guasch committed
248
}
249

Francesc Guasch's avatar
Francesc Guasch committed
250
=head2 search_volume_path
251

Francesc Guasch's avatar
Francesc Guasch committed
252
Searches for a volume in all the storage pools known to the Virtual Manager
253

Francesc Guasch's avatar
Francesc Guasch committed
254
255
256
257
258
259
260
261
262
263
264
Argument: the filenaname;
Returns the path of the volume. If called in array context returns a
list of all the paths to all the matching volumes.

    my $iso = $vm->search_volume("debian-8.iso");

    my @disk = $vm->search_volume("windows10-clone.img");



=cut
265

Francesc Guasch's avatar
Francesc Guasch committed
266
267
268
sub search_volume_path {
    my $self = shift;
    my @volume = $self->search_volume(@_);
Francesc Guasch's avatar
Francesc Guasch committed
269

Francesc Guasch's avatar
Francesc Guasch committed
270
271
272
273
274
275
    my @vol2 = map { $_->get_path() if ref($_) } @volume;

    return $vol2[0] if !wantarray;
    return @vol2;
}

Francesc Guasch's avatar
Francesc Guasch committed
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
=head2 search_volume_re

Searches for a volume in all the storage pools known to the Virtual Manager

Argument: a regular expression;
Returns the volume. If called in array context returns a
list of all the matching volumes.

    my $iso = $vm->search_volume(qr(debian-\d+\.iso));

    my @disk = $vm->search_volume(qr(windows10-clone.*\.img));

=cut

sub search_volume_re($self,$pattern,$refresh=0) {

    confess "'$pattern' doesn't look like a regexp to me ".ref($pattern)
        if !ref($pattern) || ref($pattern) ne 'Regexp';
Francesc Guasch's avatar
Francesc Guasch committed
294

Francesc Guasch's avatar
Francesc Guasch committed
295
    $self->_connect();
296
297
    $self->_refresh_storage_pools()    if $refresh;

Francesc Guasch's avatar
Francesc Guasch committed
298
299
300
    my @volume;
    for my $pool ($self->vm->list_storage_pools) {
        for my $vol ( $pool->list_all_volumes()) {
Francesc Guasch's avatar
Francesc Guasch committed
301
302
            my ($file) = $vol->get_path =~ m{.*/(.*)};
            next if $file !~ $pattern;
Francesc Guasch's avatar
Francesc Guasch committed
303

Francesc Guasch's avatar
Francesc Guasch committed
304
305
            return $vol if !wantarray;
            push @volume,($vol);
Francesc Guasch's avatar
Francesc Guasch committed
306
307
        }
    }
Francesc Guasch's avatar
Francesc Guasch committed
308
309
310
311
312
313
314
    if (!scalar @volume && !$refresh && !$self->readonly
            && time - ($self->{_time_refreshed} or 0) > 60) {
        $self->{_time_refreshed} = time;
        @volume = $self->search_volume_re($pattern,"refresh");
        return $volume[0] if !wantarray && scalar @volume;
    }
    return if !wantarray && !scalar@volume;
Francesc Guasch's avatar
Francesc Guasch committed
315
316
317
    return @volume;
}

318
319
320
321
sub refresh_storage_pools($self) {
    $self->_refresh_storage_pools();
}

322
323
sub _refresh_storage_pools($self) {
    for my $pool ($self->vm->list_storage_pools) {
324
325
326
327
328
329
        for ( 1 .. 10 ) {
            eval { $pool->refresh() };
            last if !$@;
            warn $@ if $@ !~ /pool .* has asynchronous jobs running/;
            sleep 1;
        }
330
331
332
    }
}

333
334
335
336
337
338
339
340
=head2 refresh_storage

Refreshes all the storage pools

=cut

sub refresh_storage($self) {
    $self->_refresh_storage_pools();
Francesc Guasch's avatar
Francesc Guasch committed
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
    $self->_refresh_isos();
}

sub _refresh_isos($self) {
    $self->_init_connector();
    my $sth = $$CONNECTOR->dbh->prepare(
        "SELECT * FROM iso_images ORDER BY name"
    );
    my $sth_update = $$CONNECTOR->dbh->prepare("UPDATE iso_images set device=? WHERE id=?");

    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {

        if ( $row->{device} && !-e $row->{device} ) {
            delete $row->{device};
            $sth_update->execute($row->{device}, $row->{id});
            next;
        }
        next if $row->{device};

        my ($file);
        ($file) = $row->{url} =~ m{.*/(.*)}   if $row->{url};
        my $file_re = $row->{file_re};

        next if $row->{device};
        if ($file) {
            my $iso_file = $self->search_volume_path($file);
            if ($iso_file) {
                $row->{device} = $iso_file;
            }
        }
        if (!$row->{device} && $file_re) {
            my $iso_file = $self->search_volume_path_re(qr($file_re));
            if ($iso_file) {
                $row->{device} = $iso_file;
            }
        }
        $sth_update->execute($row->{device}, $row->{id}) if $row->{device};
    }
    $sth->finish;
381
382
}

Francesc Guasch's avatar
Francesc Guasch committed
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
=head2 search_volume_path_re

Searches for a volume in all the storage pools known to the Virtual Manager

Argument: a regular expression;
Returns the volume path. If called in array context returns a
list of all the paths of all the matching volumes.

    my $iso = $vm->search_volume(qr(debian-\d+\.iso));

    my @disk = $vm->search_volume(qr(windows10-clone.*\.img));

=cut


sub search_volume_path_re($self, $pattern) {
    my @vol = $self->search_volume_re($pattern);

    return if !wantarray && !scalar @vol;
    return $vol[0]->get_path if !wantarray;

    return map { $_->get_path() if ref($_) } @vol;

}

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
=head2 dir_img

Returns the directory where disk images are stored in this Virtual Manager

=cut

sub dir_img {
    my $self = shift;

    my $pool = $self->_load_storage_pool();
    $pool = $self->_create_default_pool() if !$pool;
    my $xml = XML::LibXML->load_xml(string => $pool->get_xml_description());

    my $dir = $xml->findnodes('/pool/target/path/text()');
    die "I can't find /pool/target/path in ".$xml->toString
        if !$dir;

    return $dir;
}

428
sub _storage_path($self, $storage) {
Francesc Guasch's avatar
Francesc Guasch committed
429
430
431
    if (!ref($storage)) {
        $storage = $self->vm->get_storage_pool_by_name($storage);
    }
432
433
434
435
436
437
438
439
440
441
    my $xml = XML::LibXML->load_xml(string => $storage->get_xml_description());

    my $dir = $xml->findnodes('/pool/target/path/text()');
    die "I can't find /pool/target/path in ".$xml->toString
        if !$dir;

    return $dir;

}

442
443
sub _create_default_pool {
    my $self = shift;
444
445
    my $vm = shift;
    $vm = $self->vm if !$vm;
446
447
448

    my $uuid = Ravada::VM::KVM::_new_uuid('68663afc-aaf4-4f1f-9fff-93684c260942');

449
    my $dir = "/var/lib/libvirt/images";
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
    mkdir $dir if ! -e $dir;

    my $xml =
"<pool type='dir'>
  <name>default</name>
  <uuid>$uuid</uuid>
  <capacity unit='bytes'></capacity>
  <allocation unit='bytes'></allocation>
  <available unit='bytes'></available>
  <source>
  </source>
  <target>
    <path>$dir</path>
    <permissions>
      <mode>0711</mode>
      <owner>0</owner>
      <group>0</group>
    </permissions>
  </target>
</pool>"
;
Francesc Guasch's avatar
Francesc Guasch committed
471
472
473
474
475
476
477
    my $pool;
    eval {
        $pool = $vm->define_storage_pool($xml);
        $pool->create();
        $pool->set_autostart(1);
    };
    warn $@ if $@;
478
479
480
481
482
483
484
485
486
487

}

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

488
489
490
491
492
493
Creates a domain and removes the CPU defined in the XML template:

    $dom = $vm->create_domain(        name => $name 
                                  , id_iso => $id_iso
                              , remove_cpu => 1);

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
=cut

sub create_domain {
    my $self = shift;
    my %args = @_;
    $args{active} = 1 if !defined $args{active};

    croak "argument name required"       if !$args{name};
    croak "argument id_owner required"   if !$args{id_owner};
    croak "argument id_iso or id_base required ".Dumper(\%args)
        if !$args{id_iso} && !$args{id_base};

    my $domain;
    if ($args{id_iso}) {
        $domain = $self->_domain_create_from_iso(@_);
    } elsif($args{id_base}) {
        $domain = $self->_domain_create_from_base(@_);
    } else {
        confess "TODO";
    }

    return $domain;
}

=head2 search_domain

Returns true or false if domain exists.

    $domain = $vm->search_domain($domain_name);

=cut

526
sub search_domain($self, $name, $force=undef) {
527

Francesc Guasch's avatar
Francesc Guasch committed
528
529
530
531
532
533
534
535
536
537
538
    eval {
        $self->connect();
    };
    if ($@ && $@ =~ /libvirt error code: 38,/) {
        warn $@;
        if (!$self->is_local) {
            warn "DISABLING NODE ".$self->name;
            $self->enabled(0);
        }
        return;
    }
539

540
541
    my $dom;
    eval { $dom = $self->vm->get_domain_by_name($name); };
Francesc Guasch's avatar
Francesc Guasch committed
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
    my $error = $@;
    return if $error =~  /error code: 42,/ && !$force;

    if ($error && $error =~ /libvirt error code: 38,/ ) {
        eval {
            $self->disconnect;
            $self->connect;
        };
        confess "Error connecting to ".$self->name." $@" if $@;
        eval { $dom = $self->vm->get_domain_by_name($name); };
        confess $@ if $@ && $@ !~  /error code: 42,/;
    } elsif ($error && $error !~ /error code: 42,/) {
        confess $error;
    }

Francesc Guasch's avatar
Francesc Guasch committed
557
558
559
560
    if (!$dom) {
        return if !$force;
        return if !$self->_domain_in_db($name);
    }
561

562
    my $domain;
563

564
        my @domain = ( );
Francesc Guasch's avatar
Francesc Guasch committed
565
566
        push @domain, ( domain => $dom ) if $dom;
        push @domain, ( id_owner => $Ravada::USER_DAEMON->id)
Francesc Guasch's avatar
Francesc Guasch committed
567
            if $force && !$self->_domain_in_db($name);
568
569
        eval {
            $domain = Ravada::Domain::KVM->new(
570
571
                @domain
                ,name => $name
572
573
574
575
576
577
                ,readonly => $self->readonly
                ,_vm => $self
            );
        };
        warn $@ if $@;
        if ($domain) {
Francesc Guasch's avatar
Francesc Guasch committed
578
            $domain->xml_description()  if $dom && $domain->is_known();
579
580
            return $domain;
        }
581

582
583
584
585
586
587
588
589
590
591
592
593
594
    return;
}

=head2 list_domains

Returns a list of the created domains

  my @list = $vm->list_domains();

=cut

sub list_domains {
    my $self = shift;
595
596
    my %args = @_;

597
598
    return if !$self->vm;

599
    my $active = (delete $args{active} or 0);
600
    my $read_only = delete $args{read_only};
601

602
    confess "Arguments unknown ".Dumper(\%args)  if keys %args;
603

604
605
606
607
608
609
    my $query = "SELECT id, name FROM domains WHERE id_vm = ? ";
    $query .= " AND status = 'active' " if $active;

    my $sth = $$CONNECTOR->dbh->prepare($query);

    $sth->execute( $self->id );
610
    my @list;
Francesc Guasch's avatar
Francesc Guasch committed
611
    while ( my ($id) = $sth->fetchrow) {
612
613
614
615
616
617
        my $domain;
        if ($read_only) {
            $domain = Ravada::Front::Domain->open( $id );
        } else {
            $domain = Ravada::Domain->open( id => $id, vm => $self);
        }
618
        push @list,($domain) if $domain;
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
    }
    return @list;
}

=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 => $name, name => $file_xml);

=cut

sub create_volume {
    my $self = shift;

    confess "Wrong arrs " if scalar @_ % 2;
    my %args = @_;

637
638
639
640
641
642
643
644
645
646
    my $name = delete $args{name}       or confess "ERROR: Missing volume name";
    my $file_xml = delete $args{xml}   or confess "ERROR: Missing XML template";

    my $size        = delete $args{size};
    my $swap        =(delete $args{swap} or 0);
    my $target      = delete $args{target};
    my $capacity    = delete $args{capacity};
    my $allocation  = delete $args{allocation};

    confess "ERROR: Unknown args ".Dumper(\%args)   if keys %args;
647
648

    confess "Invalid size"          if defined $size && ( $size == 0 || $size !~ /^\d+$/);
Francesc Guasch's avatar
Francesc Guasch committed
649
650
651
652

    confess "Invalid capacity"
        if defined $capacity && ( $capacity == 0 || $capacity !~ /^\d+$/);

653
654
655
656
657
658
659
    confess "Capacity and size are the same, give only one of them"
        if defined $capacity && defined $size;

    $capacity = $size if defined $size;
    $allocation = int($capacity * 0.1)+1
        if !defined $allocation && $capacity;

660
    open my $fh,'<', $file_xml or confess "$! $file_xml";
661
662
663
664
665

    my $doc;
    eval { $doc = $XML->load_xml(IO => $fh) };
    die "ERROR reading $file_xml $@"    if $@;

666
667
668
669
670
671
672
673
674
    my $storage_pool = $self->storage_pool();

    my $img_file = $self->_volume_path(
        target => $target
        , swap => $swap
        , name => $name
        , storage => $storage_pool
    );

675
676
677
678
679
680
681
    my ($volume_name) = $img_file =~m{.*/(.*)};
    $doc->findnodes('/volume/name/text()')->[0]->setData($volume_name);
    $doc->findnodes('/volume/key/text()')->[0]->setData($img_file);
    $doc->findnodes('/volume/target/path/text()')->[0]->setData(
                        $img_file);

    if ($capacity) {
Francesc Guasch's avatar
Francesc Guasch committed
682
683
        confess "Size '$capacity' too small" if $capacity< 1024*10;
        $doc->findnodes('/volume/allocation/text()')->[0]->setData(int($allocation));
684
685
        $doc->findnodes('/volume/capacity/text()')->[0]->setData($capacity);
    }
686
687
688
    my $vol = $self->storage_pool->create_volume($doc->toString)
        or die "volume $img_file does not exists after creating volume on ".$self->name." "
            .$doc->toString();
689
690
691
692
693
694
695
696
697

    return $img_file;

}

sub _volume_path {
    my $self = shift;

    my %args = @_;
698
699
700
701
702
703
    my $swap     =(delete $args{swap} or 0);
    my $target   = delete $args{target};
    my $storage  = delete $args{storage} or confess "ERROR: Missing storage";
    my $filename = $args{name}  or confess "ERROR: Missing name";

    my $dir_img = $self->_storage_path($storage);
704
    my $suffix = ".img";
705
    $suffix = ".SWAP.img"   if $swap;
706
707
    $filename .= "-$target" if $target;
    my (undef, $img_file) = tempfile($filename."-XXXX"
708
709
710
711
712
713
714
715
716
717
        ,DIR => $dir_img
        ,OPEN => 0
        ,SUFFIX => $suffix
    );
    return $img_file;
}

sub _domain_create_from_iso {
    my $self = shift;
    my %args = @_;
718
    my %args2 = %args;
719
    for (qw(id_iso id_owner name)) {
720
        delete $args2{$_};
721
722
723
        croak "argument $_ required"
            if !$args{$_};
    }
724
    my $remove_cpu = delete $args2{remove_cpu};
Francesc Guasch's avatar
Francesc Guasch committed
725
    for (qw(disk swap active request vm memory iso_file id_template volatile)) {
726
727
        delete $args2{$_};
    }
728
729

    my $iso_file = delete $args{iso_file};
730
731
    confess "Unknown parameters : ".join(" , ",sort keys %args2)
        if keys %args2;
732
733
734
735
736

    die "Domain $args{name} already exists"
        if $self->search_domain($args{name});

    my $vm = $self->vm;
737
    my $iso = $self->_search_iso($args{id_iso} , $iso_file);
738
739
740

    die "ERROR: Empty field 'xml_volume' in iso_image ".Dumper($iso)
        if !$iso->{xml_volume};
741
742
        
    my $device_cdrom;
743
744

    confess "Template ".$iso->{name}." has no URL, iso_file argument required."
Francesc Guasch's avatar
Francesc Guasch committed
745
        if !$iso->{url} && !$iso_file && !$iso->{device};
746

747
748
749
750
    if ($iso_file) {
        if ( $iso_file ne "<NONE>") {
            $device_cdrom = $iso_file;
        }
751
752
    }
    else {
joelalju's avatar
joelalju committed
753
      $device_cdrom = $self->_iso_name($iso, $args{request});
754
755
    }
    
joelalju's avatar
joelalju committed
756
757
758
759
760
761
762
    #if ((not exists $args{iso_file}) || ((exists $args{iso_file}) && ($args{iso_file} eq "<NONE>"))) {
    #    $device_cdrom = $self->_iso_name($iso, $args{request});
    #}
    #else {
    #    $device_cdrom = $args{iso_file};
    #}
    
763
764
    my $disk_size;
    $disk_size = $args{disk} if $args{disk};
765
766
767

    my $file_xml =  $DIR_XML."/".$iso->{xml_volume};

768
769
    my $device_disk = $self->create_volume(
          name => $args{name}
770
         , xml => $file_xml
771
        , size => $disk_size
772
        ,target => 'vda'
773
774
775
776
    );

    my $xml = $self->_define_xml($args{name} , "$DIR_XML/$iso->{xml}");

777
778
779
780
781
    if ($device_cdrom) {
        _xml_modify_cdrom($xml, $device_cdrom);
    } else {
        _xml_remove_cdrom($xml);
    }
782
    _xml_remove_cpu($xml)                     if $remove_cpu;
783
784
785
786
    _xml_modify_disk($xml, [$device_disk])    if $device_disk;
    $self->_xml_modify_usb($xml);
    _xml_modify_video($xml);

787
788
    my ($domain, $spice_password)
        = $self->_domain_create_common($xml,%args);
Francesc Guasch's avatar
Francesc Guasch committed
789
790
791
    $domain->_insert_db(name=> $args{name}, id_owner => $args{id_owner}
        , id_vm => $self->id
    );
Francesc Guasch's avatar
Francesc Guasch committed
792

793
794
    $domain->_set_spice_password($spice_password)
        if $spice_password;
795
    $domain->xml_description();
796
797
798
799
800
801
802
803
804

    return $domain;
}

sub _domain_create_common {
    my $self = shift;
    my $xml = shift;
    my %args = @_;

805
    my $id_owner = delete $args{id_owner} or confess "ERROR: The id_owner is mandatory";
806
    my $is_volatile = delete $args{is_volatile};
807
    my $remote_ip = delete $args{remote_ip};
808
809
810
    my $user = Ravada::Auth::SQL->search_by_id($id_owner)
        or confess "ERROR: User id $id_owner doesn't exist";

811
    my $spice_password = Ravada::Utils::random_name(4);
812
813
814
815
    if ($remote_ip) {
        my $network = Ravada::Network->new(address => $remote_ip);
        $spice_password = undef if !$network->requires_password;
    }
816
817
818
    $self->_xml_modify_memory($xml,$args{memory})   if $args{memory};
    $self->_xml_modify_network($xml , $args{network})   if $args{network};
    $self->_xml_modify_mac($xml);
Francesc Guasch's avatar
Francesc Guasch committed
819
    my $uuid = $self->_xml_modify_uuid($xml);
820
    $self->_xml_modify_spice_port($xml, $spice_password);
821
    $self->_fix_pci_slots($xml);
JanFontanet's avatar
JanFontanet committed
822
    $self->_xml_add_guest_agent($xml);
823
    $self->_xml_clean_machine_type($xml) if !$self->is_local;
Francesc Guasch's avatar
Francesc Guasch committed
824
    $self->_xml_add_sysinfo_entry($xml, hostname => $args{name});
825
826
827

    my $dom;

Francesc Guasch's avatar
Francesc Guasch committed
828
829
830
831
832
833
834
835
836
837
838
839
    for ( 1 .. 10 ) {
        eval {
            if ($user->is_temporary || $is_volatile ) {
                $dom = $self->vm->create_domain($xml->toString());
            } else {
                $dom = $self->vm->define_domain($xml->toString());
                $dom->create if $args{active};
            }
        };

        last if !$@;
        if ($@ =~ /libvirt error code: 9, .*already defined with uuid/) {
Francesc Guasch's avatar
Francesc Guasch committed
840
            $self->_xml_modify_uuid($xml);
Francesc Guasch's avatar
Francesc Guasch committed
841
842
        } elsif ($@ =~ /libvirt error code: 1, .* pool .* asynchronous/) {
            sleep 1;
843
        } else {
Francesc Guasch's avatar
Francesc Guasch committed
844
            last ;
845
        }
Francesc Guasch's avatar
Francesc Guasch committed
846
    }
847
848
    if ($@) {
        my $out;
849
		warn $self->name."\n".$@;
850
851
852
853
854
855
856
        my $name_out = "/var/tmp/$args{name}.xml";
        warn "Dumping $name_out";
        open $out,">",$name_out and do {
            print $out $xml->toString();
        };
        close $out;
        warn "$! $name_out" if !$out;
857
        confess $@ if !$dom;
858
859
860
861
862
863
    }

    my $domain = Ravada::Domain::KVM->new(
              _vm => $self
         , domain => $dom
        , storage => $self->storage_pool
Francesc Guasch's avatar
Francesc Guasch committed
864
       , id_owner => $id_owner
865
    );
866
    return ($domain, $spice_password);
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
}

sub _create_disk {
    return _create_disk_qcow2(@_);
}

sub _create_swap_disk {
    return _create_disk_raw(@_);
}

sub _create_disk_qcow2 {
    my $self = shift;
    my ($base, $name) = @_;

    confess "Missing base" if !$base;
    confess "Missing name" if !$name;

    my $dir_img  = $self->dir_img;
Francesc Guasch's avatar
Francesc Guasch committed
885
886
    my $clone_pool = $self->clone_storage_pool();
    $dir_img = $self->_storage_path($clone_pool) if $clone_pool;
887
888
889

    my @files_out;

890
891
    for my $file_data ( $base->list_files_base_target ) {
        my ($file_base,$target) = @$file_data;
892
893
        my $ext = ".qcow2";
        $ext = ".SWAP.qcow2" if $file_base =~ /\.SWAP\.ro\.\w+$/;
894
895
        my $file_out = "$dir_img/$name-".($target or _random_name(2))
            ."-"._random_name(2).$ext;
896

897
898
899
900
901
902
903
904
905
906
907
        $self->_clone_disk($file_base, $file_out);
        push @files_out,($file_out);
    }
    return @files_out;

}

# this may become official API eventually

sub _clone_disk($self, $file_base, $file_out) {

908
        my @cmd = ('/usr/bin/qemu-img','create'
909
910
911
912
913
                ,'-f','qcow2'
                ,"-b", $file_base
                ,$file_out
        );

914
915
        my ($out, $err) = $self->run_command(@cmd);
        die $err if $err;
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
}

sub _create_disk_raw {
    my $self = shift;
    my ($base, $name) = @_;

    confess "Missing base" if !$base;
    confess "Missing name" if !$name;

    my $dir_img  = $self->dir_img;

    my @files_out;

    for my $file_base ( $base->list_files_base ) {
        next unless $file_base =~ /SWAP\.img$/;
        my $file_out = $file_base;
        $file_out =~ s/\.ro\.\w+$//;
        $file_out =~ s/-.*(img|qcow\d?)//;
        $file_out .= ".$name-".Ravada::Utils::random_name(4).".SWAP.img";

        push @files_out,($file_out);
    }
    return @files_out;

}

sub _random_name { return Ravada::Utils::random_name(@_); };

sub _search_domain_by_id {
    my $self = shift;
    my $id = shift;

    my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM domains WHERE id=?");
    $sth->execute($id);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;

    return $self->search_domain($row->{name});
}

sub _domain_create_from_base {
    my $self = shift;
    my %args = @_;

    confess "argument id_base or base required ".Dumper(\%args)
        if !$args{id_base} && !$args{base};

    die "Domain $args{name} already exists"
        if $self->search_domain($args{name});

966
    my $base = $args{base};
967
968
969
970
971
972
973

    $base = $self->_search_domain_by_id($args{id_base}) if $args{id_base};
    confess "Unknown base id: $args{id_base}" if !$base;

    my $vm = $self->vm;
    my $storage = $self->storage_pool;

974
    my $xml = XML::LibXML->load_xml(string => $base->get_xml_base());
975
976
977
978
979
980
981
982
983
984


    my @device_disk = $self->_create_disk($base, $args{name});
#    _xml_modify_cdrom($xml);
    _xml_remove_cdrom($xml);
    my ($node_name) = $xml->findnodes('/domain/name/text()');
    $node_name->setData($args{name});

    _xml_modify_disk($xml, \@device_disk);#, \@swap_disk);

985
    my ($domain, $spice_password)
986
        = $self->_domain_create_common($xml,%args, is_volatile => $base->volatile_clones);
Francesc Guasch's avatar
Francesc Guasch committed
987
988
989
    $domain->_insert_db(name=> $args{name}, id_base => $base->id, id_owner => $args{id_owner}
        , id_vm => $self->id
    );
990
    $domain->_set_spice_password($spice_password);
991
    $domain->xml_description();
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
    return $domain;
}

sub _fix_pci_slots {
    my $self = shift;
    my $doc = shift;

    my %dupe = ("0x01/0x1" => 1); #reserved por IDE PCI
    my ($all_devices) = $doc->findnodes('/domain/devices');

    for my $dev ($all_devices->findnodes('*')) {

        # skip IDE PCI, reserved before
        next if $dev->getAttribute('type')
1006
            && $dev->getAttribute('type') =~ /^(ide)$/i;
1007
1008
1009
1010
1011

#        warn "finding address of type ".$dev->getAttribute('type')."\n";

        for my $child ($dev->findnodes('address')) {
            my $bus = $child->getAttribute('bus');
1012
1013
1014
1015
1016
1017
            my $slot = ($child->getAttribute('slot') or '');
            my $function = ($child->getAttribute('function') or '');
            my $multifunction = $child->getAttribute('multifunction');

            my $index = "$bus/$slot/$function";

1018
            next if !defined $slot;
1019
1020
1021
1022
1023

            if (!$dupe{$index} || ($multifunction && $multifunction eq 'on') ) {
                $dupe{$index} = $dev->toString();
                next;
            }
1024
1025
1026

            my $new_slot = $slot;
            for (;;) {
1027
                last if !$dupe{"$bus/$new_slot/$function"};
1028
1029
1030
1031
1032
                my ($n) = $new_slot =~ m{x(\d+)};
                $n++;
                $n= "0$n" if length($n)<2;
                $new_slot="0x$n";
            }
1033
            $dupe{"$bus/$new_slot/$function"}++;
1034
1035
1036
1037
1038
1039
            $child->setAttribute(slot => $new_slot);
        }
    }

}

1040
sub _iso_name($self, $iso, $req, $verbose=1) {
1041

1042
    my $iso_name;
1043
1044
1045
1046
1047
1048
    if ($iso->{rename_file}) {
        $iso_name = $iso->{rename_file};
    } else {
        ($iso_name) = $iso->{url} =~ m{.*/(.*)} if $iso->{url};
        ($iso_name) = $iso->{device} if !$iso_name;
    }
1049
1050

    confess "Unknown iso_name for ".Dumper($iso)    if !$iso_name;
1051

1052
    my $device = ($iso->{device} or $self->dir_img."/$iso_name");
1053

Francesc Guasch's avatar
Francesc Guasch committed
1054
    confess "Missing MD5 and SHA256 field on table iso_images FOR $iso->{url}"
Francesc Guasch's avatar
Francesc Guasch committed
1055
        if $VERIFY_ISO && $iso->{url} && !$iso->{md5} && !$iso->{sha256};
1056

1057
    my $downloaded = 0;
1058
1059
1060
1061
1062
    if (! -e $device || ! -s $device) {
        $req->status("downloading $iso_name file"
                ,"Downloading ISO file for $iso_name "
                 ." from $iso->{url}. It may take several minutes"
        )   if $req;
1063
        _fill_url($iso);
1064
        my $url = $self->_download_file_external($iso->{url}, $device, $verbose);
1065
        $self->_refresh_storage_pools();
1066
1067
        die "Download failed, file $device missing.\n"
            if ! -e $device;
Francesc Guasch's avatar
Francesc Guasch committed
1068
1069
1070

        my $verified = 0;
        for my $check ( qw(md5 sha256)) {
1071
1072
1073
1074
1075
            if (!$iso->{$check} && $iso->{"${check}_url"}) {
                my ($url_path,$url_file) = $url =~ m{(.*)/(.*)};
                $iso->{"${check}_url"} =~ s/(.*)\$url(.*)/$1$url_path$2/;
                $self->_fetch_this($iso,$check,$url_file);
            }
Francesc Guasch's avatar
Francesc Guasch committed
1076
1077
1078
1079
1080
            next if !$iso->{$check};

            die "Download failed, $check id=$iso->{id} missmatched for $device."
            ." Please read ISO "
            ." verification missmatch at operation docs.\n"
1081
            if (! _check_signature($device, $check, $iso->{$check}));
Francesc Guasch's avatar
Francesc Guasch committed
1082
1083
            $verified++;
        }
1084
        die "WARNING: $device signature not verified ".Dumper($iso)    if !$verified;
1085

1086
        $req->status("done","File $iso->{filename} downloaded") if $req;
1087
1088
1089
        $downloaded = 1;
    }
    if ($downloaded || !$iso->{device} ) {
1090
        my $sth = $$CONNECTOR->dbh->prepare(
1091
                "UPDATE iso_images SET device=? WHERE id=?"
1092
1093
1094
        );
        $sth->execute($device,$iso->{id});
    }
1095
    $self->_refresh_storage_pools();
1096
1097
1098
    return $device;
}

1099
1100
1101
1102
1103
sub _fill_url($iso) {
    return if $iso->{url} =~ m{.*/[^/]+\.[^/]+$};
    if ($iso->{file_re}) {
        $iso->{url} .= "/" if $iso->{url} !~ m{/$};
        $iso->{url} .= $iso->{file_re};
1104
        $iso->{filename} = '';
1105
1106
1107
1108
1109
        return;
    }
    confess "Error: Missing field file_re for ".$iso->{name};
}

1110
1111
sub _check_md5 {
    my ($file, $md5 ) =@_;
Francesc Guasch's avatar
Francesc Guasch committed
1112
    return if !$md5;
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128

    my  $ctx = Digest::MD5->new;
    open my $in,'<',$file or die "$! $file";
    $ctx->addfile($in);

    my $digest = $ctx->hexdigest;

    return 1 if $digest eq $md5;

    warn "$file MD5 fails\n"
        ." got  : $digest\n"
        ."expecting: $md5\n"
        ;
    return 0;
}

1129
sub _check_sha256($file,$sha) {
Francesc Guasch's avatar
Francesc Guasch committed
1130
    return if !$sha;
1131
    confess "Wrong SHA256 '$sha'" if $sha !~ /[a-f0-9]{9}/;
Francesc Guasch's avatar
Francesc Guasch committed
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149

    my @cmd = ('sha256sum',$file);
    my ($in, $out, $err);
    run3(\@cmd,\$in, \$out, \$err);
    die "$err ".join(@cmd)  if $err;

    my ($digest) =  $out =~ m{([0-9a-f]+)};

    return 1 if $digest eq $sha;

    warn "$file SHA256 fails\n"
        ." got  : $digest\n"
        ."expecting: $sha\n"
        ;
    return 0;
}


1150
1151
1152
1153
1154
sub _check_signature($file, $type, $expected) {
    confess "ERROR: Wrong signature '$expected'"
        if $expected !~ /^[0-9a-f]{7}/;
    return _check_md5($file,$expected) if $type =~ /md5/i;
    return _check_sha256($file,$expected) if $type =~ /sha256/i;
Francesc Guasch's avatar
Francesc Guasch committed
1155
1156
1157
    die "Unknown signature type $type";
}

1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
sub _download_file_external($self, $url, $device, $verbose=1) {
    $url .= "/" if $url !~ m{/$} && $url !~ m{.*/([^/]+\.[^/]+)$};
    if ( $url =~ m{/$} ) {
        my ($filename) = $device =~ m{.*/(.*)};
        $url = "$url$filename";
    }
    if ($url =~ m{[^*]}) {
        my @found = $self->_search_url_file($url);
        confess "No match for $url" if !scalar @found;
        $url = $found[-1];
    }
Francesc Guasch's avatar
Francesc Guasch committed
1169
    confess "ERROR: wget missing"   if !$WGET;
1170
    my @cmd = ($WGET,'-nv',$url,'-O',$device);
1171
    my ($in,$out,$err) = @_;
1172
    warn join(" ",@cmd)."\n"    if $verbose;
1173
    run3(\@cmd,\$in,\$out,\$err);
1174
1175
    warn "out=$out" if $out && $verbose;
    warn "err=$err" if $err && $verbose;
1176
1177
1178
    print $out if $out;
    chmod 0755,$device or die "$! chmod 0755 $device"
        if -e $device;
1179

1180
    return $url if !$err;
1181
1182
1183
1184
1185
1186

    if ($err && $err =~ m{\[(\d+)/(\d+)\]}) {
        if ( $1 != $2 ) {
            unlink $device or die "$! $device" if -e $device;
            die "ERROR: Expecting $1 , got $2.\n$err"
        }
1187
        return $url;
1188
    }
1189
    unlink $device or die "$! $device" if -e $device;
1190
    die $err;
1191
1192
1193
1194
1195
}

sub _search_iso {
    my $self = shift;
    my $id_iso = shift or croak "Missing id_iso";
1196
    my $file_iso = shift;
1197
1198
1199
1200
1201

    my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM iso_images WHERE id = ?");
    $sth->execute($id_iso);
    my $row = $sth->fetchrow_hashref;
    die "Missing iso_image id=$id_iso" if !keys %$row;
Francesc Guasch's avatar
Francesc Guasch committed
1202

1203
1204
    return $row if $file_iso;

1205
    $self->_fetch_filename($row);#    if $row->{file_re};
Francesc Guasch's avatar
Francesc Guasch committed
1206
1207
1208
1209
    if ($VERIFY_ISO) {
        $self->_fetch_md5($row)         if !$row->{md5} && $row->{md5_url};
        $self->_fetch_sha256($row)         if !$row->{sha256} && $row->{sha256_url};
    }
Francesc Guasch's avatar
Francesc Guasch committed
1210

1211
    if ( !$row->{device} && $row->{filename}) {
1212
1213
1214
1215
1216
1217
1218
1219
        if (my $volume = $self->search_volume($row->{filename})) {
            $row->{device} = $volume->get_path;
            my $sth = $$CONNECTOR->dbh->prepare(
                "UPDATE iso_images SET device=? WHERE id=?"
            );
            $sth->execute($volume->get_path, $row->{id});
        }
    }
1220
1221
1222
    return $row;
}

Francesc Guasch's avatar
Francesc Guasch committed
1223
sub _download($self, $url) {
Francesc Guasch's avatar
Francesc Guasch committed
1224
    $url =~ s{(http://.*)//(.*)}{$1/$2};
1225
    if ($url =~ m{[^*]}) {
1226
1227
1228
1229
        my @found = $self->_search_url_file($url);
        confess "No match for $url" if !scalar @found;
        $url = $found[-1];
    }
1230

1231
    my $cache;
Francesc Guasch's avatar
Francesc Guasch committed
1232
    $cache = $self->_cache_get($url) if $CACHE_DOWNLOAD;# && $url !~ m{^http.?://localhost};
1233
1234
    return $cache if $cache;

1235
    my $ua = $self->_web_user_agent();
1236
1237
    my $res;
    for ( 1 .. 10 ) {
1238
        eval { $res = $ua->get($url)->res};
1239
1240
1241
        last if $res;
    }
    die $@ if $@;
1242
1243
    confess "ERROR ".$res->code." ".$res->message." : $url"
        unless $res->code == 200 || $res->code == 301;
1244

1245
    return $self->_cache_store($url,$res->body);
1246
1247
}

1248
sub _match_url($self,$url) {
1249
1250
    return $url if $url !~ m{\*};

1251
1252
    my ($url1, $match,$url2) = $url =~ m{(.*/)([^/]*\*[^/]*)/?(.*)};
    $url2 = '' if !$url2;
Francesc Guasch's avatar
Francesc Guasch committed
1253

1254
    confess "No url1 from $url" if !defined $url1;
1255
1256
    my $ua = Mojo::UserAgent->new;
    my $res = $ua->get(($url1 or '/'))->res;
1257
    confess "ERROR ".$res->code." ".$res->message." : $url1"
1258
        unless $res->code == 200 || $res->code == 301;
1259

1260
    my @found;
1261
1262
    my $links = $res->dom->find('a')->map( attr => 'href');
    for my $link (@$links) {
1263
        next if !defined $link || $link !~ qr($match);
1264
1265
        my $new_url = "$url1$link$url2";
        push @found,($self->_match_url($new_url));
1266
    }
1267
    return @found;
1268
1269
}

Francesc Guasch's avatar
Francesc Guasch committed
1270
sub _cache_get($self, $url) {
1271
1272
1273
    my $file = _cache_filename($url);

    my @stat = stat($file)  or return;
1274
    return if time-$stat[9] > 300;
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
    open my $in ,'<' , $file or return;
    return join("",<$in>);
}

sub _cache_store {
    my $self = shift;
    my $url = shift;
    my $content = shift;

    my $file = _cache_filename($url);
    open my $out ,'>' , $file or die "$! $file";
    print $out $content;
    close $out;
    return $content;

}

Francesc Guasch's avatar
Francesc Guasch committed
1292
1293
sub _cache_filename($url) {
    confess "Undefined url" if !$url;
1294
1295

    my $file = $url;
Francesc Guasch's avatar
Francesc Guasch committed
1296

1297
    $file =~ tr{/:}{_-};
Francesc Guasch's avatar
Francesc Guasch committed
1298
1299
    $file =~ tr{a-zA-Z0-9_-}{_}c;
    $file =~ s/__+/_/g;
1300

Francesc Guasch's avatar
Francesc Guasch committed
1301
    my ($user) = getpwuid($>);
Francesc Guasch's avatar
Francesc Guasch committed
1302
    my $dir = "/var/tmp/$user/ravada_cache/";
1303
1304
    make_path($dir)    if ! -e $dir;
    return "$dir/$file";
Francesc Guasch's avatar