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

use warnings;
use strict;

6
our $VERSION = '0.2.6_rc6';
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
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

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

313
314
sub _upgrade_tables {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
315
#    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;
316

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

319
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
320
321
    $self->_upgrade_table('vms','connection_args',"text DEFAULT NULL");

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

324
    $self->_upgrade_table('iso_images','md5_url','varchar(255)');
Francesc Guasch's avatar
Francesc Guasch committed
325
326
    $self->_upgrade_table('iso_images','sha256','varchar(255)');
    $self->_upgrade_table('iso_images','sha256_url','varchar(255)');
327
    $self->_upgrade_table('iso_images','file_re','char(64)');
328
    $self->_upgrade_table('iso_images','device','varchar(255)');
329
330

    $self->_upgrade_table('users','language','char(3) DEFAULT NULL');
331
332
333
334
335
336
    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
337

338
    $self->_upgrade_table('networks','requires_password','int(11)');
339
340
    $self->_upgrade_table('networks','n_order','int(11) not null default 0');

341
    $self->_upgrade_table('domains','spice_password','varchar(20) DEFAULT NULL');
342
343
}

344

345
346
347
348
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
349
350
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
351
352
353
354
355
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

356
=head2 display_ip
357

358
Returns the default display IP read from the config file
359

360
=cut
361

362
sub display_ip {
363

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

366
    return $ip if $ip;
367
368
}

369
370
sub _init_config {
    my $file = shift;
371
372

    my $connector = shift;
373
    confess "Deprecated connector" if $connector;
374

375
    $CONFIG = YAML::LoadFile($file);
376
377
378

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
379
#    $CONNECTOR = ( $connector or _connect_dbh());
380
381
}

382
sub _create_vm_kvm {
383
    my $self = shift;
384

385
386
387
388
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
391

392
393
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
394
395
396
397

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

405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
=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 {
423
    my $self = shift;
424
425
426
427

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

428
429
    my @vms;
    eval { @vms = $self->vm };
430
    warn $@ if $@ && $self->warn_error;
431
432
433
434
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
435
436
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
437
438
439

        if (!$connect) {
            $vm->disconnect();
440
441
        } else {
            $vm->connect();
442
        }
443
444
445
    }
}

446
447
448
449
450
451
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

454
455
    my $err = $err_kvm;

456
457
458
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
459
460
461
462
463
464
    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;
    }
465
    if (!@vms) {
466
        warn "No VMs found: $err\n" if $self->warn_error;
467
468
469
    }
    return \@vms;

470
471
}

472
sub _check_vms {
473
474
    my $self = shift;

475
476
    my @vm;
    eval { @vm = @{$self->vm} };
477
478
479
480
481
482
483
484
485
486
    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
487
488
489
490
=head2 create_domain

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

joansp's avatar
joansp committed
491
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
492
493
494
495
496
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
497
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
498
499
500
501
502
503
504
505
         name => $name
    , id_base => 3
  );


=cut


506
sub create_domain {
507
508
    my $self = shift;

509
510
    my %args = @_;

511
512
513
    croak "Argument id_owner required "
        if !$args{id_owner};

514
515
    my $vm_name = $args{vm};
    delete $args{vm};
516

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

519
    my $vm;
520
521
522
523
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
524
    $vm = $self->vm->[0]               if !$vm;
525

526
527
    confess "No vm found"   if !$vm;

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

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

533
    return $vm->create_domain(@_);
534
535
}

Francesc Guasch's avatar
Francesc Guasch committed
536
537
538
539
540
541
542
543
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

544
545
sub remove_domain {
    my $self = shift;
546
547
    my %arg = @_;

548
    confess "Argument name required "
549
550
        if !$arg{name};

551
552
    confess "Argument uid required "
        if !$arg{uid};
553
554
555
556

    lock_hash(%arg);

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

559
560
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
561
562
}

Francesc Guasch's avatar
Francesc Guasch committed
563
564
565
566
567
568
=head2 search_domain

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

=cut

569
570
571
sub search_domain {
    my $self = shift;
    my $name = shift;
572
    my $import = shift;
573

574
575
576
577
578
579
580
581
582
583
584
585
    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 $@;

586
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
587
        my $domain = $vm->search_domain($name, $import);
588
        next if !$domain;
589
        next if !$domain->_select_domain_db && !$import;
590
591
592
        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
593
        warn $@ if $@   && $DEBUG;
594
        return $domain if $id || $import;
595
    }
596
597


598
    return;
599
}
600

Francesc Guasch's avatar
Francesc Guasch committed
601
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
602

Francesc Guasch's avatar
Francesc Guasch committed
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
  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
618

619
620
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
621
List all created domains
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637

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

638
639
640
641
642
643
644
645
646
647
648
649
650
=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;
651
652
653
654
655
656
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
657
    }
658
    $sth->finish;
659
    return \@domains;
660
661
}

662
663
664
665
666
667
668
# 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
669
#         push @domains, {                id => $domain->id
670
671
672
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
673

674
675
676
677
678
#                            }
#     }
#     return \@domains;
# }

679

Francesc Guasch's avatar
Francesc Guasch committed
680
681
682
683
684
685
686
687
688
689
690
691
692
693
=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) {
694
695
696
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
697
698
699
700
701
702
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
=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
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
=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;
}

738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
=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
753

754
755
756
=pod

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

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

779
=cut
fv3rdugo's avatar
fv3rdugo committed
780

Francesc Guasch's avatar
Francesc Guasch committed
781
782
783
784
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
785

Francesc Guasch's avatar
Francesc Guasch committed
786
787
=cut

788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
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";
    }

}
808

809
810
811
812
813
814
815
816
817
=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 "
818
        ." WHERE status <> 'done' AND STATUS <> 'requested'"
819
820
821
822
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
823
        $req->status("done","Killed ".$req->command." before completion");
824
825
826
827
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
828
829
830
831
832
833
834
835
=head2 process_requests

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

  $ravada->process_requests();

=cut

836
837
sub process_requests {
    my $self = shift;
838
    my $debug = shift;
839
    my $dont_fork = shift;
840
841
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
842

843
844
    $self->_wait_pids_nohang();

845
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
846
847
848
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
849
850
        ." ORDER BY date_req"
    );
851
852
853
854
855
856
857
    $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;

858
859
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
860
861
862
863
864
865
866
867
868

        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;
        }
869
870
        next if $req->command !~ /shutdown/i
            && $self->_domain_working($id_domain, $id_request);
871

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

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
878
879
880
        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
881
            if ( $n_retry < 3) {
882
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
883
                $req->status("retry ".++$n_retry)
884
            }
885
        }
886
887
888
        next if !$DEBUG && !$debug;

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

892
893
    }
    $sth->finish;
894
895
896

}

Francesc Guasch's avatar
Francesc Guasch committed
897
=head2 process_long_requests
898
899
900
901
902
903
904
905
906
907
908

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);
909
910
}

911
912
913
914
915
916
917
918
919
920
921
922
923
=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);

924
925
}

926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
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;
}

956
957
958
959
960
961
962
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

963
964
sub _process_requests_dont_fork {
    my $self = shift;
965
    my $debug = shift;
966
    return $self->process_requests($debug, 1);
967
}
Francesc Guasch's avatar
Francesc Guasch committed
968

969
970
971
972
973
974
975
976
=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
977

978
979
980
981
982
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
983
    return keys %type;
984
985
}

986
987
988
sub _execute {
    my $self = shift;
    my $request = shift;
989
    my $dont_fork = shift;
990

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

993
994
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
995

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

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

1005
1006
1007
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

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

1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
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;

}

1045
1046
1047
1048
1049
1050
1051
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});
1052
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
1053
    $request->error('');
1054
    my $display = $domain->display($user);
1055
1056
    $request->result({display => $display});

1057
1058
}

1059
1060
1061
1062
1063
1064
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);
1065
    my $bytes = 0;
1066
    if (!$domain->can_screenshot) {
1067
        die "I can't take a screenshot of the domain ".$domain->name;
1068
    } else {
1069
1070
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
1071
    }
1072
    $request->error("No data received") if !$bytes;
1073
1074
1075
}


1076
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
1077
1078
1079
    my $self = shift;
    my $request = shift;

1080
    $request->status('creating domain');
1081
    warn "$$ creating domain"   if $DEBUG;
1082
    my $domain;
1083

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

1086
    my $msg = '';
1087

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

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
1097
1098
1099

}

1100
1101
1102
1103
1104
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
1105
    for ( 1 .. $SECONDS_WAIT_CHILDREN ) {
1106
1107
        my $n_pids = scalar keys %{$self->{pids}};

1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
        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;
        }
1124
1125
1126
        $self->_wait_pids_nohang();
        sleep 1;

1127
1128
1129
        next if $try++;

        $req->error($msg);
1130
        $req->status('waiting') if $req->status() !~ 'waiting';
1131
    }
1132
    return scalar keys %{$self->{pids}};
1133
1134
}

1135
1136
1137
1138
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

}

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;
1157
1158
}

Francesc Guasch's avatar
Francesc Guasch committed
1159
1160
1161
1162
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

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

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

1175
        $self->_delete_pid($kid);
Francesc Guasch's avatar
Francesc Guasch committed
1176
1177
1178
1179
1180
1181
1182
        return if $kid  == $pid;
    }
}

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

1185
    $self->{pids}->{$pid} = $id_req;
1186
1187
1188
1189
1190
1191
1192
1193

}

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

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

1196
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
1197
1198
1199
    my $self = shift;
    my $request = shift;

1200
1201
1202
1203
    confess "Unknown user id ".$request->args->{uid}
        if !defined $request->args->{uid};

    $self->remove_domain(name => $request->args('name'), uid => $request->args('uid'));
Francesc Guasch's avatar
Francesc Guasch committed
1204