KVM.pm 12.7 KB
Newer Older
1
2
3
4
5
package Ravada::Domain::KVM;

use warnings;
use strict;

6
use Carp qw(cluck confess croak);
7
use Data::Dumper;
8
use IPC::Run3 qw(run3);
9
use Moose;
10
use Sys::Virt::Stream;
11
use XML::LibXML;
12
13
14

with 'Ravada::Domain';

15
16
17
18
19
20
21
22
23
24
25
26
has 'domain' => (
      is => 'ro'
    ,isa => 'Sys::Virt::Domain'
    ,required => 1
);

has 'storage' => (
    is => 'ro'
    ,isa => 'Sys::Virt::StoragePool'
    ,required => 1
);

27
28
29
has '_vm' => (
    is => 'ro'
    ,isa => 'Sys::Virt'
30
    ,required => 0
31
32
);

33
34
##################################################
#
Francesc Guasch's avatar
Francesc Guasch committed
35
our $TIMEOUT_SHUTDOWN = 60;
36
our $OUT;
Francesc Guasch's avatar
Francesc Guasch committed
37
38

##################################################
39
40


41
42
43
44
45
46
47
48
49
50
51
52
53
=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;
54
    my $seconds = (shift or $self->timeout_shutdown);
55
56
57
58
59
60
61
62
63
64
    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";

}

Francesc Guasch's avatar
Francesc Guasch committed
65
=head2 list_disks
66
67
68
69
70
71
72

Returns a list of the disks used by the virtual machine. CDRoms are not included

  my@ disks = $domain->list_disks();

=cut

Francesc Guasch's avatar
Francesc Guasch committed
73
sub list_disks {
74
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
75
    my @disks = ();
76
77
78
79
80
81
82
83
84

    my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description);

    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');
Francesc Guasch's avatar
Francesc Guasch committed
85
                push @disks,($file);
86
87
88
            }
        }
    }
Francesc Guasch's avatar
Francesc Guasch committed
89
90
91
    return @disks;
}

Francesc Guasch's avatar
Francesc Guasch committed
92
93
94
95
96
97
=head2 remove_disks

Remove the volume files of the domain

=cut

Francesc Guasch's avatar
Francesc Guasch committed
98
99
100
101
sub remove_disks {
    my $self = shift;

    my $removed = 0;
102
103
104
105
106

    my $id;
    eval { $id = $self->id };
    return if $@ && $@ =~ /No DB info/i;
    die $@ if $@;
Francesc Guasch's avatar
Francesc Guasch committed
107
108
    for my $file ($self->list_disks) {
        if (! -e $file ) {
Francesc Guasch's avatar
Francesc Guasch committed
109
110
            warn "WARNING: $file already removed for ".$self->domain->get_name."\n"
                if $0 !~ /.t$/;
Francesc Guasch's avatar
Francesc Guasch committed
111
112
            next;
        }
Francesc Guasch's avatar
Francesc Guasch committed
113
        $self->_vol_remove($file);
Francesc Guasch's avatar
Francesc Guasch committed
114
115
116
117
118
119
120
        if ( -e $file ) {
            unlink $file or die "$! $file";
        }
        $removed++;

    }

121
122
123
124
125
    warn "WARNING: No disk files removed for ".$self->domain->get_name."\n"
        if !$removed;

}

Francesc Guasch's avatar
Francesc Guasch committed
126
sub _vol_remove {
127
128
    my $self = shift;
    my $file = shift;
129
130
    my $warning = shift;

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

133
134
    my $vol;
    eval { $vol = $self->storage->get_volume_by_name($name) };
135
    if (!$vol) {
136
#        cluck "WARNING: I can't find volume $name" if !$warning;
137
138
139
        return;
    }
    $vol->delete();
140
    return 1;
141
142
}

Francesc Guasch's avatar
Francesc Guasch committed
143
=head2 remove
144
145
146
147
148

Removes this domain. It removes also the disk drives and base images.

=cut

149
150
151
152
153
sub remove {
    my $self = shift;
    $self->domain->shutdown  if $self->domain->is_active();

    $self->_wait_down();
154

155
156
    $self->domain->destroy   if $self->domain->is_active();

157
158
    $self->remove_disks();
#    warn "WARNING: Problem removing disks for ".$self->name." : $@" if $@ && $0 !~ /\.t$/;
159

160
161
    $self->_remove_file_image();
#    warn "WARNING: Problem removing file image for ".$self->name." : $@" if $@ && $0 !~ /\.t$/;
162

Francesc Guasch's avatar
Francesc Guasch committed
163
164
#    warn "WARNING: Problem removing ".$self->file_base_img." for ".$self->name
#            ." , I will try again later : $@" if $@;
165
166

    $self->domain->undefine();
167
168
}

169

170
sub _remove_file_image {
171
    my $self = shift;
172
    for my $file ( $self->list_files_base ) {
173

174
        next if !$file || ! -e $file;
175

176
177
178
        chmod 0770, $file or die "$! chmodding $file";
        chown $<,$(,$file    or die "$! chowning $file";
        eval { $self->_vol_remove($file,1) };
179

180
181
182
183
184
185
186
187
        if ( -e $file ) {
            eval { 
                unlink $file or die "$! $file" ;
                $self->storage->refresh();
            };
            warn $@ if $@;
        }
        next if ! -e $file;
Francesc Guasch's avatar
Francesc Guasch committed
188
        warn $@ if $@;
189
    }
190
191
}

192
193
194
195
196
sub _disk_device {
    my $self = shift;
    my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description) 
        or die "ERROR: $!\n";

197
    my @img;
198
199
200
201
202
203
204
205
206
207
    my $list_disks = '';

    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';

        $list_disks .= $disk->toString();

        for my $child ($disk->childNodes) {
            if ($child->nodeName eq 'source') {
#                die $child->toString();
208
                push @img , ($child->getAttribute('file'));
209
210
211
            }
        }
    }
212
    if (!scalar @img) {
Francesc Guasch's avatar
Francesc Guasch committed
213
214
215
216
        my (@devices) = $doc->findnodes('/domain/devices/disk');
        die "I can't find disk device FROM "
            .join("\n",map { $_->toString() } @devices);
    }
217
    return @img;
218
219
220

}

Francesc Guasch's avatar
Francesc Guasch committed
221
222
223
224
225
226
227
228
229
230
231
232
233
=head2 disk_device

Returns the file name of the disk of the domain.

  my $file_name = $domain->disk_device();

=cut

sub disk_device {
    my $self = shift;
    return $self->_disk_device();
}

234
235
236
sub _create_qcow_base {
    my $self = shift;

237
238
    my @qcow_img;

239
    my $base_name = $self->name;
240
    for  my $base_img ( $self->list_volumes()) {
241

242
        my $qcow_img = $base_img;
243
    
244
245
246
247
248
        $qcow_img =~ s{\.\w+$}{\.ro.qcow2};

        push @qcow_img,($qcow_img);

        my @cmd = ('qemu-img','convert',
249
250
                '-O','qcow2', $base_img
                ,$qcow_img
251
        );
252

253
254
255
256
        my ($in, $out, $err);
        run3(\@cmd,\$in,\$out,\$err);
        warn $out  if $out;
        warn $err   if $err;
257

258
259
260
261
        if (! -e $qcow_img) {
            warn "ERROR: Output file $qcow_img not created at ".join(" ",@cmd)."\n";
            exit;
        }
262

263
264
265
266
        chmod 0555,$qcow_img;
        $self->_prepare_base_db($qcow_img);
    }
    return @qcow_img;
267
268
269

}

Francesc Guasch's avatar
Francesc Guasch committed
270
=head2 prepare_base
271
272
273
274
275
276

Prepares a base virtual machine with this domain disk

=cut


277
278
279
sub prepare_base {
    my $self = shift;

280
    return $self->_create_qcow_base();
281
}
282
283
284
285
286
287

=head2 display

Returns the display URI

=cut
288

289
290
291
292
293
294
295
296
297
298
299
sub display {
    my $self = shift;

    my $xml = XML::LibXML->load_xml(string => $self->domain->get_xml_description);
    my ($graph) = $xml->findnodes('/domain/devices/graphics') 
        or die "ERROR: I can't find graphic";

    my ($type) = $graph->getAttribute('type');
    my ($port) = $graph->getAttribute('port');
    my ($address) = $graph->getAttribute('listen');

Francesc Guasch's avatar
Francesc Guasch committed
300
301
302
    die "Unable to get port for domain ".$self->name
        if !$port;

303
304
    return "$type://$address:$port";
}
305

Francesc Guasch's avatar
Francesc Guasch committed
306
307
308
309
310
311
312
313
=head2 is_active

Returns whether the domain is running or not

=cut

sub is_active {
    my $self = shift;
314
    return ( $self->domain->is_active or 0);
Francesc Guasch's avatar
Francesc Guasch committed
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
}

=head2 start

Starts the domain

=cut

sub start {
    my $self = shift;
    $self->domain->create();
}

=head2 shutdown

Stops the domain

=cut

sub shutdown {
    my $self = shift;

    my %args = @_;
    my $req = $args{req};
    my $timeout = ($args{timeout} or $TIMEOUT_SHUTDOWN);

Francesc Guasch's avatar
Francesc Guasch committed
341
    if (!$self->is_active && !$args{force}) {
Francesc Guasch's avatar
Francesc Guasch committed
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
        $req->status("done")                if $req;
        $req->error("Domain already down")  if $req;
        return;
    }
    $self->domain->shutdown();
    $req->status("Shutting down") if $req;

    for (0 .. $timeout) {
        my $msg = "Domain ".$self->name." shutting down ($_ / $timeout)\n";
        $req->error($msg)  if $req;

        last if !$self->is_active;
        sleep 1;
    }
    if ($self->is_active) {
        my $msg = "Domaing wouldn't shut down, destroying\n";
        $req->error($msg)  if $req;
        $self->domain->destroy();
    }
    $req->status("done")        if $req;
}

Francesc Guasch's avatar
Francesc Guasch committed
364
365
366
367
368
369
370
371
=head2 shutdown_now

Shuts down uncleanly the domain

=cut

sub shutdown_now {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
372
373
    my $user = shift;
    return $self->shutdown(timeout => 1, user => $user);
Francesc Guasch's avatar
Francesc Guasch committed
374
375
}

Francesc Guasch's avatar
Francesc Guasch committed
376
377
378
379
380
381
382
383

=head2 pause

Pauses the domain

=cut

sub pause {
Francesc Guasch's avatar
Francesc Guasch committed
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
    my $self = shift;
    return $self->domain->suspend();
}

=head2 resume

Resumes a paused the domain

=cut

sub resume {
    my $self = shift;
    return $self->domain->resume();
}


=head2 is_paused

Returns if the domain is paused

=cut

sub is_paused {
    my $self = shift;
    my ($state, $reason) = $self->domain->get_state();

joansp's avatar
joansp committed
410
411
   

412
413
414
    return 0 if $state == 1;
    #TODO, find out which one of those id "1" and remove it from this list
    #
Francesc Guasch's avatar
Francesc Guasch committed
415
416
417
418
419
420
421
422
423
424
425
    return $state && 
        ($state == Sys::Virt::Domain::STATE_PAUSED_UNKNOWN 
        || $state == Sys::Virt::Domain::STATE_PAUSED_USER 
        || $state == Sys::Virt::Domain::STATE_PAUSED_DUMP
        || $state == Sys::Virt::Domain::STATE_PAUSED_FROM_SNAPSHOT
        || $state == Sys::Virt::Domain::STATE_PAUSED_IOERROR
        || $state == Sys::Virt::Domain::STATE_PAUSED_MIGRATION
        || $state == Sys::Virt::Domain::STATE_PAUSED_SAVE
        || $state == Sys::Virt::Domain::STATE_PAUSED_SHUTTING_DOWN
    );
    return 0;
Francesc Guasch's avatar
Francesc Guasch committed
426
427
}

428
429
430
431
432
433
434
435
436
=head2 add_volume

Adds a new volume to the domain

    $domain->add_volume($size);

=cut

sub add_volume {
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
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
    my $self = shift;
    my %args = @_;

    my %valid_arg = map { $_ => 1 } ( qw( name size path vm));

    for my $arg_name (keys %args) {
        confess "Unknown arg $arg_name"
            if !$valid_arg{$arg_name};
    }
    confess "Missing vm"    if !$args{vm};
    confess "Missing name " if !$args{name};

    my $path = $args{vm}->create_volume($args{name}, "etc/xml/trusty-volume.xml"
        ,($args{size} or undef));

# TODO check if <target dev="/dev/vda" bus='virtio'/> widhout dev works it out
# change dev=vd*  , slot=*
#
    my $target_dev = $self->_new_target_dev();
    my $pci_slot = $self->_new_pci_slot();
    
    my $xml_device =<<EOT;
    <disk type='file' device='disk'>
      <driver name='qemu' type='qcow2'/>
      <source file='$path'/>
      <backingStore/>
      <target bus='virtio' dev='$target_dev'/>
      <alias name='virtio-disk1'/>
      <address type='pci' domain='0x0000' bus='0x00' slot='$pci_slot' function='0x0'/>
    </disk>
EOT

    eval { $self->domain->attach_device($xml_device,Sys::Virt::Domain::DEVICE_MODIFY_CONFIG) };
    die $@."\n".$self->domain->get_xml_description if$@;
}

sub _new_target_dev {
    my $self = shift;

    my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description) 
        or die "ERROR: $!\n";

    my %target;

    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';


        for my $child ($disk->childNodes) {
            if ($child->nodeName eq 'target') {
#                die $child->toString();
                $target{ $child->getAttribute('dev') }++;
            }
        }
    }
    my ($dev) = keys %target;
    $dev =~ s/(.*).$/$1/;
    for ('b' .. 'z') {
        my $new = "$dev$_";
        return $new if !$target{$new};
    }
}

sub _new_pci_slot{
    my $self = shift;

    my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description) 
        or die "ERROR: $!\n";

    my %target;

    for my $name (qw(disk controller interface graphics sound video memballoon)) {
        for my $disk ($doc->findnodes("/domain/devices/$name")) {


            for my $child ($disk->childNodes) {
                if ($child->nodeName eq 'address') {
#                    die $child->toString();
                    $target{ $child->getAttribute('slot') }++
                        if $child->getAttribute('slot');
                }
            }
        }
    }
    for ( 1 .. 99) {
        $_ = "0$_" if length $_ < 2;
        my $new = '0x'.$_;
        return $new if !$target{$new};
    }
526
527
}

528
529
530
531
#sub BUILD {
#    warn "Builder KVM.pm";
#}

Francesc Guasch's avatar
KVM doc    
Francesc Guasch committed
532
533
534
535
536
537
538
539
540
=head2 list_volumes

Returns a list of the disk volumes. Each element of the list is a string with the filename.
For KVM it reads from the XML definition of the domain.

    my @volumes = $domain->list_volumes();

=cut

541
sub list_volumes {
542
543
    my $self = shift;
    return $self->disk_device();
544
545
}

546
547
548
549
550
551
552
553
=head2 screenshot

Takes a screenshot, it stores it in file.

=cut

sub screenshot {
    my $self = shift;
554
    my $file = (shift or $self->_file_screenshot);
555

556
    my $stream = $self->{_vm}->new_stream();
557
558

    my $mimetype = $self->domain->screenshot($stream,0);
559
560

    my $file_tmp = "$file.tmp";
561
    my $data;
562
    my $bytes = 0;
563
564
    open my $out, '>', $file_tmp or die "$! $file_tmp";
    while ( my $rv =$stream->recv($data,1024)) {
565
        $bytes += $rv;
566
        last if $rv<=0;
567
        print $out $data;
568
    }
569
    close $out;
570

571
572
    $self->_convert_png($file_tmp,$file);
    unlink $file_tmp or warn "$! removing $file_tmp";
573
574

    $stream->finish;
575
576

    return $bytes;
577
578
}

579
sub _file_screenshot {
580
581
582
583
    my $self = shift;
    my $doc = XML::LibXML->load_xml(string => $self->storage->get_xml_description);
    my ($path) = $doc->findnodes('/pool/target/path/text()');
    return "$path/".$self->name.".png";
584
585
}

586
=head2 can_screenshot
587

588
Returns if a screenshot of this domain can be taken.
589

590
591
592
593
594
=cut

sub can_screenshot {
    my $self = shift;
    return 1 if $self->_vm();
595
596
}

597
598
599
600
601
602
603
604
605
606
607
=head2 storage_refresh

Refreshes the internal storage. Used after removing files such as base images.

=cut

sub storage_refresh {
    my $self = shift;
    $self->storage->refresh();
}

608
1;