VM.pm 43.5 KB
Newer Older
1
2
3
4
use warnings;
use strict;

package Ravada::VM;
5

6
7
8
9
10
=head1 NAME

Ravada::VM - Virtual Managers library for Ravada

=cut
11

12
use Carp qw( carp confess croak cluck);
13
use Data::Dumper;
14
use File::Path qw(make_path);
15
use Hash::Util qw(lock_hash);
16
use IPC::Run3 qw(run3);
17
use JSON::XS;
18
19
20
use Socket qw( inet_aton inet_ntoa );
use Moose::Role;
use Net::DNS;
Francesc Guasch's avatar
Francesc Guasch committed
21
use Net::Ping;
Francesc Guasch's avatar
Francesc Guasch committed
22
use Net::SSH2 qw(LIBSSH2_FLAG_SIGPIPE);
23
use IO::Scalar;
24
25
26
27
use IO::Socket;
use IO::Interface;
use Net::Domain qw(hostfqdn);

28
29
use Ravada::Utils;

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

33
34
35
36
37
38
39
40
41
requires 'connect';

# global DB Connection

our $CONNECTOR = \$Ravada::CONNECTOR;
our $CONFIG = \$Ravada::CONFIG;

our $MIN_MEMORY_MB = 128 * 1024;

Francesc Guasch's avatar
Francesc Guasch committed
42
our $SSH_TIMEOUT = 20 * 1000;
43
44
our $CACHE_TIMEOUT = 60;
our $FIELD_TIMEOUT = '_data_timeout';
Francesc Guasch's avatar
Francesc Guasch committed
45

Francesc Guasch's avatar
Francesc Guasch committed
46
our %VM; # cache Virtual Manager Connection
47
our %SSH;
Francesc Guasch's avatar
Francesc Guasch committed
48
49
50
51

our $ARP = `which arp`;
chomp $ARP;

52
53
54
55
56
57
58
59
# domain
requires 'create_domain';
requires 'search_domain';

requires 'list_domains';

# storage volume
requires 'create_volume';
Francesc Guasch's avatar
Francesc Guasch committed
60
requires 'list_storage_pools';
61
62
63

requires 'connect';
requires 'disconnect';
64
requires 'import_domain';
65

66
requires 'is_alive';
67
68

requires 'free_memory';
Francesc Guasch's avatar
Francesc Guasch committed
69
requires 'free_disk';
Francesc Guasch's avatar
Francesc Guasch committed
70
71
72

requires '_fetch_dir_cert';

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
############################################################

has 'host' => (
          isa => 'Str'
         , is => 'ro',
    , default => 'localhost'
);

has 'default_dir_img' => (
      isa => 'String'
     , is => 'ro'
);

has 'readonly' => (
    isa => 'Str'
    , is => 'ro'
    ,default => 0
);
91

Francesc Guasch's avatar
Francesc Guasch committed
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
has 'tls_host_subject' => (
    isa => 'Str'
    , is => 'ro'
    , builder => '_fetch_tls_host_subject'
    , lazy => 1
);

has 'tls_ca' => (
    isa => 'Str'
    , is => 'ro'
    , builder => '_fetch_tls_ca'
    , lazy => 1
);

has dir_cert => (
    isa => 'Str'
    ,is => 'ro'
    ,lazy => 1
    ,builder => '_fetch_dir_cert'
);

Francesc Guasch's avatar
Francesc Guasch committed
113
114
115
116
117
has 'store' => (
    isa => 'Bool'
    , is => 'rw'
    , default => 1
);
118
119
120
121
122
123
124
############################################################
#
# Method Modifiers definition
# 
#
around 'create_domain' => \&_around_create_domain;

125
126
before 'search_domain' => \&_pre_search_domain;
before 'list_domains' => \&_pre_list_domains;
127
128
129

before 'create_volume' => \&_connect;

130
around 'import_domain' => \&_around_import_domain;
Francesc Guasch's avatar
Francesc Guasch committed
131

Francesc Guasch's avatar
Francesc Guasch committed
132
around 'ping' => \&_around_ping;
Francesc Guasch's avatar
Francesc Guasch committed
133
around 'connect' => \&_around_connect;
Francesc Guasch's avatar
Francesc Guasch committed
134

135
136
137
138
#############################################################
#
# method modifiers
#
139

140
141
142
143
144
145
146
sub _init_connector {
    return if $CONNECTOR && $$CONNECTOR;
    $CONNECTOR = \$Ravada::CONNECTOR if $Ravada::CONNECTOR;
    $CONNECTOR = \$Ravada::Front::CONNECTOR if !defined $$CONNECTOR
                                                && defined $Ravada::Front::CONNECTOR;
}

147
148
149
150
sub _dbh($self) {
    return $$CONNECTOR->dbh();
}

151
152
153
154
155
156
157
158
159
160
161
162
=head1 Constructors

=head2 open

Opens a Virtual Machine Manager (VM)

Arguments: id of the VM

=cut

sub open {
    my $proto = shift;
163
164
165
166
167
168
169
170
171
    my %args;
    if (!scalar @_ % 2) {
        %args = @_;
        confess "ERROR: Don't set the id and the type "
            if $args{id} && $args{type};
        return _open_type($proto,@_) if $args{type};
    } else {
        $args{id} = shift;
    }
172
173
174
175
    my $class=ref($proto) || $proto;

    my $self = {};
    bless($self, $class);
176
    my $row = $self->_do_select_vm_db( id => $args{id});
177
    lock_hash(%$row);
178
    confess "ERROR: I can't find VM id=$args{id}" if !$row || !keys %$row;
179

180
181
182
183
    if ( $VM{$args{id}} && $VM{$args{id}}->name eq $row->{name} ) {
        my $vm = $VM{$args{id}};
        return _clean($vm);
    }
Francesc Guasch's avatar
Francesc Guasch committed
184

185
186
187
188
189
    my $type = $row->{vm_type};
    $type = 'KVM'   if $type eq 'qemu';
    $class .= "::$type";
    bless ($self,$class);

190
    $args{host} = $row->{hostname};
191
    $args{security} = decode_json($row->{security}) if $row->{security};
192

Francesc Guasch's avatar
Francesc Guasch committed
193
194
195
    my $vm = $self->new(%args);
    $VM{$args{id}} = $vm;
    return $vm;
196
197
198

}

Francesc Guasch's avatar
Francesc Guasch committed
199
200
201
202
sub _clean_cache {
    %VM = ();
}

203
204
sub BUILD {
    my $self = shift;
205
206
207

    my $args = $_[0];

208
209
210
    my $id = delete $args->{id};
    my $host = delete $args->{host};
    my $name = delete $args->{name};
Francesc Guasch's avatar
Francesc Guasch committed
211
212
    my $store = delete $args->{store};
    $store = 1 if !defined $store;
213
    my $public_ip = delete $args->{public_ip};
Francesc Guasch's avatar
Francesc Guasch committed
214

215
216
217
218
219
220
    delete $args->{readonly};
    delete $args->{security};

    # TODO check if this is needed
    delete $args->{connector};

Francesc Guasch's avatar
Francesc Guasch committed
221
222
    lock_hash(%$args);

223
    confess "ERROR: Unknown args ".join (",", keys (%$args)) if keys %$args;
Francesc Guasch's avatar
Francesc Guasch committed
224
    return if !$store;
225
226
    if ($id) {
        $self->_select_vm_db(id => $id)
227
228
    } else {
        my %query = (
Francesc Guasch's avatar
Francesc Guasch committed
229
            hostname => ($host or 'localhost')
230
231
            ,vm_type => $self->type
        );
Francesc Guasch's avatar
Francesc Guasch committed
232
        $query{name} = $name  if $name;
233
        $query{public_ip} = $public_ip if defined $public_ip;
234
235
        $self->_select_vm_db(%query);
    }
236
    $self->id;
Francesc Guasch's avatar
Francesc Guasch committed
237

238
239
}

240
241
242
243
244
245
246
247
248
249
sub _open_type {
    my $self = shift;
    my %args = @_;

    my $type = delete $args{type} or confess "ERROR: Missing VM type";
    my $class = "Ravada::VM::$type";

    my $proto = {};
    bless $proto,$class;

250
    my $vm = $proto->new(%args);
251
252
253
254
    eval { $vm->vm };
    warn $@ if $@;

    return $vm;
255
256
257

}

Francesc Guasch's avatar
Francesc Guasch committed
258
259
260
261
=head1 Methods

=cut

262
263
264
265
266
267
268
269
270
sub _check_readonly {
    my $self = shift;
    confess "ERROR: You can't create domains in read-only mode "
        if $self->readonly 

}

sub _connect {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
    my $result = $self->connect();
    if ($result) {
        $self->is_active(1);
    } else {
        $self->is_active(0);
    }
    return $result;
}

sub _around_connect($orig, $self) {
    my $result = $self->$orig();
    if ($result) {
        $self->is_active(1);
    } else {
        $self->is_active(0);
    }
    return $result;
288
289
290
291
292
293
294
}

sub _pre_create_domain {
    _check_create_domain(@_);
    _connect(@_);
}

295
296
297
298
299
300
301
302
303
304
sub _pre_search_domain($self,@) {
    $self->_connect();
    die "ERROR: VM ".$self->name." unavailable" if !$self->ping();
}

sub _pre_list_domains($self,@) {
    $self->_connect();
    die "ERROR: VM ".$self->name." unavailable" if !$self->ping();
}

305
306
sub _connect_ssh($self, $disconnect=0) {
    confess "Don't connect to local ssh"
Francesc Guasch's avatar
Francesc Guasch committed
307
308
        if $self->is_local;

Francesc Guasch's avatar
Francesc Guasch committed
309
310
    if ( $self->readonly || $> ) {
        confess $self->name." readonly or not root, don't do ssh";
311
312
        return;
    }
Francesc Guasch's avatar
Francesc Guasch committed
313

314
315
316
    my @pwd = getpwuid($>);
    my $home = $pwd[7];

317
318
319
320
    my $ssh= $self->{_ssh};
    $ssh = $SSH{$self->host}    if exists $SSH{$self->host};

    if (! $ssh || $disconnect ) {
321
        return if !$self->ping();
322
        $ssh->disconnect if $ssh && $disconnect;
Francesc Guasch's avatar
Francesc Guasch committed
323
        $ssh = Net::SSH2->new( timeout => $SSH_TIMEOUT );
324
325
        my $connect;
        for ( 1 .. 3 ) {
326
            eval { $connect = $ssh->connect($self->host) };
327
328
329
330
            last if $connect;
            warn "RETRYING ssh ".$self->host." ".join(" ",$ssh->error);
            sleep 1;
        }
331
332
333
334
335
336
337
        if ( !$connect) {
            eval { $connect = $ssh->connect($self->host) };
            if (!$connect) {
                $self->_cached_active(0);
                confess $ssh->error();
            }
        }
338
339
340
341
342
343
        $ssh->auth_publickey( 'root'
            , "$home/.ssh/id_rsa.pub"
            , "$home/.ssh/id_rsa"
        ) or $ssh->die_with_error();
        $self->{_ssh} = $ssh;
        $SSH{$self->host} = $ssh;
Francesc Guasch's avatar
Francesc Guasch committed
344
    }
345
    return $ssh;
346
347
}

348
sub _ssh_channel($self) {
349
    my $ssh = $self->_connect_ssh() or confess "ERROR: I can't connect to SSH in ".$self->host;
350
351
352
353
354
    my $ssh_channel;
    for ( 1 .. 5 ) {
        $ssh_channel = $ssh->channel();
        last if $ssh_channel;
        sleep 1;
355
    }
356
    if (!$ssh_channel) {
Francesc Guasch's avatar
Francesc Guasch committed
357
        $ssh = $self->_connect_ssh(1) or die "Error: I can't connect to ".$self->name;
358
        $ssh_channel = $ssh->channel();
Francesc Guasch's avatar
Francesc Guasch committed
359
    }
360
361
362
    die $ssh->die_with_error    if !$ssh_channel;
    $ssh->blocking(1);
    return $ssh_channel;
Francesc Guasch's avatar
Francesc Guasch committed
363
364
}

365
366
367
368
sub _around_create_domain {
    my $orig = shift;
    my $self = shift;
    my %args = @_;
369
    my $remote_ip = delete $args{remote_ip};
370
    my $add_to_pool = delete $args{add_to_pool};
371
    my %args_create = %args;
372

373
    my $id_owner = delete $args{id_owner} or confess "ERROR: Missing id_owner";
Francesc Guasch's avatar
Francesc Guasch committed
374
    my $owner = Ravada::Auth::SQL->search_by_id($id_owner) or confess "Unknown user id: $id_owner";
375
376

    my $base;
Francesc Guasch's avatar
Francesc Guasch committed
377
    my $volatile = delete $args{volatile};
378
    my $id_base = delete $args{id_base};
Francesc Guasch's avatar
Francesc Guasch committed
379
380
381
382
     my $id_iso = delete $args{id_iso};
     my $active = delete $args{active};
       my $name = delete $args{name};
       my $swap = delete $args{swap};
383
       my $from_pool = delete $args{from_pool};
Francesc Guasch's avatar
Francesc Guasch committed
384

385
     # args get deleted but kept on %args_create so when we call $self->$orig below are passed
Francesc Guasch's avatar
Francesc Guasch committed
386
387
388
389
     delete $args{disk};
     delete $args{memory};
     delete $args{request};
     delete $args{iso_file};
390
     delete $args{id_template};
391
     delete @args{'description','remove_cpu','vm','start'};
Francesc Guasch's avatar
Francesc Guasch committed
392
393
394

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

Francesc Guasch's avatar
Francesc Guasch committed
395
    $self->_check_duplicate_name($name);
396
397
398
    if ($id_base) {
        $base = $self->search_domain_by_id($id_base)
            or confess "Error: I can't find domain $id_base on ".$self->name;
Francesc Guasch's avatar
Francesc Guasch committed
399
        $volatile = 1 if $base->volatile_clones;
400
401
402
403
404
        if ($add_to_pool) {
            confess "Error: you can't add to pool and also pick from pool" if $from_pool;
            $from_pool = 0;
        }
        $from_pool = 1 if !defined $from_pool && $base->pools();
405
    }
Francesc Guasch's avatar
Francesc Guasch committed
406

407
408
409
410
411
412
413
    confess "ERROR: User ".$owner->name." is not allowed to create machines"
        unless $owner->is_admin
            || $owner->can_create_machine()
            || ($base && $owner->can_clone);

    confess "ERROR: Base ".$base->name." is private"
        if !$owner->is_admin && $base && !$base->is_public();
414

415
416
417
418
419
420
    if ($add_to_pool) {
        confess "Error: This machine can only be added to a pool if it is a clone"
            if !$base;
        confess("Error: Requested to add a clone for the pool but this base has no pools")
            if !$base->pools;
    }
421
422
423
    $args_create{listen_ip} = $self->listen_ip($remote_ip);
    $args_create{spice_password} = $self->_define_spice_password($remote_ip);
    $self->_pre_create_domain(%args_create);
424

425
426
    return $base->_search_pool_clone($owner) if $from_pool;

427
    my $domain = $self->$orig(%args_create, volatile => $volatile);
Francesc Guasch's avatar
Francesc Guasch committed
428
    $self->_add_instance_db($domain->id);
Francesc Guasch's avatar
Francesc Guasch committed
429
    $domain->add_volume_swap( size => $swap )   if $swap;
430

431
    if ($id_base) {
432
433
        $domain->run_timeout($base->run_timeout)
            if defined $base->run_timeout();
Francesc Guasch's avatar
Francesc Guasch committed
434
        $domain->_data(shutdown_disconnected => $base->_data('shutdown_disconnected'));
Francesc Guasch's avatar
Francesc Guasch committed
435
436
437
438
439
        for my $port ( $base->list_ports ) {
            my %port = %$port;
            delete @port{'id','id_domain','public_port'};
            $domain->expose(%port);
        }
440
    }
441
    my $user = Ravada::Auth::SQL->search_by_id($id_owner);
442
    $domain->is_volatile(1)     if $user->is_temporary() ||($base && $base->volatile_clones());
Francesc Guasch's avatar
Francesc Guasch committed
443
444
445
446
447

    my @start_args = ( user => $owner );
    push @start_args, (remote_ip => $remote_ip) if $remote_ip;

    $domain->_post_start(@start_args) if $domain->is_active;
Francesc Guasch's avatar
Francesc Guasch committed
448
    eval {
Francesc Guasch's avatar
Francesc Guasch committed
449
           $domain->start(@start_args)      if $active || ($domain->is_volatile && ! $domain->is_active);
Francesc Guasch's avatar
Francesc Guasch committed
450
451
    };
    die $@ if $@ && $@ !~ /code: 55,/;
452

Francesc Guasch's avatar
Francesc Guasch committed
453
    $domain->info($owner);
454
    $domain->display($owner)    if $domain->is_active;
Francesc Guasch's avatar
Francesc Guasch committed
455

456
    $domain->is_pool(1) if $add_to_pool;
457
458
459
    return $domain;
}

Francesc Guasch's avatar
Francesc Guasch committed
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
sub _add_instance_db($self, $id_domain) {
    my $sth = $$CONNECTOR->dbh->prepare("SELECT * FROM domain_instances "
        ." WHERE id_domain=? AND id_vm=?"
    );
    $sth->execute($id_domain, $self->id);
    my ($row) = $sth->fetchrow;
    return if $row;

    $sth = $$CONNECTOR->dbh->prepare("INSERT INTO domain_instances (id_domain, id_vm) "
        ." VALUES (?, ?)"
    );
    eval {
        $sth->execute($id_domain, $self->id);
    };
    confess $@ if $@;
}

477
478
479
480
481
482
483
484
485
sub _define_spice_password($self, $remote_ip) {
    my $spice_password = Ravada::Utils::random_name(4);
    if ($remote_ip) {
        my $network = Ravada::Network->new(address => $remote_ip);
        $spice_password = undef if !$network->requires_password;
    }
    return $spice_password;
}

Francesc Guasch's avatar
Francesc Guasch committed
486
487
488
489
490
491
492
493
494
sub _check_duplicate_name($self, $name) {
    my $sth = $$CONNECTOR->dbh->prepare("SELECT id,name,vm FROM domains where name=?");
    $sth->execute($name);
    my $row = $sth->fetchrow_hashref;
    confess "Error: machine with name '$name' already exists ".Dumper($row)
        if $row->{id};
    return 1;
}

495
496
497
sub _around_import_domain {
    my $orig = shift;
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
498
    my ($name, $user, $spinoff, $import_base) = @_;
499

Francesc Guasch's avatar
Francesc Guasch committed
500
    my $domain = $self->$orig($name, $user, $spinoff);
501
502
503

    $domain->_insert_db(name => $name, id_owner => $user->id);

504
    if ($spinoff) {
505
506
        warn "Spinning volumes off their backing files ...\n"
            if $ENV{TERM} && $0 !~ /\.t$/;
Francesc Guasch's avatar
Francesc Guasch committed
507
        $domain->spinoff();
508
    }
Francesc Guasch's avatar
Francesc Guasch committed
509
510
511
    if ($import_base) {
        $self->_import_base($domain);
    }
512
    return $domain;
513
514
}

Francesc Guasch's avatar
Francesc Guasch committed
515
516
517
518
519
520
521
522
523
524
525
526
527
sub _import_base($self, $domain) {
    my @img;
    for my $vol ( $domain->list_volumes_info ) {
        next if !$vol->file;
        next if !$vol->backing_file;
        push @img,[$vol->backing_file, $vol->info->{target}];
    }
    return if !@img;
    $domain->_prepare_base_db(@img);
    $domain->_post_prepare_base( Ravada::Utils::user_daemon());
}


528
529
############################################################
#
530

531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
sub _domain_remove_db {
    my $self = shift;
    my $name = shift;
    my $sth = $$CONNECTOR->dbh->prepare("DELETE FROM domains WHERE name=?");
    $sth->execute($name);
    $sth->finish;
}

=head2 domain_remove

Remove the domain. Returns nothing.

=cut


sub domain_remove {
    my $self = shift;
    $self->domain_remove_vm();
    $self->_domain_remove_bd();
}

=head2 name

Returns the name of this Virtual Machine Manager

    my $name = $vm->name();

=cut

sub name {
    my $self = shift;

563
    return $self->_data('name') if defined $self->{_data}->{name};
564

565
566
    my ($ref) = ref($self) =~ /.*::(.*)/;
    return ($ref or ref($self))."_".$self->host;
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
}

=head2 search_domain_by_id

Returns a domain searching by its id

    $domain = $vm->search_domain_by_id($id);

=cut

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

    my $sth = $$CONNECTOR->dbh->prepare("SELECT name FROM domains "
        ." WHERE id=?");
    $sth->execute($id);
    my ($name) = $sth->fetchrow;
    return if !$name;

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

Francesc Guasch's avatar
Francesc Guasch committed
590
591
592
593
594
595
596
597
sub _domain_in_db($self, $name) {

    my $sth = $$CONNECTOR->dbh->prepare("SELECT id FROM domains WHERE name=?");
    $sth->execute($name);
    my ($id) =$sth->fetchrow;
    return $id;
}

598
599
600
601
602
603
604
605
606
=head2 ip

Returns the external IP this for this VM

=cut

sub ip {
    my $self = shift;

607
608
    my $name = ($self->public_ip or $self->host())
        or confess "this vm has no host name";
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
    my $ip = inet_ntoa(inet_aton($name)) ;

    return $ip if $ip && $ip !~ /^127\./;

    $name = Ravada::display_ip();

    if ($name) {
        if ($name =~ /^\d+\.\d+\.\d+\.\d+$/) {
            $ip = $name;
        } else {
            $ip = inet_ntoa(inet_aton($name));
        }
    }
    return $ip if $ip && $ip !~ /^127\./;

    $ip = $self->_interface_ip();
    return $ip if $ip && $ip !~ /^127/ && $ip =~ /^\d+\.\d+\.\d+\.\d+$/;

    warn "WARNING: I can't find the IP of host ".$self->host.", using localhost."
Francesc Guasch's avatar
Francesc Guasch committed
628
        ." This virtual machine won't be available from the network." if $0 !~ /\.t$/;
629
630
631
632

    return '127.0.0.1';
}

Francesc Guasch's avatar
Francesc Guasch committed
633
634
635
636
637
638
=head2 nat_ip

Returns the IP of the VM when it is in a NAT environment

=cut

639
sub nat_ip($self) {
640
    return Ravada::nat_ip();
641
642
}

643
644
645
646
647
sub _interface_ip($self, $remote_ip=undef) {
    return '127.0.0.1' if $remote_ip && $remote_ip =~ /^127\./;
    my ($out, $err) = $self->run_command("/sbin/ip","route");
    my %route;
    my ($default_gw , $default_ip);
648

649
650
    my $remote_ip_addr = NetAddr::IP->new($remote_ip)
                or confess "I can't find netaddr for $remote_ip";
651
652
653
654
655
656
657
658
659

    for my $line ( split( /\n/, $out ) ) {
        if ( $line =~ m{^default via ([\d\.]+)} ) {
            $default_gw = NetAddr::IP->new($1);
        }
        if ( $line =~ m{^([\d\.\/]+).*src ([\d\.\/]+)} ) {
            my ($network, $ip) = ($1, $2);
            $route{$network} = $ip;

660
661
            return $ip if $remote_ip && $remote_ip eq $ip;

662
663
            my $netaddr = NetAddr::IP->new($network)
                or confess "I can't find netaddr for $network";
664
665
            return $ip if $remote_ip_addr->within($netaddr);

666
            $default_ip = $ip if !defined $default_ip && $ip !~ /^127\./;
667
668
            $default_ip = $ip if defined $default_gw && $default_gw->within($netaddr);
        }
669
    }
670
    return $default_ip;
671
672
}

Francesc Guasch's avatar
Francesc Guasch committed
673
674
675
676
677
678
679
680
=head2 listen_ip

Returns the IP where virtual machines must be bound to

Arguments: optional remote ip

=cut

681
sub listen_ip($self, $remote_ip=undef) {
682
    return Ravada::display_ip() if $self->is_local && Ravada::display_ip();
683
    return $self->public_ip     if $self->public_ip;
684

685
686
    return $self->_interface_ip($remote_ip) if $remote_ip;

687
    return (
688
            $self->ip()
689
690
691
    );
}

692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
sub _check_memory {
    my $self = shift;
    my %args = @_;
    return if !exists $args{memory};

    die "ERROR: Low memory '$args{memory}' required ".int($MIN_MEMORY_MB/1024)." MB " if $args{memory} < $MIN_MEMORY_MB;
}

sub _check_disk {
    my $self = shift;
    my %args = @_;
    return if !exists $args{disk};

    die "ERROR: Low Disk '$args{disk}' required 1 Gb " if $args{disk} < 1024*1024;
}


sub _check_create_domain {
    my $self = shift;

    my %args = @_;

    $self->_check_readonly(@_);

    $self->_check_require_base(@_);
    $self->_check_memory(@_);
    $self->_check_disk(@_);

}

sub _check_require_base {
    my $self = shift;

    my %args = @_;
726
727
728
729
730
731

    my $id_base = delete $args{id_base} or return;
    my $request = delete $args{request};
    my $id_owner = delete $args{id_owner}
        or confess "ERROR: id_owner required ";

732
733
734
    delete $args{start};
    delete $args{remote_ip};

735
    delete @args{'_vm','name','vm', 'memory','description','id_iso','listen_ip','spice_password','from_pool'};
736
737
738
739
740

    confess "ERROR: Unknown arguments ".join(",",keys %args)
        if keys %args;

    my $base = Ravada::Domain->open($id_base);
741
    my %ignore_requests = map { $_ => 1 } qw(clone refresh_machine set_base_vm start_clones shutdown_clones);
742
743
744
745
746
    my @requests;
    for my $req ( $base->list_requests ) {
        push @requests,($req) if !$ignore_requests{$req->command};
    }
    if (@requests) {
747
748
        confess "ERROR: Domain ".$base->name." has ".$base->list_requests
                            ." requests.\n"
Francesc Guasch's avatar
Francesc Guasch committed
749
                            .Dumper([$base->list_requests])
750
751
            unless scalar @requests == 1 && $request
                && $requests[0]->id eq $request->id;
752
753
    }

754

755
756
757
    die "ERROR: Domain ".$self->name." is not base"
            if !$base->is_base();

758
759
760
761
    my $user = Ravada::Auth::SQL->search_by_id($id_owner);

    die "ERROR: Base ".$base->name." is not public\n"
        unless $user->is_admin || $base->is_public;
762
763
}

764
765
766
767
768
769
770
771
772
773
774
=head2 id

Returns the id value of the domain. This id is used in the database
tables and is not related to the virtual machine engine.

=cut

sub id {
    return $_[0]->_data('id');
}

Francesc Guasch's avatar
Francesc Guasch committed
775
sub _data($self, $field, $value=undef) {
Francesc Guasch's avatar
Francesc Guasch committed
776
    if (defined $value && $self->store ) {
777
778
779
780
781
782
783
        $self->{_data}->{$field} = $value;
        my $sth = $$CONNECTOR->dbh->prepare(
            "UPDATE vms set $field=?"
            ." WHERE id=?"
        );
        $sth->execute($value, $self->id);
        $sth->finish;
784

785
786
        return $value;
    }
787
788
789

#    _init_connector();

790
    $self->_timed_data_cache()  if $self->{_data}->{$field} && $field ne 'name';
791
    return $self->{_data}->{$field} if exists $self->{_data}->{$field};
Francesc Guasch's avatar
Francesc Guasch committed
792
793
    return if !$self->store();

794
795
796
797
798
799
800
801
    $self->{_data} = $self->_select_vm_db( name => $self->name);

    confess "No DB info for VM ".$self->name    if !$self->{_data};
    confess "No field $field in vms"            if !exists$self->{_data}->{$field};

    return $self->{_data}->{$field};
}

802
sub _timed_data_cache($self) {
803
    return if !$self->{$FIELD_TIMEOUT} || time - $self->{$FIELD_TIMEOUT} < $CACHE_TIMEOUT;
804
805
806
807
    return _clean($self);
}

sub _clean($self) {
808
809
810
    my $name = $self->{_data}->{name};
    my $id = $self->{_data}->{id};
    delete $self->{_data};
811
    delete $self->{$FIELD_TIMEOUT};
812
813
    $self->{_data}->{name} = $name  if $name;
    $self->{_data}->{id} = $id      if $id;
814
    return $self;
815
816
}

817
818
819
820
sub _do_select_vm_db {
    my $self = shift;
    my %args = @_;

821
822
    _init_connector();

823
824
825
826
827
828
829
830
    if (!keys %args) {
        my $id;
        eval { $id = $self->id  };
        if ($id) {
            %args =( id => $id );
        }
    }

Francesc Guasch's avatar
Francesc Guasch committed
831
    confess Dumper(\%args) if !keys %args;
832
    my $sth = $$CONNECTOR->dbh->prepare(
833
        "SELECT * FROM vms WHERE ".join(" AND ",map { "$_=?" } sort keys %args )
834
835
836
837
    );
    $sth->execute(map { $args{$_} } sort keys %args);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;
Francesc Guasch's avatar
Francesc Guasch committed
838
839
840

    return if !$row;

841
842
843
844
845
846
    return $row;
}

sub _select_vm_db {
    my $self = shift;

847
    my ($row) = ($self->_do_select_vm_db(@_) or $self->_insert_vm_db(@_));
848
849

    $self->{_data} = $row;
850
    $self->{$FIELD_TIMEOUT} = time if $row->{id};
851
852
853
854
855
    return $row if $row->{id};
}

sub _insert_vm_db {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
856
857
    return if !$self->store();

858
    my $sth = $$CONNECTOR->dbh->prepare(
859
860
        "INSERT INTO vms (name, vm_type, hostname, public_ip)"
        ." VALUES(?, ?, ?, ?)"
861
    );
862
863
864
    my %args = @_;
    my $name = ( delete $args{name} or $self->name);
    my $host = ( delete $args{hostname} or $self->host );
865
    my $public_ip = ( delete $args{public_ip} or '' );
866
    delete $args{vm_type};
867

868
869
    confess "Unknown args ".Dumper(\%args)  if keys %args;

870
    eval { $sth->execute($name,$self->type,$host, $public_ip) };
871
    confess $@ if $@;
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
    $sth->finish;

    return $self->_do_select_vm_db( name => $name);
}

=head2 default_storage_pool_name

Set the default storage pool name for this Virtual Machine Manager

    $vm->default_storage_pool_name('default');

=cut

sub default_storage_pool_name {
    my $self = shift;
    my $value = shift;

    #TODO check pool exists
    if (defined $value) {
        my $id = $self->id();
        my $sth = $$CONNECTOR->dbh->prepare(
            "UPDATE vms SET default_storage=?"
            ." WHERE id=?"
        );
        $sth->execute($value,$id);
        $self->{_data}->{default_storage} = $value;
    }
Francesc Guasch's avatar
Francesc Guasch committed
899
    $self->_select_vm_db() if $self->store();
900
901
902
    return $self->_data('default_storage');
}

Francesc Guasch's avatar
Francesc Guasch committed
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
=head2 base_storage_pool

Set the storage pool for bases in this Virtual Machine Manager

    $vm->base_storage_pool('pool2');

=cut

sub base_storage_pool {
    my $self = shift;
    my $value = shift;

    #TODO check pool exists
    if (defined $value) {
        my $id = $self->id();
        my $sth = $$CONNECTOR->dbh->prepare(
            "UPDATE vms SET base_storage=?"
            ." WHERE id=?"
        );
        $sth->execute($value,$id);
        $self->{_data}->{base_storage} = $value;
    }
925
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
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
    return $self->_data('base_storage');
}

=head2 clone_storage_pool

Set the storage pool for clones in this Virtual Machine Manager

    $vm->clone_storage_pool('pool3');

=cut

sub clone_storage_pool {
    my $self = shift;
    my $value = shift;

    #TODO check pool exists
    if (defined $value) {
        my $id = $self->id();
        my $sth = $$CONNECTOR->dbh->prepare(
            "UPDATE vms SET clone_storage=?"
            ." WHERE id=?"
        );
        $sth->execute($value,$id);
        $self->{_data}->{clone_storage} = $value;
    }
951
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
952
953
954
    return $self->_data('clone_storage');
}

955
956
957
958
959
960
961
962
=head2 min_free_memory

Returns the minimun free memory necessary to start a new virtual machine

=cut

sub min_free_memory {
    my $self = shift;
963
    return ($self->_data('min_free_memory') or $Ravada::Domain::MIN_FREE_MEMORY);
964
965
}

Francesc Guasch's avatar
Francesc Guasch committed
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
=head2 max_load 

Returns the maximum cpu load that the host can handle.

=cut

sub max_load {
    my $self = shift;
    return $self->_data('max_load');
}

=head2 active_limit

Returns the value of 'active_limit' in the BBDD

=cut

sub active_limit {
    my $self = shift;
    return $self->_data('active_limit');
}
987

Francesc Guasch's avatar
Francesc Guasch committed
988
989
990
991
992
993
994
995
996
997
998
999
1000
=head2 list_drivers

Lists the drivers available for this Virtual Machine Manager

Arguments: Optional driver type

Returns a list of strings with the nams of the drivers.

    my @drivers = $vm->list_drivers();
    my @drivers = $vm->list_drivers('image');

=cut

For faster browsing, not all history is shown. View entire blame