Ravada.pm 37.3 KB
Newer Older
1
2
3
4
5
package Ravada;

use warnings;
use strict;

Francesc Guasch's avatar
Francesc Guasch committed
6
our $VERSION = '0.2.7-beta1';
Francesc Guasch's avatar
Francesc Guasch committed
7

8
use Carp qw(carp croak);
9
use Data::Dumper;
10
use DBIx::Connector;
11
use Hash::Util qw(lock_hash);
12
use Moose;
Francesc Guasch's avatar
Francesc Guasch committed
13
use POSIX qw(WNOHANG);
14
15
use YAML;

16
17
use Socket qw( inet_aton inet_ntoa );

Francesc Guasch's avatar
Francesc Guasch committed
18
use Ravada::Auth;
19
use Ravada::Request;
20
use Ravada::VM::KVM;
21
use Ravada::VM::Void;
22

Francesc Guasch's avatar
Francesc Guasch committed
23
24
25
26
27
28
29
30
31
32
33
34
=head1 NAME

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

35
36
37
38
39
40
41

our $FILE_CONFIG = "/etc/ravada.conf";

###########################################################################

our $CONNECTOR;
our $CONFIG = {};
42
our $DEBUG;
43
our $CAN_FORK = 1;
44
our $CAN_LXC = 0;
45
46
47
48

# Seconds to wait for other long process
our $SECONDS_WAIT_CHILDREN = 2;
# Limit for long processes
49
our $LIMIT_PROCESS = 2;
50
51
our $LIMIT_HUGE_PROCESS = 1;

52
53
our $DIR_SQL = "sql/mysql";
$DIR_SQL = "/usr/share/doc/ravada/sql/mysql" if ! -e $DIR_SQL;
54

55
# LONG commands take long
56
57
our %HUGE_COMMAND = map { $_ => 1 } qw(download);
our %LONG_COMMAND =  map { $_ => 1 } (qw(prepare_base remove_base screenshot ), keys %HUGE_COMMAND);
58

59
60
61
our $USER_DAEMON;
our $USER_DAEMON_NAME = 'daemon';

62
63
64
65
66
67
68
69
has 'vm' => (
          is => 'ro'
        ,isa => 'ArrayRef'
       ,lazy => 1
     , builder => '_create_vm'
);

has 'connector' => (
70
71
72
73
74
75
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
76
77
);

78
79
80
81
82
83
has 'warn_error' => (
    is => 'rw'
    ,isa => 'Bool'
    ,default => sub { 1 }
);

Francesc Guasch's avatar
Francesc Guasch committed
84
85
86
87
88
89
90
=head2 BUILD

Internal constructor

=cut


91
92
sub BUILD {
    my $self = shift;
93
    if ($self->config()) {
94
        _init_config($self->config);
95
    } else {
Francesc Guasch's avatar
Francesc Guasch committed
96
        _init_config($FILE_CONFIG) if -e $FILE_CONFIG;
97
    }
98

Francesc Guasch's avatar
Francesc Guasch committed
99
    if ( $self->connector ) {
joansp's avatar
joansp committed
100
        $CONNECTOR = $self->connector
Francesc Guasch's avatar
Francesc Guasch committed
101
102
    } else {
        $CONNECTOR = $self->_connect_dbh();
103
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
104
    }
Francesc Guasch's avatar
Francesc Guasch committed
105
    Ravada::Auth::init($CONFIG);
106

107
    $self->_create_tables();
108
    $self->_upgrade_tables();
Francesc Guasch's avatar
Francesc Guasch committed
109
    $self->_init_user_daemon();
110
111
112
    $self->_update_data();
}

113
114
115
116
117
118
119
120
121
122
123
124
125
126
sub _init_user_daemon {
    my $self = shift;
    return if $USER_DAEMON;

    $USER_DAEMON = Ravada::Auth::SQL->new(name => $USER_DAEMON_NAME);
    if (!$USER_DAEMON->id) {
        $USER_DAEMON = Ravada::Auth::SQL::add_user(
            name => $USER_DAEMON_NAME,
            is_admin => 1
        );
        $USER_DAEMON = Ravada::Auth::SQL->new(name => $USER_DAEMON_NAME);
    }

}
127
128
sub _update_user_grants {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
129
    $self->_init_user_daemon();
130
131
132
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM users");
    my $id;
    $sth->execute;
Francesc Guasch's avatar
Francesc Guasch committed
133
    $sth->bind_columns(\$id);
134
135
    while ($sth->fetch) {
        my $user = Ravada::Auth::SQL->search_by_id($id);
Francesc Guasch's avatar
Francesc Guasch committed
136
137
        next if $user->name() eq $USER_DAEMON_NAME;

138
139
        $USER_DAEMON->grant_user_permissions($user);
        $USER_DAEMON->grant_admin_permissions($user)    if $user->is_admin;
140
141
142
143
    }
    $sth->finish;
}

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
sub _update_isos {
    my $self = shift;
    my $table = 'iso_images';
    my $field = 'name';
    my %data = (
        zesty => {
                    name => 'Ubuntu Zesty Zapus'
            ,description => 'Ubuntu 17.04 Zesty Zapus 64 bits'
                   ,arch => 'amd64'
                    ,xml => 'yakkety64-amd64.xml'
             ,xml_volume => 'yakkety64-volume.xml'
                    ,url => 'http://releases.ubuntu.com/17.04/'
                ,file_re => ,'ubuntu-17.04.*desktop-amd64.iso'
                ,md5_url => ,'http://releases.ubuntu.com/17.04/MD5SUMS'
        }
Francesc Guasch's avatar
Francesc Guasch committed
159
160
161
162
163
164
165
166
167
168
169
170
        ,serena64 => {
            name => 'Mint 18.1 Mate 64 bits'
    ,description => 'Mint Serena 18.1 with Mate Desktop based on Ubuntu Xenial 64 bits'
           ,arch => 'amd64'
            ,xml => 'xenial64-amd64.xml'
     ,xml_volume => 'xenial64-volume.xml'
            ,url => 'http://mirrors.evowise.com/linuxmint/stable/18.1/'
        ,file_re => 'linuxmint-18.1-mate-64bit.iso'
        ,md5_url => ''
            ,md5 => 'c5cf5c5d568e2dfeaf705cfa82996d93'

        }
Francesc Guasch's avatar
Francesc Guasch committed
171
172
173
        ,fedora => {
            name => 'Fedora 25'
            ,description => 'RedHat Fedora 25 Workstation 64 bits'
Francesc Guasch's avatar
Francesc Guasch committed
174
            ,url => 'http://ftp.halifax.rwth-aachen.de/fedora/linux/releases/25/Workstation/x86_64/iso/Fedora-Workstation-netinst-x86_64-25-.*\.iso'
Francesc Guasch's avatar
Francesc Guasch committed
175
176
177
178
179
            ,arch => 'amd64'
            ,xml => 'xenial64-amd64.xml'
            ,xml_volume => 'xenial64-volume.xml'
            ,sha256_url => 'http://fedora.mirrors.ovh.net/linux/releases/25/Workstation/x86_64/iso/Fedora-Workstation-25-.*-x86_64-CHECKSUM'
        }
Francesc Guasch's avatar
Francesc Guasch committed
180
181
182
183
184
185
186
187
188
189
190
        ,xubuntu_zesty => {
            name => 'Xubuntu Zesty Zapus'
            ,description => 'Xubuntu 17.04 Zesty Zapus 64 bits'
            ,arch => 'amd64'
            ,xml => 'yakkety64-amd64.xml'
            ,xml_volume => 'yakkety64-volume.xml'
            ,md5 => '6bd80e10bf223a04d3aafe0f997d046b'
            ,url => 'http://archive.ubuntu.com/ubuntu/dists/zesty/main/installer-amd64/current/images/netboot/mini.iso'
        }
        ,xubuntu_xenial => {
            name => 'Xubuntu Xenial Xerus'
191
            ,description => 'Xubuntu 16.04 Xenial Xerus 64 bits (LTS)'
Francesc Guasch's avatar
Francesc Guasch committed
192
193
194
195
196
            ,url => 'http://archive.ubuntu.com/ubuntu/dists/xenial/main/installer-amd64/current/images/netboot/mini.iso'
           ,xml => 'yakkety64-amd64.xml'
            ,xml_volume => 'yakkety64-volume.xml'
            ,md5 => 'fe495d34188a9568c8d166efc5898d22'
        }
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
        ,lubuntu_zesty => {
            name => 'Lubuntu Zesty Zapus'
            ,description => 'Lubuntu 17.04 Zesty Zapus 64 bits'
            ,url => 'http://cdimage.ubuntu.com/lubuntu/releases/17.04/release/lubuntu-17.04-desktop-amd64.iso'
            ,md5_url => 'http://cdimage.ubuntu.com/lubuntu/releases/17.04/release/MD5SUMS'
            ,xml => 'yakkety64-amd64.xml'
            ,xml_volume => 'yakkety64-volume.xml'
        }
        ,lubuntu_xenial => {
            name => 'Lubuntu Xenial Xerus'
            ,description => 'Xubuntu 16.04 Xenial Xerus 64 bits (LTS)'
            ,url => 'http://cdimage.ubuntu.com/lubuntu/releases/16.04.2/release/lubuntu-16.04.2-desktop-amd64.iso'
            ,md5_url => 'http://cdimage.ubuntu.com/lubuntu/releases/16.04.2/release/MD5SUMS'
            ,xml => 'yakkety64-amd64.xml'
            ,xml_volume => 'yakkety64-volume.xml'
        }
Francesc Guasch's avatar
Francesc Guasch committed
213

214
215
216
217
218
219
220
221
    );

    my $sth_search = $CONNECTOR->dbh->prepare("SELECT id FROM $table WHERE $field = ?");
    for my $name (keys %data) {
        my $row = $data{$name};
        $sth_search->execute($row->{$field});
        my ($id) = $sth_search->fetchrow;
        next if $id;
Francesc Guasch's avatar
Francesc Guasch committed
222
        warn("INFO: updating $table : $row->{$field}\n")    if $0 !~ /\.t$/;
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240

        my $sql =
            "INSERT INTO iso_images "
            ."("
            .join(" , ", sort keys %{$data{$name}})
            .")"
            ." VALUES ( "
            .join(" , ", map { "?" } keys %{$data{$name}})
            ." )"
        ;
        my $sth = $CONNECTOR->dbh->prepare($sql);
        $sth->execute(map { $data{$name}->{$_} } sort keys %{$data{$name}});
        $sth->finish;
    }
}

sub _update_data {
    my $self = shift;
241

242
    $self->_update_isos();
243
    $self->_update_user_grants();
244
245
}

246
247
248
249
250
251
252
253
254
255
sub _upgrade_table {
    my $self = shift;
    my ($table, $field, $definition) = @_;
    my $dbh = $CONNECTOR->dbh;

    my $sth = $dbh->column_info(undef,undef,$table,$field);
    my $row = $sth->fetchrow_hashref;
    $sth->finish;
    return if $row;

Francesc Guasch's avatar
Francesc Guasch committed
256
    warn "INFO: adding $field $definition to $table\n"  if $0 !~ /\.t$/;
257
    $dbh->do("alter table $table add $field $definition");
258
    return 1;
259
260
}

261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
sub _create_table {
    my $self = shift;
    my $table = shift;

    my $sth = $CONNECTOR->dbh->table_info('%',undef,$table,'TABLE');
    my $info = $sth->fetchrow_hashref();
    $sth->finish;
    return if keys %$info;

    warn "INFO: creating table $table\n";
    my $file_sql = "$DIR_SQL/$table.sql";
    open my $in,'<',$file_sql or die "$! $file_sql";
    my $sql = join " ",<$in>;
    close $in;

    $CONNECTOR->dbh->do($sql);
    return 1;
}

sub _insert_data {
    my $self = shift;
    my $table = shift;

    my $file_sql =  "$DIR_SQL/../data/insert_$table.sql";
    return if ! -e $file_sql;

    warn "INFO: inserting data for $table\n";
    open my $in,'<',$file_sql or die "$! $file_sql";
    my $sql = '';
    while (my $line = <$in>) {
        $sql .= $line;
        next if $sql !~ /\w/ || $sql !~ /;\s*$/;
        $CONNECTOR->dbh->do($sql);
        $sql = '';
    }
    close $in;

}

sub _create_tables {
    my $self = shift;
302
303
304
305
#    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

    my $driver = lc($CONNECTOR->dbh->{Driver}{Name});
    $DIR_SQL =~ s{(.*)/.*}{$1/$driver};
306

307
308
309
310
    opendir my $ls,$DIR_SQL or die "$! $DIR_SQL";
    while (my $file = readdir $ls) {
        my ($table) = $file =~ m{(.*)\.sql$};
        next if !$table;
311
        next if $table =~ /^insert/;
312
313
314
315
316
        $self->_insert_data($table)     if $self->_create_table($table);
    }
    closedir $ls;
}

317
318
sub _upgrade_tables {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
319
#    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;
320

321
    $self->_upgrade_table('file_base_images','target','varchar(64) DEFAULT NULL');
322

323
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
324
325
    $self->_upgrade_table('vms','connection_args',"text DEFAULT NULL");

326
    $self->_upgrade_table('requests','at_time','int(11) DEFAULT NULL');
Francesc Guasch's avatar
Francesc Guasch committed
327

328
    $self->_upgrade_table('iso_images','md5_url','varchar(255)');
Francesc Guasch's avatar
Francesc Guasch committed
329
330
    $self->_upgrade_table('iso_images','sha256','varchar(255)');
    $self->_upgrade_table('iso_images','sha256_url','varchar(255)');
331
    $self->_upgrade_table('iso_images','file_re','char(64)');
332
    $self->_upgrade_table('iso_images','device','varchar(255)');
333
334

    $self->_upgrade_table('users','language','char(3) DEFAULT NULL');
335
336
337
338
339
340
    if ( $self->_upgrade_table('users','is_external','int(11) DEFAULT 0')) {
        my $sth = $CONNECTOR->dbh->prepare(
            "UPDATE users set is_external=1 WHERE password='*LK* no pss'"
        );
        $sth->execute;
    }
Francesc Guasch's avatar
Francesc Guasch committed
341

342
    $self->_upgrade_table('networks','requires_password','int(11)');
343
344
    $self->_upgrade_table('networks','n_order','int(11) not null default 0');

345
    $self->_upgrade_table('domains','spice_password','varchar(20) DEFAULT NULL');
346
347
}

348

349
350
351
352
sub _connect_dbh {
    my $driver= ($CONFIG->{db}->{driver} or 'mysql');;
    my $db_user = ($CONFIG->{db}->{user} or getpwnam($>));;
    my $db_pass = ($CONFIG->{db}->{password} or undef);
Francesc Guasch's avatar
Francesc Guasch committed
353
354
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
355
356
357
358
359
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

360
=head2 display_ip
361

362
Returns the default display IP read from the config file
363

364
=cut
365

366
sub display_ip {
367

368
    my $ip = $CONFIG->{display_ip};
joansp's avatar
joansp committed
369

370
    return $ip if $ip;
371
372
}

373
374
sub _init_config {
    my $file = shift;
375
376

    my $connector = shift;
377
    confess "Deprecated connector" if $connector;
378

379
    $CONFIG = YAML::LoadFile($file);
380
381
382

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
383
#    $CONNECTOR = ( $connector or _connect_dbh());
384
385
}

386
sub _create_vm_kvm {
387
    my $self = shift;
388

389
390
391
392
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

    return(undef,"ERROR: Missing qemu-img") if !$cmd_qemu_img;
393
394

    my $vm_kvm;
395

396
397
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
398
399
400
401

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
402
        $internal_vm = $vm_kvm->vm;
403
404
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
405
406
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
407
408
}

409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
=head2 disconnect_vm

Disconnect all the Virtual Managers connections.

=cut


sub disconnect_vm {
    my $self = shift;
    $self->_disconnect_vm();
}

sub _disconnect_vm{
    my $self = shift;
    return $self->_connect_vm(0);
}

sub _connect_vm {
427
    my $self = shift;
428
429
430
431

    my $connect = shift;
    $connect = 1 if !defined $connect;

432
433
    my @vms;
    eval { @vms = $self->vm };
434
    warn $@ if $@ && $self->warn_error;
435
436
437
438
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
439
440
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
441
442
443

        if (!$connect) {
            $vm->disconnect();
444
445
        } else {
            $vm->connect();
446
        }
447
448
449
    }
}

450
451
452
453
454
455
sub _create_vm {
    my $self = shift;

    my @vms = ();

    my ($vm_kvm, $err_kvm) = $self->_create_vm_kvm();
456
    warn $err_kvm if $err_kvm && $0 !~ /\.t$/;
457

458
459
    my $err = $err_kvm;

460
461
462
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
463
464
465
466
467
468
    if ($CAN_LXC) {
        eval { $vm_lxc = Ravada::VM::LXC->new( connector => ( $self->connector or $CONNECTOR )) };
        push @vms,($vm_lxc) if $vm_lxc;
        my $err_lxc = $@;
        $err .= "\n$err_lxc" if $err_lxc;
    }
469
    if (!@vms) {
470
        warn "No VMs found: $err\n" if $self->warn_error;
471
472
473
    }
    return \@vms;

474
475
}

476
sub _check_vms {
477
478
    my $self = shift;

479
480
    my @vm;
    eval { @vm = @{$self->vm} };
481
482
483
484
485
486
487
488
489
490
    for my $n ( 0 .. $#vm ) {
        if ($vm[$n] && ref $vm[$n] =~ /KVM/i) {
            if (!$vm[$n]->is_alive) {
                warn "$vm[$n] dead" if $DEBUG;
                $vm[$n] = $self->_create_vm_kvm();
            }
        }
    }
}

Francesc Guasch's avatar
Francesc Guasch committed
491
492
493
494
=head2 create_domain

Creates a new domain based on an ISO image or another domain.

joansp's avatar
joansp committed
495
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
496
497
498
499
500
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
501
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
502
503
504
505
506
507
508
509
         name => $name
    , id_base => 3
  );


=cut


510
sub create_domain {
511
512
    my $self = shift;

513
514
    my %args = @_;

515
516
517
    croak "Argument id_owner required "
        if !$args{id_owner};

518
519
    my $vm_name = $args{vm};
    delete $args{vm};
520

521
    my $request = ( $args{request} or undef);
Francesc Guasch's avatar
Francesc Guasch committed
522

523
    my $vm;
524
525
526
527
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
528
    $vm = $self->vm->[0]               if !$vm;
529

530
531
    confess "No vm found"   if !$vm;

532
533
    carp "WARNING: no VM defined, we will use ".$vm->name
        if !$vm_name;
Francesc Guasch's avatar
Francesc Guasch committed
534

535
    confess "I can't find any vm ".Dumper($self->vm) if !$vm;
Francesc Guasch's avatar
Francesc Guasch committed
536

537
    return $vm->create_domain(@_);
538
539
}

Francesc Guasch's avatar
Francesc Guasch committed
540
541
542
543
544
545
546
547
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

548
549
sub remove_domain {
    my $self = shift;
550
551
    my %arg = @_;

552
    confess "Argument name required "
553
554
        if !$arg{name};

555
556
    confess "Argument uid required "
        if !$arg{uid};
557
558
559
560

    lock_hash(%arg);

    my $domain = $self->search_domain($arg{name}, 1)
561
        or die "ERROR: I can't find domain '$arg{name}', maybe already removed.";
562

563
564
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
565
566
}

Francesc Guasch's avatar
Francesc Guasch committed
567
568
569
570
571
572
=head2 search_domain

  my $domain = $ravada->search_domain($name);

=cut

573
574
575
sub search_domain {
    my $self = shift;
    my $name = shift;
576
    my $import = shift;
577

578
579
580
581
582
583
584
585
586
587
588
589
    my $vm = $self->search_vm('Void');
    warn "No Void VM" if !$vm;
    return if !$vm;

    my $domain = $vm->search_domain($name, $import);
    return $domain if $domain;

    my @vms;
    eval { @vms = $self->vm };
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

590
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
591
        my $domain = $vm->search_domain($name, $import);
592
        next if !$domain;
593
        next if !$domain->_select_domain_db && !$import;
594
595
596
        my $id;
        eval { $id = $domain->id };
        # TODO import the domain in the database with an _insert_db or something
Francesc Guasch's avatar
Francesc Guasch committed
597
        warn $@ if $@   && $DEBUG;
598
        return $domain if $id || $import;
599
    }
600
601


602
    return;
603
}
604

Francesc Guasch's avatar
Francesc Guasch committed
605
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
606

Francesc Guasch's avatar
Francesc Guasch committed
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
  my $domain = $ravada->search_domain_by_id($id);

=cut

sub search_domain_by_id {
    my $self = shift;
    my $id = shift  or confess "ERROR: missing argument id";

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

    return $self->search_domain($name);
}
Francesc Guasch's avatar
Francesc Guasch committed
622

623
624
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
625
List all created domains
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641

  my @list = $ravada->list_domains();

=cut

sub list_domains {
    my $self = shift;
    my @domains;
    for my $vm (@{$self->vm}) {
        for my $domain ($vm->list_domains) {
            push @domains,($domain);
        }
    }
    return @domains;
}

642
643
644
645
646
647
648
649
650
651
652
653
654
=head2 list_domains_data

List all domains in raw format. Return a list of id => { name , id , is_active , is_base }

   my $list = $ravada->list_domains_data();

   $c->render(json => $list);

=cut

sub list_domains_data {
    my $self = shift;
    my @domains;
655
656
657
658
659
660
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
661
    }
662
    $sth->finish;
663
    return \@domains;
664
665
}

666
667
668
669
670
671
672
# sub list_domains_data {
#     my $self = shift;
#     my @domains;
#     for my $domain ($self->list_domains()) {
#         eval { $domain->id };
#         warn $@ if $@;
#         next if $@;
joansp's avatar
joansp committed
673
#         push @domains, {                id => $domain->id
674
675
676
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
677

678
679
680
681
682
#                            }
#     }
#     return \@domains;
# }

683

Francesc Guasch's avatar
Francesc Guasch committed
684
685
686
687
688
689
690
691
692
693
694
695
696
697
=head2 list_bases

List all base domains

  my @list = $ravada->list_domains();


=cut

sub list_bases {
    my $self = shift;
    my @domains;
    for my $vm (@{$self->vm}) {
        for my $domain ($vm->list_domains) {
698
699
700
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
701
702
703
704
705
706
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
=head2 list_bases_data

List information about the bases

=cut

sub list_bases_data {
    my $self = shift;
    my @data;
    for ($self->list_bases ) {
        push @data,{ id => $_->id , name => $_->name };
    }
    return \@data;
}

Francesc Guasch's avatar
Francesc Guasch committed
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
=head2 list_images

List all ISO images

=cut

sub list_images {
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM iso_images ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
=head2 list_images_data

List information about the images

=cut

sub list_images_data {
    my $self = shift;
    my @data;
    for ($self->list_images ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

Francesc Guasch's avatar
Francesc Guasch committed
757

758
759
760
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
761
762
763
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
764
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
765
766
767
768
769
770
771
772
773
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

774
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
775
776
777
778
779
780
781
782
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

783
=cut
fv3rdugo's avatar
fv3rdugo committed
784

Francesc Guasch's avatar
Francesc Guasch committed
785
786
787
788
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
789

Francesc Guasch's avatar
Francesc Guasch committed
790
791
=cut

792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
sub remove_volume {
    my $self = shift;

    my $file = shift;
    my ($name) = $file =~ m{.*/(.*)};

    my $removed = 0;
    for my $vm (@{$self->vm}) {
        my $vol = $vm->search_volume($name);
        next if !$vol;

        $vol->delete();
        $removed++;
    }
    if (!$removed && -e $file ) {
        warn "volume $file not found. removing file $file.\n";
        unlink $file or die "$! $file";
    }

}
812

813
814
815
816
817
818
819
820
821
=head2 clean_killed_requests

Before processing requests, old killed requests must be cleaned.

=cut

sub clean_killed_requests {
    my $self = shift;
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
822
        ." WHERE status <> 'done' AND STATUS <> 'requested'"
823
824
825
826
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
827
        $req->status("done","Killed ".$req->command." before completion");
828
829
830
831
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
832
833
834
835
836
837
838
839
=head2 process_requests

This is run in the ravada backend. It processes the commands requested by the fronted

  $ravada->process_requests();

=cut

840
841
sub process_requests {
    my $self = shift;
842
    my $debug = shift;
843
    my $dont_fork = shift;
844
845
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
846

847
848
    $self->_wait_pids_nohang();

849
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
850
851
852
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
853
854
        ." ORDER BY date_req"
    );
855
856
857
858
859
860
861
    $sth->execute(time);

    my $debug_type = '';
    $debug_type = 'long' if $long_commands;
    $debug_type = 'short' if $short_commands || !$long_commands;
    $debug_type = 'all' if $long_commands && $short_commands;

862
863
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
864
865
866
867
868
869
870
871
872

        if ( ($long_commands && 
                (!$short_commands && !$LONG_COMMAND{$req->command}))
            ||(!$long_commands && $LONG_COMMAND{$req->command})
        ) {
            warn "[$debug_type,$long_commands,$short_commands] $$ skipping request "
                .$req->command  if $DEBUG;
            next;
        }
873
874
        next if $req->command !~ /shutdown/i
            && $self->_domain_working($id_domain, $id_request);
875

876
877
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
878
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
879
880
881

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
882
883
884
        my $err = $self->_execute($req, $dont_fork);
        $req->error($err)   if $err;
        if ($err && $err =~ /libvirt error code: 38/) {
Francesc Guasch's avatar
Francesc Guasch committed
885
            if ( $n_retry < 3) {
886
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
887
                $req->status("retry ".++$n_retry)
888
            }
889
        }
890
891
892
        next if !$DEBUG && !$debug;

        sleep 1;
893
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
894
            ." , error: '".($req->error or 'NONE')."'\n"  if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
895

896
897
    }
    $sth->finish;
898
899
900

}

Francesc Guasch's avatar
Francesc Guasch committed
901
=head2 process_long_requests
902
903
904
905
906
907
908
909
910
911
912

Process requests that take log time. It will fork on each one

=cut

sub process_long_requests {
    my $self = shift;
    my ($debug,$dont_fork) = @_;

    $self->_disconnect_vm();
    return $self->process_requests($debug, $dont_fork, 1);
913
914
}

915
916
917
918
919
920
921
922
923
924
925
926
927
=head2 process_all_requests

Process all the requests, long and short

=cut

sub process_all_requests {

    my $self = shift;
    my ($debug,$dont_fork) = @_;

    $self->process_requests($debug, $dont_fork,1,1);

928
929
}

930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
sub _domain_working {
    my $self = shift;
    my ($id_domain, $id_request) = @_;

    confess "Missing id_request" if !defined$id_request;

    if (!$id_domain) {
        my $req = Ravada::Request->open($id_request);
        $id_domain = $req->defined_arg('id_base');
        if (!$id_domain) {
            my $domain_name = $req->defined_arg('name');
            return if !$domain_name;
            my $domain = $self->search_domain($domain_name) or return;
            $id_domain = $domain->id;
            if (!$id_domain) {
                warn Dumper($req);
                return;
            }
        }
    }
    my $sth = $CONNECTOR->dbh->prepare("SELECT id, status FROM requests "
        ." WHERE id <> ? AND id_domain=? AND (status <> 'requested' AND status <> 'done')");
    $sth->execute($id_request, $id_domain);
    my ($id, $status) = $sth->fetchrow;
#    warn "CHECKING DOMAIN WORKING "
#        ."[$id_request] id_domain $id_domain working in request ".($id or '<NULL>')
#            ." status: ".($status or '<UNDEF>');
    return $id;
}

960
961
962
963
964
965
966
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

    return $self->process_requests($debug,1, 1, 1);
}

967
968
sub _process_requests_dont_fork {
    my $self = shift;
969
    my $debug = shift;
970
    return $self->process_requests($debug, 1);
971
}
Francesc Guasch's avatar
Francesc Guasch committed
972

973
974
975
976
977
978
979
980
=head2 list_vm_types

Returnsa list ofthe types of Virtual Machines available on this system

=cut

sub list_vm_types {
    my $self = shift;
joansp's avatar
joansp committed
981

982
983
984
985
986
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
987
    return keys %type;
988
989
}

990
991
992
sub _execute {
    my $self = shift;
    my $request = shift;
993
    my $dont_fork = shift;
994

Francesc Guasch's avatar
Francesc Guasch committed
995
996
    my $sub = $self->_req_method($request->command);

997
998
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
999

1000
    if ($dont_fork || !$CAN_FORK || !$LONG_COMMAND{$request->command}) {
Francesc Guasch's avatar
Francesc Guasch committed
1001

1002
1003
1004
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
1005
        $request->status('done') if $request->status() ne 'done';
1006
1007
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
1008

1009
1010
1011
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

1012
    $request->status('working');
1013
1014
    my $pid = fork();
    die "I can't fork" if !defined $pid;
1015
1016
1017
1018
1019
    if ( $pid == 0 ) {
        $self->_do_execute_command($sub, $request) 
    } else {
        $self->_add_pid($pid, $request->id);
    }
1020
#    $self->_connect_vm_kvm();
1021
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
1022
1023
}

1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
sub _do_execute_command {
    my $self = shift;
    my ($sub, $request) = @_;

#    if ($DEBUG ) {
#        mkdir 'log' if ! -e 'log';
#        open my $f_out ,'>', "log/fork_$$.out";
#        open my $f_err ,'>', "log/fork_$$.err";
#        $| = 1;
#        local *STDOUT = $f_out;
#        local *STDERR = $f_err;
#    }

    eval {
        $self->_connect_vm();
        $sub->($self,$request);
        $self->_disconnect_vm();
    };
    my $err = ( $@ or '');
    $request->error($err);
    $request->status('done') if $request->status() ne 'done';
    exit;

}

1049
1050
1051
1052
1053
1054
1055
sub _cmd_domdisplay {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
    confess "Unknown name for request ".Dumper($request)  if!$name;
    my $domain = $self->search_domain($request->args->{name});
1056
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
1057
    $request->error('');
1058
    my $display = $domain->display($user);
1059
1060
    $request->result({display => $display});

1061
1062
}

1063
1064
1065
1066
1067
1068
sub _cmd_screenshot {
    my $self = shift;
    my $request = shift;

    my $id_domain = $request->args('id_domain');
    my $domain = $self->search_domain_by_id($id_domain);
1069
    my $bytes = 0;
1070
    if (!$domain->can_screenshot) {
1071
        die "I can't take a screenshot of the domain ".$domain->name;
1072
    } else {
1073
1074
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
1075
    }
1076
    $request->error("No data received") if !$bytes;
1077
1078
1079
}


1080
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
1081
1082
1083
    my $self = shift;
    my $request = shift;

1084
    $request->status('creating domain');
1085
    warn "$$ creating domain"   if $DEBUG;
1086
    my $domain;
1087

1088
    $domain = $self->create_domain(%{$request->args},request => $request);
1089

1090
    my $msg = '';
1091

1092
    if ($domain) {
1093
       $msg = 'Domain '
1094
1095
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
1096
            ." created."
1097
1098
1099
1100
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
1101
1102
1103

}

1104
1105
1106
1107
1108
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
1109
    for ( 1 .. $SECONDS_WAIT_CHILDREN ) {
1110
1111
        my $n_pids = scalar keys %{$self->{pids}};

1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
        my $msg;
        if ($HUGE_COMMAND{$req->command}) {
            if ( $n_pids < $LIMIT_HUGE_PROCESS) {
                $msg = $req->id." ".$req->command
                ." waiting for processes to finish $n_pids"
                ." of $LIMIT_HUGE_PROCESS ";
                warn $msg if $DEBUG;
                return;
            }
        } elsif ( $n_pids < $LIMIT_PROCESS) {
            $msg = $req->id." ".$req->command
                ." waiting for processes to finish $n_pids"
                ." of $LIMIT_PROCESS ";
            warn $msg if $DEBUG;
            return;
        }
1128
1129
1130
        $self->_wait_pids_nohang();
        sleep 1;

1131
1132
1133
        next if $try++;

        $req->error($msg);
1134
        $req->status('waiting') if $req->status() !~ 'waiting';
1135
    }
1136
    return scalar keys %{$self->{pids}};
1137
1138
}

1139
1140
1141
1142
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

Francesc Guasch's avatar
Francesc Guasch committed
1143
1144
1145
1146
    for my $pid ( keys %{$self->{pids}}) {
        my $kid = waitpid($pid , WNOHANG);
        next if !$kid || $kid == -1;
        $self->_set_req_done($kid);
1147
        $self->_delete_pid($kid);
Francesc Guasch's avatar
Francesc Guasch committed
1148
    }
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160

}

sub _set_req_done {
    my $self = shift;
    my $pid = shift;

    my $id_request = $self->{pids}->{$pid};
    return if !$id_request;

    my $req = Ravada::Request->open($id_request);
    $req->status('done')    if $req->status =~ /working/i;
1161
1162
}

Francesc Guasch's avatar
Francesc Guasch committed
1163
1164
1165
1166
sub _wait_pids {
    my $self = shift;
    my $request = shift;

1167
1168
    $request->status('waiting for other tasks')
        if $request && $request->status !~ /waiting/i;
Francesc Guasch's avatar
Francesc Guasch committed
1169

Francesc Guasch's avatar
Francesc Guasch committed
1170
    for my $pid ( keys %{$self->{pids}}) {
1171
1172
        $request->status("waiting for pid $pid")
            if $request && $request->status !~ /waiting/i;
1173
1174

#        warn "Checking for pid '$pid' created at ".localtime($self->{pids}->{$pid});
Francesc Guasch's avatar
Francesc Guasch committed
1175
        my $kid = waitpid($pid,0);
1176
#        warn "Found $kid";
1177
1178
        $self->_set_req_done($pid);

1179
        $self->_delete_pid($kid);
Francesc Guasch's avatar
Francesc Guasch committed
1180
1181
1182
1183
1184
1185
1186
        return if $kid  == $pid;
    }
}

sub _add_pid {
    my $self = shift;
    my $pid = shift;
1187
    my $id_req = shift;
Francesc Guasch's avatar
Francesc Guasch committed
1188

1189
    $self->{pids}->{$pid} = $id_req;
1190
1191
1192
1193
1194
1195
1196
1197

}

sub _delete_pid {
    my $self = shift;
    my $pid = shift;

    delete $self->{pids}->{$pid};
Francesc Guasch's avatar
Francesc Guasch committed
1198
1199
}

1200
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
1201
1202
1203
    my