Ravada.pm 37.7 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';
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
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
354
355
356
357
358
359
360
    my $host = $CONFIG->{db}->{host};

    my $data_source = "DBI:$driver:$db";
    $data_source = "DBI:$driver:database=$db;host=$host"    
        if $host && $host ne 'localhost';

    return DBIx::Connector->new($data_source
361
362
363
364
365
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

366
=head2 display_ip
367

368
Returns the default display IP read from the config file
369

370
=cut
371

372
sub display_ip {
373

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

376
    return $ip if $ip;
377
378
}

379
380
sub _init_config {
    my $file = shift;
381
382

    my $connector = shift;
383
    confess "Deprecated connector" if $connector;
384

385
    $CONFIG = YAML::LoadFile($file);
386
387
388

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
389
#    $CONNECTOR = ( $connector or _connect_dbh());
390
391
}

392
sub _create_vm_kvm {
393
    my $self = shift;
394

395
396
397
398
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
401

402
403
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
404
405
406
407

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
408
        $internal_vm = $vm_kvm->vm;
409
410
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
411
412
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
413
414
}

415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
=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 {
433
    my $self = shift;
434
435
436
437

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

438
439
    my @vms;
    eval { @vms = $self->vm };
440
    warn $@ if $@ && $self->warn_error;
441
442
443
444
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
445
446
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
447
448
449

        if (!$connect) {
            $vm->disconnect();
450
451
        } else {
            $vm->connect();
452
        }
453
454
455
    }
}

456
457
458
459
460
461
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

464
465
    my $err = $err_kvm;

466
467
468
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
469
470
471
472
473
474
    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;
    }
475
    if (!@vms) {
476
        warn "No VMs found: $err\n" if $self->warn_error;
477
478
479
    }
    return \@vms;

480
481
}

482
sub _check_vms {
483
484
    my $self = shift;

485
486
    my @vm;
    eval { @vm = @{$self->vm} };
487
488
489
490
491
492
493
494
495
496
    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
497
498
499
500
=head2 create_domain

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

joansp's avatar
joansp committed
501
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
502
503
504
505
506
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
507
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
508
509
510
511
512
513
514
515
         name => $name
    , id_base => 3
  );


=cut


516
sub create_domain {
517
518
    my $self = shift;

519
520
    my %args = @_;

521
522
523
    croak "Argument id_owner required "
        if !$args{id_owner};

524
525
    my $vm_name = $args{vm};
    delete $args{vm};
526

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

529
    my $vm;
530
531
532
533
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
534
    $vm = $self->vm->[0]               if !$vm;
535

536
537
    confess "No vm found"   if !$vm;

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

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

543
    return $vm->create_domain(@_);
544
545
}

Francesc Guasch's avatar
Francesc Guasch committed
546
547
548
549
550
551
552
553
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

554
555
sub remove_domain {
    my $self = shift;
556
557
    my %arg = @_;

558
    confess "Argument name required "
559
560
        if !$arg{name};

561
562
    confess "Argument uid required "
        if !$arg{uid};
563
564
565
566

    lock_hash(%arg);

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

569
570
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
571
572
}

Francesc Guasch's avatar
Francesc Guasch committed
573
574
575
576
577
578
=head2 search_domain

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

=cut

579
580
581
sub search_domain {
    my $self = shift;
    my $name = shift;
582
    my $import = shift;
583

584
585
586
587
588
589
590
591
592
593
594
595
    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 $@;

596
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
597
        my $domain = $vm->search_domain($name, $import);
598
        next if !$domain;
599
        next if !$domain->_select_domain_db && !$import;
600
601
602
        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
603
        warn $@ if $@   && $DEBUG;
604
        return $domain if $id || $import;
605
    }
606
607


608
    return;
609
}
610

Francesc Guasch's avatar
Francesc Guasch committed
611
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
612

Francesc Guasch's avatar
Francesc Guasch committed
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
  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
628

629
630
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
631
List all created domains
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647

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

648
649
650
651
652
653
654
655
656
657
658
659
660
=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;
661
662
663
664
665
666
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
667
    }
668
    $sth->finish;
669
    return \@domains;
670
671
}

672
673
674
675
676
677
678
# 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
679
#         push @domains, {                id => $domain->id
680
681
682
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
683

684
685
686
687
688
#                            }
#     }
#     return \@domains;
# }

689

Francesc Guasch's avatar
Francesc Guasch committed
690
691
692
693
694
695
696
697
698
699
700
701
702
703
=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) {
704
705
706
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
707
708
709
710
711
712
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
=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
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
=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;
}

748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
=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
763

764
765
766
=pod

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

780
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
781
782
783
784
785
786
787
788
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

789
=cut
fv3rdugo's avatar
fv3rdugo committed
790

Francesc Guasch's avatar
Francesc Guasch committed
791
792
793
794
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
795

Francesc Guasch's avatar
Francesc Guasch committed
796
797
=cut

798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
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";
    }

}
818

819
820
821
822
823
824
825
826
827
=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 "
828
        ." WHERE status <> 'done' AND STATUS <> 'requested'"
829
830
831
832
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
833
        $req->status("done","Killed ".$req->command." before completion");
834
835
836
837
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
838
839
840
841
842
843
844
845
=head2 process_requests

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

  $ravada->process_requests();

=cut

846
847
sub process_requests {
    my $self = shift;
848
    my $debug = shift;
849
    my $dont_fork = shift;
850
851
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
852

853
854
    $self->_wait_pids_nohang();

855
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
856
857
858
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
859
860
        ." ORDER BY date_req"
    );
861
862
863
864
865
866
867
    $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;

868
869
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
870
871
872
873
874
875
876
877
878

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

882
883
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
884
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
885
886
887

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
888
889
890
        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
891
            if ( $n_retry < 3) {
892
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
893
                $req->status("retry ".++$n_retry)
894
            }
895
        }
896
897
898
        next if !$DEBUG && !$debug;

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

902
903
    }
    $sth->finish;
904
905
906

}

Francesc Guasch's avatar
Francesc Guasch committed
907
=head2 process_long_requests
908
909
910
911
912
913
914
915
916
917
918

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);
919
920
}

921
922
923
924
925
926
927
928
929
930
931
932
933
=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);

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
960
961
962
963
964
965
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;
}

966
967
968
969
970
971
972
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

973
974
sub _process_requests_dont_fork {
    my $self = shift;
975
    my $debug = shift;
976
    return $self->process_requests($debug, 1);
977
}
Francesc Guasch's avatar
Francesc Guasch committed
978

979
980
981
982
983
984
985
986
=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
987

988
989
990
991
992
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
993
    return keys %type;
994
995
}

996
997
998
sub _execute {
    my $self = shift;
    my $request = shift;
999
    my $dont_fork = shift;
1000

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

1003
1004
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
1005

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

1008
1009
1010
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
1011
        $request->status('done') if $request->status() ne 'done';
1012
1013
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
1014

1015
1016
1017
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

1018
    $request->status('working');
1019
1020
    my $pid = fork();
    die "I can't fork" if !defined $pid;
1021
1022
1023
1024
1025
    if ( $pid == 0 ) {
        $self->_do_execute_command($sub, $request) 
    } else {
        $self->_add_pid($pid, $request->id);
    }
1026
#    $self->_connect_vm_kvm();
1027
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
1028
1029
}

1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
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;

}

1055
1056
1057
1058
1059
1060
1061
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});
1062
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
1063
    $request->error('');
1064
    my $display = $domain->display($user);
1065
1066
    $request->result({display => $display});

1067
1068
}

1069
1070
1071
1072
1073
1074
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);
1075
    my $bytes = 0;
1076
    if (!$domain->can_screenshot) {
1077
        die "I can't take a screenshot of the domain ".$domain->name;
1078
    } else {
1079
1080
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
1081
    }
1082
    $request->error("No data received") if !$bytes;
1083
1084
1085
}


1086
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
1087
1088
1089
    my $self = shift;
    my $request = shift;

1090
    $request->status('creating domain');
1091
    warn "$$ creating domain"   if $DEBUG;
1092
    my $domain;
1093

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

1096
    my $msg = '';
1097

1098
    if ($domain) {
1099
       $msg = 'Domain '
1100
1101
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
1102
            ." created."
1103
1104
1105
1106
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
1107
1108
1109

}

1110
1111
1112
1113
1114
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
1115
    for ( 1 .. $SECONDS_WAIT_CHILDREN ) {
1116
1117
        my $n_pids = scalar keys %{$self->{pids}};

1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
        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;
        }
1134
1135
1136
        $self->_wait_pids_nohang();
        sleep 1;

1137
1138
1139
        next if $try++;

        $req->error($msg);
1140
        $req->status('waiting') if $req->status() !~ 'waiting';
1141
    }
1142
    return scalar keys %{$self->{pids}};
1143
1144
}

1145
1146
1147
1148
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

Francesc Guasch's avatar
Francesc Guasch committed
1149
1150
1151
1152
    for my $pid ( keys %{$self->{pids}}) {
        my $kid = waitpid($pid , WNOHANG);
        next if !$kid || $kid == -1;
        $self->_set_req_done($kid);
1153
        $self->_delete_pid($kid);
Francesc Guasch's avatar
Francesc Guasch committed
1154
    }
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166

}

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

Francesc Guasch's avatar
Francesc Guasch committed
1169
1170
1171
1172
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
1176
    for my $pid ( keys %{$self->{pids}}) {
1177
1178
        $request->status("waiting for pid $pid")
            if $request && $request->status !~ /waiting/i;
1179
1180

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

1185
        $self->_delete_pid($kid);
Francesc Guasch's avatar
Francesc Guasch committed
1186
1187
1188
1189
1190
1191
1192
        return if $kid  == $pid;
    }
}

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

1195
    $self->{pids}->{$pid} = $id_req;
1196
1197
1198
1199
1200
1201
1202
1203

}

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

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