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

Francesc Guasch's avatar
Francesc Guasch committed
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);
Francesc Guasch's avatar
Francesc Guasch committed
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
=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;

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 ) {
Francesc Guasch's avatar
Francesc Guasch committed
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) {
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};
Francesc Guasch's avatar
Francesc Guasch committed
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};
Francesc Guasch's avatar
Francesc Guasch committed
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;
Francesc Guasch's avatar
Francesc Guasch committed
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

Francesc Guasch's avatar
Francesc Guasch committed
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

Francesc Guasch's avatar
Francesc Guasch committed
425
426
    return $base->_search_pool_clone($owner) if $from_pool;

427
    my $domain = $self->$orig(%args_create, volatile => $volatile);
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
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

Francesc Guasch's avatar
Francesc Guasch committed
456
    $domain->is_pool(1) if $add_to_pool;
457
458
459
    return $domain;
}

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;
498
    my ($name, $user, $spinoff) = @_;
499

500
    my $domain = $self->$orig($name, $user);
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$/;
507
        $domain->spinoff();
508
    }
509
    return $domain;
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
543
544
545
546
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;

547
    return $self->_data('name') if defined $self->{_data}->{name};
548

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

=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
574
575
576
577
578
579
580
581
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;
}

582
583
584
585
586
587
588
589
590
=head2 ip

Returns the external IP this for this VM

=cut

sub ip {
    my $self = shift;

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

    return '127.0.0.1';
}

Francesc Guasch's avatar
Francesc Guasch committed
617
618
619
620
621
622
=head2 nat_ip

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

=cut

623
sub nat_ip($self) {
624
    return Ravada::nat_ip();
625
626
}

627
628
629
630
631
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);
632

633
634
635
636
637
638
639
640
641
642
643
644
645
    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);

frankiejol's avatar
frankiejol committed
646
            $default_ip = $ip if !defined $default_ip && $ip !~ /^127\./;
647
648
            $default_ip = $ip if defined $default_gw && $default_gw->within($netaddr);
        }
649
    }
650
    return $default_ip;
651
652
}

653
654
655
656
657
658
659
660
=head2 listen_ip

Returns the IP where virtual machines must be bound to

Arguments: optional remote ip

=cut

661
sub listen_ip($self, $remote_ip=undef) {
662
    return Ravada::display_ip() if Ravada::display_ip();
663
    return $self->public_ip     if $self->public_ip;
664

665
666
    return $self->_interface_ip($remote_ip) if $remote_ip;

667
    return (
668
            $self->ip()
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
694
695
696
697
698
699
700
701
702
703
704
705
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 = @_;
706
707
708
709
710
711

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

712
713
714
    delete $args{start};
    delete $args{remote_ip};

Francesc Guasch's avatar
Francesc Guasch committed
715
    delete @args{'_vm','name','vm', 'memory','description','id_iso','listen_ip','spice_password','from_pool'};
716
717
718
719
720

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

    my $base = Ravada::Domain->open($id_base);
721
722
723
724
725
726
    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) {
727
728
        confess "ERROR: Domain ".$base->name." has ".$base->list_requests
                            ." requests.\n"
Francesc Guasch's avatar
Francesc Guasch committed
729
                            .Dumper([$base->list_requests])
730
731
            unless scalar @requests == 1 && $request
                && $requests[0]->id eq $request->id;
732
733
    }

734

735
736
737
    die "ERROR: Domain ".$self->name." is not base"
            if !$base->is_base();

738
739
740
741
    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;
742
743
}

744
745
746
747
748
749
750
751
752
753
754
=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
755
sub _data($self, $field, $value=undef) {
Francesc Guasch's avatar
Francesc Guasch committed
756
    if (defined $value && $self->store ) {
757
758
759
760
761
762
763
        $self->{_data}->{$field} = $value;
        my $sth = $$CONNECTOR->dbh->prepare(
            "UPDATE vms set $field=?"
            ." WHERE id=?"
        );
        $sth->execute($value, $self->id);
        $sth->finish;
764

765
766
        return $value;
    }
767
768
769

#    _init_connector();

770
    $self->_timed_data_cache()  if $self->{_data}->{$field} && $field ne 'name';
771
    return $self->{_data}->{$field} if exists $self->{_data}->{$field};
Francesc Guasch's avatar
Francesc Guasch committed
772
773
    return if !$self->store();

774
775
776
777
778
779
780
781
    $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};
}

782
sub _timed_data_cache($self) {
783
    return if !$self->{$FIELD_TIMEOUT} || time - $self->{$FIELD_TIMEOUT} < $CACHE_TIMEOUT;
784
785
786
787
    return _clean($self);
}

sub _clean($self) {
788
789
790
    my $name = $self->{_data}->{name};
    my $id = $self->{_data}->{id};
    delete $self->{_data};
791
    delete $self->{$FIELD_TIMEOUT};
792
793
    $self->{_data}->{name} = $name  if $name;
    $self->{_data}->{id} = $id      if $id;
794
    return $self;
795
796
}

797
798
799
800
sub _do_select_vm_db {
    my $self = shift;
    my %args = @_;

801
802
    _init_connector();

803
804
805
806
807
808
809
810
    if (!keys %args) {
        my $id;
        eval { $id = $self->id  };
        if ($id) {
            %args =( id => $id );
        }
    }

Francesc Guasch's avatar
Francesc Guasch committed
811
    confess Dumper(\%args) if !keys %args;
812
    my $sth = $$CONNECTOR->dbh->prepare(
813
        "SELECT * FROM vms WHERE ".join(" AND ",map { "$_=?" } sort keys %args )
814
815
816
817
    );
    $sth->execute(map { $args{$_} } sort keys %args);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;
Francesc Guasch's avatar
Francesc Guasch committed
818
819
820

    return if !$row;

821
822
823
824
825
826
    return $row;
}

sub _select_vm_db {
    my $self = shift;

827
    my ($row) = ($self->_do_select_vm_db(@_) or $self->_insert_vm_db(@_));
828
829

    $self->{_data} = $row;
830
    $self->{$FIELD_TIMEOUT} = time if $row->{id};
831
832
833
834
835
    return $row if $row->{id};
}

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

838
    my $sth = $$CONNECTOR->dbh->prepare(
839
840
        "INSERT INTO vms (name, vm_type, hostname, public_ip)"
        ." VALUES(?, ?, ?, ?)"
841
    );
842
843
844
    my %args = @_;
    my $name = ( delete $args{name} or $self->name);
    my $host = ( delete $args{hostname} or $self->host );
845
    my $public_ip = ( delete $args{public_ip} or '' );
846
    delete $args{vm_type};
847

848
849
    confess "Unknown args ".Dumper(\%args)  if keys %args;

850
    eval { $sth->execute($name,$self->type,$host, $public_ip) };
851
    confess $@ if $@;
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
    $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
879
    $self->_select_vm_db() if $self->store();
880
881
882
    return $self->_data('default_storage');
}

Francesc Guasch's avatar
Francesc Guasch committed
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
=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;
    }
905
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
    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;
    }
931
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
932
933
934
    return $self->_data('clone_storage');
}

935
936
937
938
939
940
941
942
943
944
945
=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
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
=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');
}
967

Francesc Guasch's avatar
Francesc Guasch committed
968
969
970
971
972
973
974
975
976
977
978
979
980
=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
981
982
983
sub list_drivers($self, $name=undef) {
    return Ravada::Domain::drivers(undef,$name,$self->type);
}
984

Francesc Guasch's avatar
Francesc Guasch committed
985
986
987
988
989
990
=head2 is_local

Returns wether this virtual manager is in the local host

=cut

991
sub is_local($self) {
992
    return 1 if $self->host eq 'localhost'
993
994
        || $self->host eq '127.0.0,1'
        || !$self->host;
995
    return 0;
996
997
}

998
999
1000

=head2 list_nodes

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