KVM.pm 54.8 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
55
56
57
58
59
60

with 'Ravada::VM';

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

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

has type => (
    isa => 'Str'
    ,is => 'ro'
    ,default => 'qemu'
);

#########################################################################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
65
66
67
68
69
70
71
72
73
74

our $XML = XML::LibXML->new();

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

our $CONNECTOR = \$Ravada::CONNECTOR;

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

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

our %_CREATED_DEFAULT_STORAGE = ();
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
##########################################################################


sub _connect {
    my $self = shift;

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

    if ($self->host eq 'localhost') {
        $vm = Sys::Virt->new( address => $self->type.":///system" , readonly => $self->readonly);
    } else {
        $vm = Sys::Virt->new( address => $self->type."+ssh"."://".$self->host."/system"
                              ,readonly => $self->mode
                          );
    }
98
99
100
101
    if ( ! $vm->list_storage_pools ) {
	warn "WARNING: No storage pools creating default\n";
    	$self->_create_default_pool($vm);
    }
102
    $self->_check_networks($vm);
103
104
105
    return $vm;
}

106
107
108
109
110
111
112
113
114
115
116
117
118
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);
    }
}

119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
=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;
    return if $self->vm;

    $self->vm($self->_connect);
#    $self->storage_pool($self->_load_storage_pool);
}

sub _load_storage_pool {
    my $self = shift;

    my $vm_pool;
    my $available;

151
152
153
154
155
    if (defined $self->default_storage_pool_name) {
        return( $self->vm->get_storage_pool_by_name($self->default_storage_pool_name)
            or confess "ERROR: Unknown storage pool: ".$self->default_storage_pool_name);
    }

156
157
158
    for my $pool ($self->vm->list_storage_pools) {
        my $info = $pool->get_info();
        next if defined $available
159
                && $info->{available} <= $available;
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

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

    }
    die "I can't find /pool/target/path in the storage pools xml\n"
        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();
}

189
190
191
192
193
=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
194
195
Returns the volume as a Sys::Virt::StorageGol. If called in array context returns a
list of all the volumes.
196
197
198
199
200
201
202

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

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

=cut

Francesc Guasch's avatar
Francesc Guasch committed
203
sub search_volume($self,$file,$refresh=0) {
204
    confess "ERROR: undefined file" if !defined $file;
Francesc Guasch's avatar
Francesc Guasch committed
205
206
    return $self->search_volume_re(qr(^$file$),$refresh);
}
207

Francesc Guasch's avatar
Francesc Guasch committed
208
=head2 search_volume_path
209

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

Francesc Guasch's avatar
Francesc Guasch committed
212
213
214
215
216
217
218
219
220
221
222
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
223

Francesc Guasch's avatar
Francesc Guasch committed
224
225
226
sub search_volume_path {
    my $self = shift;
    my @volume = $self->search_volume(@_);
Francesc Guasch's avatar
Francesc Guasch committed
227

Francesc Guasch's avatar
Francesc Guasch committed
228
229
230
231
232
233
    my @vol2 = map { $_->get_path() if ref($_) } @volume;

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

Francesc Guasch's avatar
Francesc Guasch committed
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
=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
252

Francesc Guasch's avatar
Francesc Guasch committed
253
    $self->_connect();
254
255
    $self->_refresh_storage_pools()    if $refresh;

Francesc Guasch's avatar
Francesc Guasch committed
256
257
258
    my @volume;
    for my $pool ($self->vm->list_storage_pools) {
        for my $vol ( $pool->list_all_volumes()) {
Francesc Guasch's avatar
Francesc Guasch committed
259
260
            my ($file) = $vol->get_path =~ m{.*/(.*)};
            next if $file !~ $pattern;
Francesc Guasch's avatar
Francesc Guasch committed
261

Francesc Guasch's avatar
Francesc Guasch committed
262
263
            return $vol if !wantarray;
            push @volume,($vol);
Francesc Guasch's avatar
Francesc Guasch committed
264
265
        }
    }
Francesc Guasch's avatar
Francesc Guasch committed
266
267
268
269
270
271
272
    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
273
274
275
    return @volume;
}

276
277
sub _refresh_storage_pools($self) {
    for my $pool ($self->vm->list_storage_pools) {
278
279
280
281
282
283
        for (;;) {
            eval { $pool->refresh() };
            last if !$@;
            warn $@ if $@ !~ /pool .* has asynchronous jobs running/;
            sleep 1;
        }
284
285
286
    }
}

287
288
289
290
291
292
293
294
295
296
=head2 refresh_storage

Refreshes all the storage pools

=cut

sub refresh_storage($self) {
    $self->_refresh_storage_pools();
}

Francesc Guasch's avatar
Francesc Guasch committed
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
=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;

}

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
=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;
}

342
sub _storage_path($self, $storage) {
Francesc Guasch's avatar
Francesc Guasch committed
343
344
345
    if (!ref($storage)) {
        $storage = $self->vm->get_storage_pool_by_name($storage);
    }
346
347
348
349
350
351
352
353
354
355
    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;

}

356
357
sub _create_default_pool {
    my $self = shift;
358
359
    my $vm = shift;
    $vm = $self->vm if !$vm;
360
361
362

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

363
    my $dir = "/var/lib/libvirt/images";
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
    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
385
386
387
388
389
390
391
    my $pool;
    eval {
        $pool = $vm->define_storage_pool($xml);
        $pool->create();
        $pool->set_autostart(1);
    };
    warn $@ if $@;
392
393
394
395
396
397
398
399
400
401

}

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

402
403
404
405
406
407
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);

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
=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

Francesc Guasch's avatar
Francesc Guasch committed
440
sub search_domain($self, $name, $force=undef) {
441
442
443

    $self->connect();

Francesc Guasch's avatar
Francesc Guasch committed
444
445
    my $dom;
    eval { $dom = $self->vm->get_domain_by_name($name); };
Francesc Guasch's avatar
Francesc Guasch committed
446
    confess $@ if $@ && $@ !~ /error code: 42,/;
Francesc Guasch's avatar
Francesc Guasch committed
447
448
449
450
451
    if (!$dom) {
        return if !$force;
        return if !$self->_domain_in_db($name);
    }
    return if !$force && !$self->_domain_in_db($name);
452
453
454

        my $domain;

Francesc Guasch's avatar
Francesc Guasch committed
455
        my @domain = ( );
Francesc Guasch's avatar
Francesc Guasch committed
456
457
        push @domain, ( domain => $dom ) if $dom;
        push @domain, ( id_owner => $Ravada::USER_DAEMON->id)
Francesc Guasch's avatar
Francesc Guasch committed
458
            if $force && !$self->_domain_in_db($name);
459
460
        eval {
            $domain = Ravada::Domain::KVM->new(
Francesc Guasch's avatar
Francesc Guasch committed
461
462
                @domain
                ,name => $name
463
464
465
466
467
468
                ,readonly => $self->readonly
                ,_vm => $self
            );
        };
        warn $@ if $@;
        if ($domain) {
Francesc Guasch's avatar
Francesc Guasch committed
469
            $domain->xml_description()  if $dom && $domain->is_known();
470
471
            return $domain;
        }
Francesc Guasch's avatar
Francesc Guasch committed
472

473
474
475
476
477
478
479
480
481
482
483
    return;
}

=head2 list_domains

Returns a list of the created domains

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

=cut

Francesc Guasch's avatar
Francesc Guasch committed
484
485
486
487
488
sub list_domains($self, %args) {

    my $active = delete $args{active} or 0;

    confess "ERROR: Unknown arguments ".Dumper(\%args)  if keys %args;
489

Francesc Guasch's avatar
Francesc Guasch committed
490
491
    my $sth = $$CONNECTOR->dbh->prepare("SELECT id, name FROM domains WHERE vm = ?");
    $sth->execute('KVM');
492
    my @list;
Francesc Guasch's avatar
Francesc Guasch committed
493
494
495
496
    while ( my ($id) = $sth->fetchrow) {
        my $domain = Ravada::Domain->open($id);
        next if !$domain || $active && !$domain->is_active;
        push @list,($domain);
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
    }
    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 = @_;

515
516
517
518
519
520
521
522
523
524
    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;
525
526
527
528
529
530
531
532
533

    confess "Invalid size"          if defined $size && ( $size == 0 || $size !~ /^\d+$/);
    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;

534
    open my $fh,'<', $file_xml or confess "$! $file_xml";
535
536
537
538
539

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

540
541
542
543
544
545
546
547
548
    my $storage_pool = $self->storage_pool();

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

549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
    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) {
        confess "Size '$capacity' too small" if $capacity< 1024*512;
        $doc->findnodes('/volume/allocation/text()')->[0]->setData($allocation);
        $doc->findnodes('/volume/capacity/text()')->[0]->setData($capacity);
    }
    my $vol = $self->storage_pool->create_volume($doc->toString);
    die "volume $img_file does not exists after creating volume "
            .$doc->toString()
            if ! -e $img_file;

    return $img_file;

}

sub _volume_path {
    my $self = shift;

    my %args = @_;
573
574
575
576
577
578
    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);
579
    my $suffix = ".img";
580
    $suffix = ".SWAP.img"   if $swap;
581
582
    $filename .= "-$target" if $target;
    my (undef, $img_file) = tempfile($filename."-XXXX"
583
584
585
586
587
588
589
590
591
592
        ,DIR => $dir_img
        ,OPEN => 0
        ,SUFFIX => $suffix
    );
    return $img_file;
}

sub _domain_create_from_iso {
    my $self = shift;
    my %args = @_;
593
    my %args2 = %args;
594
    for (qw(id_iso id_owner name)) {
595
        delete $args2{$_};
596
597
598
        croak "argument $_ required"
            if !$args{$_};
    }
599
    my $remove_cpu = delete $args2{remove_cpu};
joelalju's avatar
joelalju committed
600
    for (qw(disk swap active request vm memory iso_file id_template)) {
601
602
        delete $args2{$_};
    }
603
604

    my $iso_file = delete $args{iso_file};
605
606
    confess "Unknown parameters : ".join(" , ",sort keys %args2)
        if keys %args2;
607
608
609
610
611

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

    my $vm = $self->vm;
612
    my $iso = $self->_search_iso($args{id_iso} , $iso_file);
613
614
615

    die "ERROR: Empty field 'xml_volume' in iso_image ".Dumper($iso)
        if !$iso->{xml_volume};
616
617
        
    my $device_cdrom;
618
619

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

622
623
624
625
    if ($iso_file) {
        if ( $iso_file ne "<NONE>") {
            $device_cdrom = $iso_file;
        }
626
627
    }
    else {
joelalju's avatar
joelalju committed
628
      $device_cdrom = $self->_iso_name($iso, $args{request});
629
630
    }
    
joelalju's avatar
joelalju committed
631
632
633
634
635
636
637
    #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};
    #}
    
638
639
    my $disk_size;
    $disk_size = $args{disk} if $args{disk};
640
641
642

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

643
644
    my $device_disk = $self->create_volume(
          name => $args{name}
645
         , xml => $file_xml
646
        , size => $disk_size
647
        ,target => 'vda'
648
649
650
651
    );

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

652
653
654
655
656
    if ($device_cdrom) {
        _xml_modify_cdrom($xml, $device_cdrom);
    } else {
        _xml_remove_cdrom($xml);
    }
657
    _xml_remove_cpu($xml)                     if $remove_cpu;
658
659
660
661
    _xml_modify_disk($xml, [$device_disk])    if $device_disk;
    $self->_xml_modify_usb($xml);
    _xml_modify_video($xml);

662
663
    my ($domain, $spice_password)
        = $self->_domain_create_common($xml,%args);
Francesc Guasch's avatar
Francesc Guasch committed
664
665
666
    $domain->_insert_db(name=> $args{name}, id_owner => $args{id_owner}
        , id_vm => $self->id
    );
Francesc Guasch's avatar
Francesc Guasch committed
667

668
669
    $domain->_set_spice_password($spice_password)
        if $spice_password;
Francesc Guasch's avatar
Francesc Guasch committed
670
    $domain->xml_description();
671
672
673
674
675
676
677
678
679

    return $domain;
}

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

680
    my $id_owner = delete $args{id_owner} or confess "ERROR: The id_owner is mandatory";
681
    my $is_volatile = delete $args{is_volatile};
682
    my $remote_ip = delete $args{remote_ip};
683
684
685
    my $user = Ravada::Auth::SQL->search_by_id($id_owner)
        or confess "ERROR: User id $id_owner doesn't exist";

686
    my $spice_password = Ravada::Utils::random_name(4);
687
688
689
690
    if ($remote_ip) {
        my $network = Ravada::Network->new(address => $remote_ip);
        $spice_password = undef if !$network->requires_password;
    }
691
692
693
694
    $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);
    $self->_xml_modify_uuid($xml);
695
    $self->_xml_modify_spice_port($xml, $spice_password);
696
    $self->_fix_pci_slots($xml);
JanFontanet's avatar
JanFontanet committed
697
    $self->_xml_add_guest_agent($xml);
698
    $self->_xml_clean_machine_type($xml);
699
    $self->_xml_add_sysinfo_entry($xml, hostname => $args{name});
700
701
702
703

    my $dom;

    eval {
704
        if ($user->is_temporary || $is_volatile ) {
705
706
707
708
709
            $dom = $self->vm->create_domain($xml->toString());
        } else {
            $dom = $self->vm->define_domain($xml->toString());
            $dom->create if $args{active};
        }
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
    };
    if ($@) {
        my $out;
		warn $@;
        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;
        die $@ if !$dom;
    }

    my $domain = Ravada::Domain::KVM->new(
              _vm => $self
         , domain => $dom
        , storage => $self->storage_pool
Francesc Guasch's avatar
Francesc Guasch committed
728
       , id_owner => $id_owner
729
    );
730
    return ($domain, $spice_password);
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
}

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
749
750
    my $clone_pool = $self->clone_storage_pool();
    $dir_img = $self->_storage_path($clone_pool) if $clone_pool;
751
752
753

    my @files_out;

754
755
    for my $file_data ( $base->list_files_base_target ) {
        my ($file_base,$target) = @$file_data;
756
757
        my $ext = ".qcow2";
        $ext = ".SWAP.qcow2" if $file_base =~ /\.SWAP\.ro\.\w+$/;
758
759
        my $file_out = "$dir_img/$name-".($target or _random_name(2))
            ."-"._random_name(2).$ext;
760

761
762
763
764
765
766
767
768
769
770
771
        $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) {

772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
        my @cmd = ('qemu-img','create'
                ,'-f','qcow2'
                ,"-b", $file_base
                ,$file_out
        );

        my ($in, $out, $err);
        run3(\@cmd,\$in,\$out,\$err);

        if (! -e $file_out) {
            warn "ERROR: Output file $file_out not created at ".join(" ",@cmd)."\n$err\n$out\n";
            exit;
        }

}

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

836
    my $base = $args{base};
837
838
839
840
841
842
843

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

844
    my $xml = XML::LibXML->load_xml(string => $base->get_xml_base());
845
846
847
848
849
850
851
852
853
854


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

855
    my ($domain, $spice_password)
856
        = $self->_domain_create_common($xml,%args, is_volatile => $base->volatile_clones);
Francesc Guasch's avatar
Francesc Guasch committed
857
858
859
    $domain->_insert_db(name=> $args{name}, id_base => $base->id, id_owner => $args{id_owner}
        , id_vm => $self->id
    );
860
    $domain->_set_spice_password($spice_password);
Francesc Guasch's avatar
Francesc Guasch committed
861
    $domain->xml_description();
862
863
864
865
866
867
868
869
870
871
872
873
874
875
    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')
876
            && $dev->getAttribute('type') =~ /^(ide)$/i;
877
878
879
880
881

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

        for my $child ($dev->findnodes('address')) {
            my $bus = $child->getAttribute('bus');
882
883
884
885
886
887
            my $slot = ($child->getAttribute('slot') or '');
            my $function = ($child->getAttribute('function') or '');
            my $multifunction = $child->getAttribute('multifunction');

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

888
            next if !defined $slot;
889
890
891
892
893

            if (!$dupe{$index} || ($multifunction && $multifunction eq 'on') ) {
                $dupe{$index} = $dev->toString();
                next;
            }
894
895
896

            my $new_slot = $slot;
            for (;;) {
897
                last if !$dupe{"$bus/$new_slot/$function"};
898
899
900
901
902
                my ($n) = $new_slot =~ m{x(\d+)};
                $n++;
                $n= "0$n" if length($n)<2;
                $new_slot="0x$n";
            }
903
            $dupe{"$bus/$new_slot/$function"}++;
904
905
906
907
908
909
            $child->setAttribute(slot => $new_slot);
        }
    }

}

910
sub _iso_name($self, $iso, $req, $verbose=1) {
911

912
    my $iso_name;
913
914
915
916
917
918
    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;
    }
919
920

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

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

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

927
    my $downloaded = 0;
928
929
930
931
932
    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;
933
        _fill_url($iso);
Francesc Guasch's avatar
Francesc Guasch committed
934
        my $url = $self->_download_file_external($iso->{url}, $device, $verbose);
935
        $self->_refresh_storage_pools();
936
937
        die "Download failed, file $device missing.\n"
            if ! -e $device;
Francesc Guasch's avatar
Francesc Guasch committed
938
939
940

        my $verified = 0;
        for my $check ( qw(md5 sha256)) {
Francesc Guasch's avatar
Francesc Guasch committed
941
942
943
944
945
            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
946
947
948
949
950
            next if !$iso->{$check};

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

956
        $req->status("done","File $iso->{filename} downloaded") if $req;
957
958
959
        $downloaded = 1;
    }
    if ($downloaded || !$iso->{device} ) {
960
        my $sth = $$CONNECTOR->dbh->prepare(
961
                "UPDATE iso_images SET device=? WHERE id=?"
962
963
964
        );
        $sth->execute($device,$iso->{id});
    }
965
    $self->_refresh_storage_pools();
966
967
968
    return $device;
}

969
970
971
972
973
974
975
976
977
978
sub _fill_url($iso) {
    return if $iso->{url} =~ m{.*/[^/]+\.[^/]+$};
    if ($iso->{file_re}) {
        $iso->{url} .= "/" if $iso->{url} !~ m{/$};
        $iso->{url} .= $iso->{file_re};
        return;
    }
    confess "Error: Missing field file_re for ".$iso->{name};
}

979
980
sub _check_md5 {
    my ($file, $md5 ) =@_;
Francesc Guasch's avatar
Francesc Guasch committed
981
    return if !$md5;
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997

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

998
sub _check_sha256($file,$sha) {
Francesc Guasch's avatar
Francesc Guasch committed
999
    return if !$sha;
1000
    confess "Wrong SHA256 '$sha'" if $sha !~ /[a-f0-9]{9}/;
For faster browsing, not all history is shown. View entire blame