VM.pm 40.3 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

}

258
259
260
261
262
263
264
265
266
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
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
    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;
284
285
286
287
288
289
290
}

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

291
292
293
294
295
296
297
298
299
300
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();
}

301
302
sub _connect_ssh($self, $disconnect=0) {
    confess "Don't connect to local ssh"
Francesc Guasch's avatar
Francesc Guasch committed
303
304
        if $self->is_local;

305
    if ( $self->readonly ) {
306
        warn $self->name." readonly, don't do ssh";
307
308
        return;
    }
Francesc Guasch's avatar
Francesc Guasch committed
309

310
311
312
    my @pwd = getpwuid($>);
    my $home = $pwd[7];

313
314
315
316
    my $ssh= $self->{_ssh};
    $ssh = $SSH{$self->host}    if exists $SSH{$self->host};

    if (! $ssh || $disconnect ) {
317
        return if !$self->ping();
318
        $ssh->disconnect if $ssh && $disconnect;
Francesc Guasch's avatar
Francesc Guasch committed
319
        $ssh = Net::SSH2->new( timeout => $SSH_TIMEOUT );
320
321
        my $connect;
        for ( 1 .. 3 ) {
322
            eval { $connect = $ssh->connect($self->host) };
323
324
325
326
            last if $connect;
            warn "RETRYING ssh ".$self->host." ".join(" ",$ssh->error);
            sleep 1;
        }
327
328
329
330
331
332
333
        if ( !$connect) {
            eval { $connect = $ssh->connect($self->host) };
            if (!$connect) {
                $self->_cached_active(0);
                confess $ssh->error();
            }
        }
334
335
336
337
338
339
        $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
340
    }
341
    return $ssh;
342
343
}

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

361
362
363
364
sub _around_create_domain {
    my $orig = shift;
    my $self = shift;
    my %args = @_;
365
    my $remote_ip = delete $args{remote_ip};
366
    my $add_to_pool = delete $args{add_to_pool};
367
    my %args_create = %args;
368

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

    my $base;
Francesc Guasch's avatar
Francesc Guasch committed
373
    my $volatile = delete $args{volatile};
374
    my $id_base = delete $args{id_base};
Francesc Guasch's avatar
Francesc Guasch committed
375
376
377
378
     my $id_iso = delete $args{id_iso};
     my $active = delete $args{active};
       my $name = delete $args{name};
       my $swap = delete $args{swap};
379
       my $from_pool = delete $args{from_pool};
Francesc Guasch's avatar
Francesc Guasch committed
380

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

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

Francesc Guasch's avatar
Francesc Guasch committed
391
    $self->_check_duplicate_name($name);
392
393
394
    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
395
        $volatile = 1 if $base->volatile_clones;
396
397
398
399
400
        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();
401
    }
Francesc Guasch's avatar
Francesc Guasch committed
402

403
404
405
406
407
408
409
    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();
410

411
412
413
414
415
416
    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;
    }
417
418
419
    $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);
420

421
422
    return $base->_search_pool_clone($owner) if $from_pool;

423
    my $domain = $self->$orig(%args_create, volatile => $volatile);
Francesc Guasch's avatar
Francesc Guasch committed
424
    $self->_add_instance_db($domain->id);
Francesc Guasch's avatar
Francesc Guasch committed
425
    $domain->add_volume_swap( size => $swap )   if $swap;
426

427
    if ($id_base) {
428
429
        $domain->run_timeout($base->run_timeout)
            if defined $base->run_timeout();
Francesc Guasch's avatar
Francesc Guasch committed
430
431
432
433
434
435

        for my $port ( $base->list_ports ) {
            my %port = %$port;
            delete @port{'id','id_domain','public_port'};
            $domain->expose(%port);
        }
436
    }
437
    my $user = Ravada::Auth::SQL->search_by_id($id_owner);
438
    $domain->is_volatile(1)     if $user->is_temporary() ||($base && $base->volatile_clones());
Francesc Guasch's avatar
Francesc Guasch committed
439
440
441
442
443

    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
444
    eval {
Francesc Guasch's avatar
Francesc Guasch committed
445
           $domain->start(@start_args)      if $active || ($domain->is_volatile && ! $domain->is_active);
Francesc Guasch's avatar
Francesc Guasch committed
446
447
    };
    die $@ if $@ && $@ !~ /code: 55,/;
448

Francesc Guasch's avatar
Francesc Guasch committed
449
    $domain->info($owner);
450
    $domain->display($owner)    if $domain->is_active;
Francesc Guasch's avatar
Francesc Guasch committed
451

452
    $domain->is_pool(1) if $add_to_pool;
453
454
455
    return $domain;
}

Francesc Guasch's avatar
Francesc Guasch committed
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
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 $@;
}

473
474
475
476
477
478
479
480
481
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
482
483
484
485
486
487
488
489
490
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;
}

491
492
493
sub _around_import_domain {
    my $orig = shift;
    my $self = shift;
494
    my ($name, $user, $spinoff) = @_;
495

496
    my $domain = $self->$orig($name, $user);
497
498
499

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

500
    if ($spinoff) {
501
502
        warn "Spinning volumes off their backing files ...\n"
            if $ENV{TERM} && $0 !~ /\.t$/;
Francesc Guasch's avatar
Francesc Guasch committed
503
        $domain->spinoff();
504
    }
505
    return $domain;
506
507
}

508
509
############################################################
#
510

511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
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;

543
    return $self->_data('name') if defined $self->{_data}->{name};
544

545
546
    my ($ref) = ref($self) =~ /.*::(.*)/;
    return ($ref or ref($self))."_".$self->host;
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
}

=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
570
571
572
573
574
575
576
577
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;
}

578
579
580
581
582
583
584
585
586
=head2 ip

Returns the external IP this for this VM

=cut

sub ip {
    my $self = shift;

587
588
    my $name = ($self->public_ip or $self->host())
        or confess "this vm has no host name";
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
    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
608
        ." This virtual machine won't be available from the network." if $0 !~ /\.t$/;
609
610
611
612

    return '127.0.0.1';
}

Francesc Guasch's avatar
Francesc Guasch committed
613
614
615
616
617
618
=head2 nat_ip

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

=cut

619
sub nat_ip($self) {
620
    return Ravada::nat_ip();
621
622
}

623
624
625
626
627
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);
628

629
630
631
632
633
634
635
636
637
638
639
640
641
    my $remote_ip_addr = NetAddr::IP->new($remote_ip);

    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;

            my $netaddr = NetAddr::IP->new($network);
            return $ip if $remote_ip_addr->within($netaddr);

642
            $default_ip = $ip if !defined $default_ip && $ip !~ /^127\./;
643
644
            $default_ip = $ip if defined $default_gw && $default_gw->within($netaddr);
        }
645
    }
646
    return $default_ip;
647
648
}

649
sub listen_ip($self, $remote_ip=undef) {
650
    return Ravada::display_ip() if $self->is_local && Ravada::display_ip();
651
    return $self->public_ip     if $self->public_ip;
652

653
654
    return $self->_interface_ip($remote_ip) if $remote_ip;

655
    return (
656
            $self->ip()
657
658
659
    );
}

660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
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 = @_;
694
695
696
697
698
699

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

700
701
702
    delete $args{start};
    delete $args{remote_ip};

703
    delete @args{'_vm','name','vm', 'memory','description','id_iso','listen_ip','spice_password','from_pool'};
704
705
706
707
708

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

    my $base = Ravada::Domain->open($id_base);
709
710
711
712
713
714
    my %ignore_requests = map { $_ => 1 } qw(clone refresh_machine set_base_vm start_clones);
    my @requests;
    for my $req ( $base->list_requests ) {
        push @requests,($req) if !$ignore_requests{$req->command};
    }
    if (@requests) {
715
716
        confess "ERROR: Domain ".$base->name." has ".$base->list_requests
                            ." requests.\n"
Francesc Guasch's avatar
Francesc Guasch committed
717
                            .Dumper([$base->list_requests])
718
719
            unless scalar @requests == 1 && $request
                && $requests[0]->id eq $request->id;
720
721
    }

722

723
724
725
    die "ERROR: Domain ".$self->name." is not base"
            if !$base->is_base();

726
727
728
729
    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;
730
731
}

732
733
734
735
736
737
738
739
740
741
742
=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
743
sub _data($self, $field, $value=undef) {
Francesc Guasch's avatar
Francesc Guasch committed
744
    if (defined $value && $self->store ) {
745
746
747
748
749
750
751
        $self->{_data}->{$field} = $value;
        my $sth = $$CONNECTOR->dbh->prepare(
            "UPDATE vms set $field=?"
            ." WHERE id=?"
        );
        $sth->execute($value, $self->id);
        $sth->finish;
752

753
754
        return $value;
    }
755
756
757

#    _init_connector();

758
    $self->_timed_data_cache()  if $self->{_data}->{$field} && $field ne 'name';
759
    return $self->{_data}->{$field} if exists $self->{_data}->{$field};
Francesc Guasch's avatar
Francesc Guasch committed
760
761
    return if !$self->store();

762
763
764
765
766
767
768
769
    $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};
}

770
sub _timed_data_cache($self) {
771
    return if !$self->{$FIELD_TIMEOUT} || time - $self->{$FIELD_TIMEOUT} < $CACHE_TIMEOUT;
772
773
774
775
    return _clean($self);
}

sub _clean($self) {
776
777
778
    my $name = $self->{_data}->{name};
    my $id = $self->{_data}->{id};
    delete $self->{_data};
779
    delete $self->{$FIELD_TIMEOUT};
780
781
    $self->{_data}->{name} = $name  if $name;
    $self->{_data}->{id} = $id      if $id;
782
    return $self;
783
784
}

785
786
787
788
sub _do_select_vm_db {
    my $self = shift;
    my %args = @_;

789
790
    _init_connector();

791
792
793
794
795
796
797
798
    if (!keys %args) {
        my $id;
        eval { $id = $self->id  };
        if ($id) {
            %args =( id => $id );
        }
    }

Francesc Guasch's avatar
Francesc Guasch committed
799
    confess Dumper(\%args) if !keys %args;
800
    my $sth = $$CONNECTOR->dbh->prepare(
801
        "SELECT * FROM vms WHERE ".join(" AND ",map { "$_=?" } sort keys %args )
802
803
804
805
    );
    $sth->execute(map { $args{$_} } sort keys %args);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;
Francesc Guasch's avatar
Francesc Guasch committed
806
807
808

    return if !$row;

809
810
811
812
813
814
    return $row;
}

sub _select_vm_db {
    my $self = shift;

815
    my ($row) = ($self->_do_select_vm_db(@_) or $self->_insert_vm_db(@_));
816
817

    $self->{_data} = $row;
818
    $self->{$FIELD_TIMEOUT} = time if $row->{id};
819
820
821
822
823
    return $row if $row->{id};
}

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

826
    my $sth = $$CONNECTOR->dbh->prepare(
827
828
        "INSERT INTO vms (name, vm_type, hostname, public_ip)"
        ." VALUES(?, ?, ?, ?)"
829
    );
830
831
832
    my %args = @_;
    my $name = ( delete $args{name} or $self->name);
    my $host = ( delete $args{hostname} or $self->host );
833
    my $public_ip = ( delete $args{public_ip} or '' );
834
    delete $args{vm_type};
835

836
837
    confess "Unknown args ".Dumper(\%args)  if keys %args;

838
    eval { $sth->execute($name,$self->type,$host, $public_ip) };
839
    confess $@ if $@;
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
    $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
867
    $self->_select_vm_db() if $self->store();
868
869
870
    return $self->_data('default_storage');
}

Francesc Guasch's avatar
Francesc Guasch committed
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
=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;
    }
893
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
    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;
    }
919
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
920
921
922
    return $self->_data('clone_storage');
}

923
924
925
926
927
928
929
930
931
932
933
=head2 min_free_memory

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

=cut

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

Francesc Guasch's avatar
Francesc Guasch committed
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
=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');
}
955

Francesc Guasch's avatar
Francesc Guasch committed
956
957
958
959
960
961
962
963
964
965
966
967
968
=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

Francesc Guasch's avatar
Francesc Guasch committed
969
970
971
sub list_drivers($self, $name=undef) {
    return Ravada::Domain::drivers(undef,$name,$self->type);
}
972

Francesc Guasch's avatar
Francesc Guasch committed
973
974
975
976
977
978
=head2 is_local

Returns wether this virtual manager is in the local host

=cut

979
sub is_local($self) {
980
    return 1 if $self->host eq 'localhost'
981
982
        || $self->host eq '127.0.0,1'
        || !$self->host;
983
    return 0;
984
985
}

986
987
988
989
990
991
992
993
994

=head2 list_nodes

Returns a list of virtual machine manager nodes of the same type as this.

    my @nodes = $self->list_nodes();

=cut

995
sub list_nodes($self) {
996
997
    return @{$self->{_nodes}} if $self->{_nodes};

998
999
1000
    my $sth = $$CONNECTOR->dbh->prepare(
        "SELECT id FROM vms WHERE vm_type=?"
    );
For faster browsing, not all history is shown. View entire blame