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

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;
22
use Net::OpenSSH;
23
24
25
26
use IO::Socket;
use IO::Interface;
use Net::Domain qw(hostfqdn);

27
28
use Ravada::Utils;

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

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

# global DB Connection

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

our $MIN_MEMORY_MB = 128 * 1024;

41
42
our $CACHE_TIMEOUT = 60;
our $FIELD_TIMEOUT = '_data_timeout';
Francesc Guasch's avatar
Francesc Guasch committed
43

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

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

50
51
52
53
54
55
56
57
# domain
requires 'create_domain';
requires 'search_domain';

requires 'list_domains';

# storage volume
requires 'create_volume';
Francesc Guasch's avatar
Francesc Guasch committed
58
requires 'list_storage_pools';
59
60
61

requires 'connect';
requires 'disconnect';
62
requires 'import_domain';
63

64
requires 'is_alive';
65
66

requires 'free_memory';
Francesc Guasch's avatar
Francesc Guasch committed
67
requires 'free_disk';
Francesc Guasch's avatar
Francesc Guasch committed
68
69
70

requires '_fetch_dir_cert';

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

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

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

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

Francesc Guasch's avatar
Francesc Guasch committed
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
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
111
112
113
114
115
has 'store' => (
    isa => 'Bool'
    , is => 'rw'
    , default => 1
);
116
117
118
119
120
121
122
123

has 'netssh' => (
    isa => 'Any'
    ,is => 'ro'
    , builder => '_connect_ssh'
    , lazy => 1
    , clearer => 'clear_netssh'
);
124
125
126
127
128
129
130
############################################################
#
# Method Modifiers definition
# 
#
around 'create_domain' => \&_around_create_domain;

131
132
before 'search_domain' => \&_pre_search_domain;
before 'list_domains' => \&_pre_list_domains;
133
134
135

before 'create_volume' => \&_connect;

136
around 'import_domain' => \&_around_import_domain;
Francesc Guasch's avatar
Francesc Guasch committed
137

Francesc Guasch's avatar
Francesc Guasch committed
138
around 'ping' => \&_around_ping;
Francesc Guasch's avatar
Francesc Guasch committed
139
around 'connect' => \&_around_connect;
140
after 'disconnect' => \&_post_disconnect;
Francesc Guasch's avatar
Francesc Guasch committed
141

142
143
144
145
#############################################################
#
# method modifiers
#
146

147
148
149
150
151
152
153
sub _init_connector {
    return if $CONNECTOR && $$CONNECTOR;
    $CONNECTOR = \$Ravada::CONNECTOR if $Ravada::CONNECTOR;
    $CONNECTOR = \$Ravada::Front::CONNECTOR if !defined $$CONNECTOR
                                                && defined $Ravada::Front::CONNECTOR;
}

154
155
156
157
sub _dbh($self) {
    return $$CONNECTOR->dbh();
}

158
159
160
161
162
163
164
165
166
167
168
169
=head1 Constructors

=head2 open

Opens a Virtual Machine Manager (VM)

Arguments: id of the VM

=cut

sub open {
    my $proto = shift;
170
171
172
173
174
175
176
177
178
    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;
    }
179
180
181
182
    my $class=ref($proto) || $proto;

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

187
188
189
190
    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
191

192
193
194
195
196
    my $type = $row->{vm_type};
    $type = 'KVM'   if $type eq 'qemu';
    $class .= "::$type";
    bless ($self,$class);

197
    $args{host} = $row->{hostname};
198
    $args{security} = decode_json($row->{security}) if $row->{security};
199

Francesc Guasch's avatar
Francesc Guasch committed
200
201
202
    my $vm = $self->new(%args);
    $VM{$args{id}} = $vm;
    return $vm;
203
204
205

}

Francesc Guasch's avatar
Francesc Guasch committed
206
207
208
209
sub _clean_cache {
    %VM = ();
}

210
211
sub BUILD {
    my $self = shift;
212
213
214

    my $args = $_[0];

215
216
217
    my $id = delete $args->{id};
    my $host = delete $args->{host};
    my $name = delete $args->{name};
Francesc Guasch's avatar
Francesc Guasch committed
218
219
    my $store = delete $args->{store};
    $store = 1 if !defined $store;
220
    my $public_ip = delete $args->{public_ip};
Francesc Guasch's avatar
Francesc Guasch committed
221

222
223
224
225
226
227
    delete $args->{readonly};
    delete $args->{security};

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

Francesc Guasch's avatar
Francesc Guasch committed
228
229
    lock_hash(%$args);

230
    confess "ERROR: Unknown args ".join (",", keys (%$args)) if keys %$args;
Francesc Guasch's avatar
Francesc Guasch committed
231
    return if !$store;
232
233
    if ($id) {
        $self->_select_vm_db(id => $id)
234
235
    } else {
        my %query = (
Francesc Guasch's avatar
Francesc Guasch committed
236
            hostname => ($host or 'localhost')
237
238
            ,vm_type => $self->type
        );
Francesc Guasch's avatar
Francesc Guasch committed
239
        $query{name} = $name  if $name;
240
        $query{public_ip} = $public_ip if defined $public_ip;
241
242
        $self->_select_vm_db(%query);
    }
243
    $self->id;
Francesc Guasch's avatar
Francesc Guasch committed
244

245
246
}

247
248
249
250
251
252
253
254
255
256
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;

257
    my $vm = $proto->new(%args);
258
259
260
261
    eval { $vm->vm };
    warn $@ if $@;

    return $vm;
262
263
264

}

265
266
267
268
=head1 Methods

=cut

269
270
271
272
273
274
275
276
277
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
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
    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;
295
296
}

297
298
299
300
301
302
303
304
305
306
sub _post_disconnect($self) {
    if (!$self->is_local) {
        if ($self->netssh) {
            $self->netssh->disconnect();
	    }
        $self->clear_netssh();
        delete $SSH{$self->host};
    }
}

307
308
309
310
311
sub _pre_create_domain {
    _check_create_domain(@_);
    _connect(@_);
}

312
313
314
315
316
317
318
319
320
321
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();
}

322
sub _connect_ssh($self) {
323
    confess "Don't connect to local ssh"
Francesc Guasch's avatar
Francesc Guasch committed
324
325
        if $self->is_local;

326
327
    if ( $self->readonly || $> ) {
        confess $self->name." readonly or not root, don't do ssh";
328
329
        return;
    }
Francesc Guasch's avatar
Francesc Guasch committed
330

331
    my $ssh;
332
333
    $ssh = $SSH{$self->host}    if exists $SSH{$self->host};

334
335
    if (!$ssh || !$ssh->check_master) {
        delete $SSH{$self->host};
336
        for ( 1 .. 3 ) {
337
338
339
340
341
342
343
344
            $ssh = Net::OpenSSH->new($self->host
                    ,timeout => 2
                 ,batch_mode => 1
                ,forward_X11 => 0
              ,forward_agent => 0
        ,kill_ssh_on_timeout => 1
            );
            last if !$ssh->error;
345
346
347
            warn "RETRYING ssh ".$self->host." ".join(" ",$ssh->error);
            sleep 1;
        }
348
349
350
351
        if ( $ssh->error ) {
            $self->_cached_active(0);
            warn "Error connecting to ".$self->host." : ".$ssh->error();
            return;
352
        }
Francesc Guasch's avatar
Francesc Guasch committed
353
    }
354
    $SSH{$self->host} = $ssh;
355
    return $ssh;
356
357
}

358
sub _ssh($self) {
359
360
361
362
363
364
365
    my $ssh = $self->netssh;
    return if !$ssh;
    return $ssh if $ssh->check_master;
    warn "WARNING: ssh error '".$ssh->error."'" if $ssh->error;
    $self->netssh->disconnect;
    $self->clear_netssh();
    return $self->netssh;
Francesc Guasch's avatar
Francesc Guasch committed
366
367
}

368
369
370
371
sub _around_create_domain {
    my $orig = shift;
    my $self = shift;
    my %args = @_;
372
    my $remote_ip = delete $args{remote_ip};
Francesc Guasch's avatar
Francesc Guasch committed
373
    my $add_to_pool = delete $args{add_to_pool};
374
    my %args_create = %args;
375

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

    my $base;
Francesc Guasch's avatar
Francesc Guasch committed
380
    my $volatile = delete $args{volatile};
381
    my $id_base = delete $args{id_base};
Francesc Guasch's avatar
Francesc Guasch committed
382
383
384
385
     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
386
       my $from_pool = delete $args{from_pool};
Francesc Guasch's avatar
Francesc Guasch committed
387

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

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

Francesc Guasch's avatar
Francesc Guasch committed
398
    $self->_check_duplicate_name($name);
399
    if ($id_base) {
400
401
402
        my $vm_local = $self;
        $vm_local = $self->new( host => 'localhost') if !$vm_local->is_local;
        $base = $vm_local->search_domain_by_id($id_base)
403
            or confess "Error: I can't find domain $id_base on ".$self->name;
Francesc Guasch's avatar
Francesc Guasch committed
404
        $volatile = 1 if $base->volatile_clones;
Francesc Guasch's avatar
Francesc Guasch committed
405
406
407
408
409
        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();
410
    }
Francesc Guasch's avatar
Francesc Guasch committed
411

412
413
414
415
416
417
418
    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();
419

Francesc Guasch's avatar
Francesc Guasch committed
420
421
422
423
424
425
    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;
    }
426
427
    $args_create{spice_password} = $self->_define_spice_password($remote_ip);
    $self->_pre_create_domain(%args_create);
428
    $args_create{listen_ip} = $self->listen_ip($remote_ip);
429

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

432
433
434
435
436
437
    if ($self->is_local && $base && $base->is_base
            && ( $base->volatile_clones || $owner->is_temporary )) {
        $request->status("balancing")                       if $request;
        my $vm = $self->balance_vm($base) or die "Error: No free nodes available.";
        $request->status("creating machine on ".$vm->name)  if $request;
        $self = $vm;
438
        $args_create{listen_ip} = $self->listen_ip($remote_ip);
439
440
    }

441
    my $domain = $self->$orig(%args_create, volatile => $volatile);
442
    $self->_add_instance_db($domain->id);
Francesc Guasch's avatar
Francesc Guasch committed
443
    $domain->add_volume_swap( size => $swap )   if $swap;
444

445
    if ($id_base) {
446
447
        $domain->run_timeout($base->run_timeout)
            if defined $base->run_timeout();
448
        $domain->_data(shutdown_disconnected => $base->_data('shutdown_disconnected'));
Francesc Guasch's avatar
Francesc Guasch committed
449
450
451
452
453
        for my $port ( $base->list_ports ) {
            my %port = %$port;
            delete @port{'id','id_domain','public_port'};
            $domain->expose(%port);
        }
454
    }
455
    my $user = Ravada::Auth::SQL->search_by_id($id_owner);
456
    $domain->is_volatile(1)     if $user->is_temporary() ||($base && $base->volatile_clones());
Francesc Guasch's avatar
Francesc Guasch committed
457
458
459
460
461

    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
462
    eval {
Francesc Guasch's avatar
Francesc Guasch committed
463
           $domain->start(@start_args)      if $active || ($domain->is_volatile && ! $domain->is_active);
Francesc Guasch's avatar
Francesc Guasch committed
464
465
    };
    die $@ if $@ && $@ !~ /code: 55,/;
466

Francesc Guasch's avatar
Francesc Guasch committed
467
    $domain->info($owner);
468
    $domain->display($owner)    if $domain->is_active;
Francesc Guasch's avatar
Francesc Guasch committed
469

Francesc Guasch's avatar
Francesc Guasch committed
470
    $domain->is_pool(1) if $add_to_pool;
471
472
473
    return $domain;
}

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

491
492
493
494
495
496
497
498
499
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
500
501
502
503
504
505
506
507
508
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;
}

509
510
511
sub _around_import_domain {
    my $orig = shift;
    my $self = shift;
512
    my ($name, $user, $spinoff, $import_base) = @_;
513

514
    my $domain = $self->$orig($name, $user, $spinoff);
515
516
517

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

518
    if ($spinoff) {
519
520
        warn "Spinning volumes off their backing files ...\n"
            if $ENV{TERM} && $0 !~ /\.t$/;
521
        $domain->spinoff();
522
    }
523
524
525
    if ($import_base) {
        $self->_import_base($domain);
    }
526
    return $domain;
527
528
}

529
530
531
532
533
534
535
536
537
538
539
540
541
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());
}


542
543
############################################################
#
544

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
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;

577
    return $self->_data('name') if defined $self->{_data}->{name};
578

579
580
    my ($ref) = ref($self) =~ /.*::(.*)/;
    return ($ref or ref($self))."_".$self->host;
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
}

=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
604
605
606
607
608
609
610
611
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;
}

612
613
614
615
616
617
618
619
620
=head2 ip

Returns the external IP this for this VM

=cut

sub ip {
    my $self = shift;

621
622
    my $name = ($self->public_ip or $self->host())
        or confess "this vm has no host name";
623
624
625
626
    my $ip = inet_ntoa(inet_aton($name)) ;

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

Francesc Guasch's avatar
Francesc Guasch committed
627
    $name = $self->display_ip();
628
629
630
631
632
633
634
635
636
637
638
639
640
641

    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
642
        ." This virtual machine won't be available from the network." if $0 !~ /\.t$/;
643
644
645
646

    return '127.0.0.1';
}

Francesc Guasch's avatar
Francesc Guasch committed
647
648
649
650
651
652
=head2 nat_ip

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

=cut

Francesc Guasch's avatar
Francesc Guasch committed
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
sub nat_ip($self, $value=undef) {
    $self->_data( nat_ip => $value ) if defined $value;
    if ($self->is_local) {
        return $self->_data('nat_ip') if $self->_data('nat_ip');
        return Ravada::nat_ip(); #deprecated
    }
    return $self->_data('nat_ip');
}

=head2 display_ip

Returns the display IP of the Virtual Manager

=cut

sub display_ip($self, $value=undef) {
    return $self->_set_display_ip($value) if defined $value;

    if ($self->is_local) {
        return $self->_data('display_ip') if $self->_data('display_ip');
        return Ravada::display_ip(); #deprecated
    }
    return $self->_data('display_ip');
}

sub _set_display_ip($self, $value) {
679
680
    if (defined $value && length $value ) {
        my %ip_address = $self->_list_ip_address();
Francesc Guasch's avatar
Francesc Guasch committed
681

682
683
684
685
        confess "Error: $value is not in any interface in node ".$self->name
        .". Found ".Dumper(\%ip_address)
        if !exists $ip_address{$value};
    }
Francesc Guasch's avatar
Francesc Guasch committed
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707

    $self->_data( display_ip => $value );
}

sub _list_ip_address($self) {
    my @cmd = ("ip","address","show");
    my ($out, $err) = $self->run_command(@cmd);
    my $dev;
    my %address;
    for my $line (split /\n/,$out) {
        my ($dev_found) = $line =~ /^\d+: (.*?):/;
        if ($dev_found) {
            $dev = $dev_found;
            next;
        }
        my ($inet) = $line =~ m{inet (\d+\.\d+\.\d+\.\d+)/};
        if ($inet) {
            die "Error: no device found for $inet in node ".$self->name."\n$out" if !$dev;
            $address{$inet} = $dev;
        }
    }
    return %address;
708
709
}

710
711
712
713
714
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);
715

716
717
    my $remote_ip_addr = NetAddr::IP->new($remote_ip)
                or confess "I can't find netaddr for $remote_ip";
718
719
720
721
722
723
724
725
726

    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;

727
728
            return $ip if $remote_ip && $remote_ip eq $ip;

729
730
            my $netaddr = NetAddr::IP->new($network)
                or confess "I can't find netaddr for $network";
731
732
            return $ip if $remote_ip_addr->within($netaddr);

frankiejol's avatar
frankiejol committed
733
            $default_ip = $ip if !defined $default_ip && $ip !~ /^127\./;
734
735
            $default_ip = $ip if defined $default_gw && $default_gw->within($netaddr);
        }
736
    }
737
    return $default_ip;
738
739
}

740
741
742
743
744
745
746
747
=head2 listen_ip

Returns the IP where virtual machines must be bound to

Arguments: optional remote ip

=cut

748
sub listen_ip($self, $remote_ip=undef) {
749
    return Ravada::display_ip() if $self->is_local && Ravada::display_ip();
750
    return $self->public_ip     if $self->public_ip;
751

752
753
    return $self->_interface_ip($remote_ip) if $remote_ip;

754
    return (
755
            $self->ip()
756
757
758
    );
}

759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
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 = @_;
793
794
795
796
797
798

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

799
800
801
    delete $args{start};
    delete $args{remote_ip};

Francesc Guasch's avatar
Francesc Guasch committed
802
    delete @args{'_vm','name','vm', 'memory','description','id_iso','listen_ip','spice_password','from_pool'};
803
804
805
806
807

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

    my $base = Ravada::Domain->open($id_base);
Francesc Guasch's avatar
Francesc Guasch committed
808
    my %ignore_requests = map { $_ => 1 } qw(clone refresh_machine set_base_vm start_clones shutdown_clones shutdown);
809
810
811
812
813
    my @requests;
    for my $req ( $base->list_requests ) {
        push @requests,($req) if !$ignore_requests{$req->command};
    }
    if (@requests) {
814
815
        confess "ERROR: Domain ".$base->name." has ".$base->list_requests
                            ." requests.\n"
Francesc Guasch's avatar
Francesc Guasch committed
816
                            .Dumper([$base->list_requests])
817
818
            unless scalar @requests == 1 && $request
                && $requests[0]->id eq $request->id;
819
820
    }

821

822
823
824
    die "ERROR: Domain ".$self->name." is not base"
            if !$base->is_base();

825
826
827
828
    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;
829
830
}

831
832
833
834
835
836
837
838
839
840
841
=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
842
sub _data($self, $field, $value=undef) {
Francesc Guasch's avatar
Francesc Guasch committed
843
    if (defined $value && $self->store ) {
844
845
846
847
848
849
850
        $self->{_data}->{$field} = $value;
        my $sth = $$CONNECTOR->dbh->prepare(
            "UPDATE vms set $field=?"
            ." WHERE id=?"
        );
        $sth->execute($value, $self->id);
        $sth->finish;
851

852
853
        return $value;
    }
854
855
856

#    _init_connector();

857
    $self->_timed_data_cache()  if $self->{_data}->{$field} && $field ne 'name';
858
    return $self->{_data}->{$field} if exists $self->{_data}->{$field};
Francesc Guasch's avatar
Francesc Guasch committed
859
860
    return if !$self->store();

861
862
863
864
865
866
867
868
    $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};
}

869
sub _timed_data_cache($self) {
870
    return if !$self->{$FIELD_TIMEOUT} || time - $self->{$FIELD_TIMEOUT} < $CACHE_TIMEOUT;
871
872
873
874
    return _clean($self);
}

sub _clean($self) {
875
876
877
    my $name = $self->{_data}->{name};
    my $id = $self->{_data}->{id};
    delete $self->{_data};
878
    delete $self->{$FIELD_TIMEOUT};
879
880
    $self->{_data}->{name} = $name  if $name;
    $self->{_data}->{id} = $id      if $id;
881
    return $self;
882
883
}

884
885
886
887
sub _do_select_vm_db {
    my $self = shift;
    my %args = @_;

888
889
    _init_connector();

890
891
892
893
894
895
896
897
    if (!keys %args) {
        my $id;
        eval { $id = $self->id  };
        if ($id) {
            %args =( id => $id );
        }
    }

Francesc Guasch's avatar
Francesc Guasch committed
898
    confess Dumper(\%args) if !keys %args;
899
    my $sth = $$CONNECTOR->dbh->prepare(
900
        "SELECT * FROM vms WHERE ".join(" AND ",map { "$_=?" } sort keys %args )
901
902
903
904
    );
    $sth->execute(map { $args{$_} } sort keys %args);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;
Francesc Guasch's avatar
Francesc Guasch committed
905
906
907

    return if !$row;

908
909
910
911
912
913
    return $row;
}

sub _select_vm_db {
    my $self = shift;

914
    my ($row) = ($self->_do_select_vm_db(@_) or $self->_insert_vm_db(@_));
915
916

    $self->{_data} = $row;
917
    $self->{$FIELD_TIMEOUT} = time if $row->{id};
918
919
920
921
922
    return $row if $row->{id};
}

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

925
    my $sth = $$CONNECTOR->dbh->prepare(
926
927
        "INSERT INTO vms (name, vm_type, hostname, public_ip)"
        ." VALUES(?, ?, ?, ?)"
928
    );
929
930
931
    my %args = @_;
    my $name = ( delete $args{name} or $self->name);
    my $host = ( delete $args{hostname} or $self->host );
932
    my $public_ip = ( delete $args{public_ip} or '' );
933
    delete $args{vm_type};
934

935
936
    confess "Unknown args ".Dumper(\%args)  if keys %args;

937
    eval { $sth->execute($name,$self->type,$host, $public_ip) };
938
    confess $@ if $@;
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
    $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
966
    $self->_select_vm_db() if $self->store();
967
968
969
    return $self->_data('default_storage');
}

Francesc Guasch's avatar
Francesc Guasch committed
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
=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;
    }
992
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
    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;
    }
1018
    $self->_select_vm_db();
Francesc Guasch's avatar
Francesc Guasch committed
1019
1020
1021
    return $self->_data('clone_storage');
}

1022
1023
1024
1025
1026
1027
1028
1029
=head2 min_free_memory

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

=cut

sub min_free_memory {
    my $self = shift;
1030
    return ($self->_data('min_free_memory') or $Ravada::Domain::MIN_FREE_MEMORY);
1031
1032
}

Francesc Guasch's avatar
Francesc Guasch committed
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
=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');
}
1054

Francesc Guasch's avatar
Francesc Guasch committed
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
=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
1068
1069
1070
sub list_drivers($self, $name=undef) {
    return Ravada::Domain::drivers(undef,$name,$self->type);
}
1071

Francesc Guasch's avatar
Francesc Guasch committed
1072
1073
1074
1075
1076
1077
=head2 is_local

Returns wether this virtual manager is in the local host

=cut

1078
sub is_local($self) {
1079
    return 1 if $self->host eq 'localhost'
1080
1081
        || $self->host eq '127.0.0,1'
        || !$self->host;
1082
    return 0;
1083
1084
}

1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
=head2 is_locked

This node has requests running or waiting to be run

=cut

sub is_locked($self) {
    my $sth = $$CONNECTOR->dbh->prepare("SELECT id, at_time, args FROM requests "
        ." WHERE status <> 'done' "
    );
    $sth->execute;
    my ($id, $at, $args);
    $sth->bind_columns(\($id, $at, $args));
    while ( $sth->fetch ) {
        next if defined $at && $at < time + 2;
        next if !$args;
        my $args_d = decode_json($args);
        return 1 if exists $args_d->{id_vm} && $args_d->{id_vm} == $self->id
    }
    return 0;
}
1106
1107
1108
1109
1110
1111
1112
1113
1114

=head2 list_nodes

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

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

=cut

1115
sub list_nodes($self) {
1116
1117
    return @{$self->{_nodes}} if $self->{_nodes};

1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
    my $sth = $$CONNECTOR->dbh->prepare(
        "SELECT id FROM vms WHERE vm_type=?"
    );
    my @nodes;
    $sth->execute($self->type);

    while (my ($id) = $sth->fetchrow) {
        push @nodes,(Ravada::VM->open($id))
    }

1128
    $self->{_nodes} = \@nodes;
1129
1130
    return @nodes;
}
1131

1132
1133
1134
1135
1136
1137
=head2 ping

Returns if the virtual manager connection is available

=cut

1138
sub ping($self, $option=undef, $cache=1) {
1139
    confess "ERROR: option unknown" if defined $option && $option ne 'debug';
Francesc Guasch's avatar
Francesc Guasch committed
1140
1141

    return 1 if $self->is_local();
Francesc Guasch's avatar
Francesc Guasch committed
1142
1143

    my $cache_key = "ping_".$self->host;
1144
1145
1146
1147
1148
1149
    if ($cache) {
        my $ping = $self->_get_cache($cache_key);
        return $ping if defined $ping;
    } else {
        $self->_delete_cache($cache_key);
    }
Francesc Guasch's avatar
Francesc Guasch committed
1150

1151
1152
1153
    my $debug = 0;
    $debug = 1 if defined $option && $option eq 'debug';

1154
1155
    my $ping = $self->_do_ping($self->host, $debug);
    $self->_set_cache($cache_key => $ping)  if $cache;
Francesc Guasch's avatar
Francesc Guasch committed
1156
1157
1158
    return $ping;
}

1159
1160
1161
1162
sub _ping_nocache($self,$option=undef) {
    return $self->ping($option,0);
}

1163
1164
1165
1166
sub _delete_cache($self, $key) {
    $key = "_cache_$key";
    delete $self->{$key};
}
Francesc Guasch's avatar
Francesc Guasch committed
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
sub _set_cache($self, $key, $value) {
    $key = "_cache_$key";
    $self->{$key} = [ $value, time ];
}

sub _get_cache($self, $key, $timeout=30) {
    $key = "_cache_$key";
    return if !exists $self->{$key};
    my ($value, $time) = @{$self->{$key}};
    if ( time - $time > $timeout ) {
        delete $self->{$key};
        return ;
    }
    return $value;
Francesc Guasch's avatar
Francesc Guasch committed
1181
1182
1183
}

sub _do_ping($self, $host, $debug=0) {
1184

Francesc Guasch's avatar
Francesc Guasch committed
1185
    my $p = Net::Ping->new('tcp',2);
1186
    my $ping_ok;
Francesc Guasch's avatar
Francesc Guasch committed
1187
1188
1189
1190
1191
    eval { $ping_ok = $p->ping($host) };
    confess $@ if $@;
    warn "$@ pinging host $host" if $@;

    $self->_store_mac_address() if $ping_ok && $self;
1192
    return 1 if $ping_ok;
Francesc Guasch's avatar
Francesc Guasch committed
1193
1194
    $p->close();

1195
    return if $>; # icmp ping requires root privilege
1196
    warn "trying icmp"   if $debug;
Francesc Guasch's avatar
Francesc Guasch committed
1197
    $p= Net::Ping->new('icmp',2);
Francesc Guasch's avatar
Francesc Guasch committed
1198
    eval { $ping_ok = $p->ping($host) };
1199
    warn $@ if $@;
Francesc Guasch's avatar
Francesc Guasch committed
1200
    $self->_store_mac_address() if $ping_ok && $self;
1201
    return 1 if $ping_ok;
Francesc Guasch's avatar
Francesc Guasch committed
1202

1203
    return 0;
Francesc Guasch's avatar
Francesc Guasch committed
1204
1205
}

1206
1207
1208
sub _around_ping($orig, $self, $option=undef, $cache=1) {

    my $ping = $self->$orig($option, $cache);
Francesc Guasch's avatar
Francesc Guasch committed
1209

1210
1211
1212
1213
    if ($cache) {
        $self->_cached_active($ping);
        $self->_cached_active_time(time);
    }
Francesc Guasch's avatar
Francesc Guasch committed
1214
1215
1216
1217

    return $ping;
}

1218
1219
=head2 is_active

1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
Returns if the domain is active. The active state is cached for some seconds.
Pass an optional true value to perform a real check.

Arguments: optional force mode

    if ($node->is_active) {
    }


    if ($node->is_active(1)) {
    }
1231
1232
1233

=cut

1234
sub is_active($self, $force=0) {
1235
    return $self->_do_is_active($force) if $self->is_local || $force;
1236

1237
    return $self->_cached_active if time - $self->_cached_active_time < 60;
1238
1239
1240
    return $self->_do_is_active();
}

1241
sub _do_is_active($self, $force=undef) {
1242
    my $ret = 0;
1243
1244
    if ( $self->is_local ) {
        $ret = 1 if $self->vm;
1245
    } else {
1246
1247
1248
        my @ping_args = ();
        @ping_args = (undef,0) if $force; # no cache
        if ( !$self->ping(@ping_args) ) {
1249
1250
1251
1252
1253
1254
            $ret = 0;
        } else {
            if ( $self->is_alive ) {
                $ret = 1;
            }
        }
1255
1256
1257
    }
    $self->_cached_active($ret);
    $self->_cached_active_time(time);
1258
1259
1260

    my $cache_key = "ping_".$self->host;
    $self->_delete_cache($cache_key);
1261
1262
1263
1264
    return $ret;
}

sub _cached_active($self, $value=undef) {
1265
    return $self->_data('is_active', $value);
1266
}
Francesc Guasch's avatar
Francesc Guasch committed
1267

1268
1269
sub _cached_active_time($self, $value=undef) {
    return $self->_data('cached_active_time', $value);
1270
}