Ravada.pm 33.8 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.5';
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
62
63
64
65
66

has 'vm' => (
          is => 'ro'
        ,isa => 'ArrayRef'
       ,lazy => 1
     , builder => '_create_vm'
);

has 'connector' => (
67
68
69
70
71
72
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
73
74
);

75
76
77
78
79
80
has 'warn_error' => (
    is => 'rw'
    ,isa => 'Bool'
    ,default => sub { 1 }
);

Francesc Guasch's avatar
Francesc Guasch committed
81
82
83
84
85
86
87
=head2 BUILD

Internal constructor

=cut


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

Francesc Guasch's avatar
Francesc Guasch committed
96
    if ( $self->connector ) {
joansp's avatar
joansp committed
97
        $CONNECTOR = $self->connector
Francesc Guasch's avatar
Francesc Guasch committed
98
99
    } else {
        $CONNECTOR = $self->_connect_dbh();
100
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
101
    }
Francesc Guasch's avatar
Francesc Guasch committed
102
    Ravada::Auth::init($CONFIG);
103
    $self->_create_tables();
104
    $self->_upgrade_tables();
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
    $self->_update_data();
}

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
123
124
125
126
127
128
129
130
131
132
133
134
135
        ,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'

        }

136
137
138
139
140
141
142
143
    );

    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
144
        warn("INFO: updating $table : $row->{$field}\n")    if $0 !~ /\.t$/;
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

        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;
    $self->_update_isos();
164
165
}

166
167
168
169
170
171
172
173
174
175
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
176
    warn "INFO: adding $field $definition to $table\n"  if $0 !~ /\.t$/;
177
    $dbh->do("alter table $table add $field $definition");
178
    return 1;
179
180
}

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
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;
222
223
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

224
225
226
227
228
229
230
231
232
    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;
}

233
234
sub _upgrade_tables {
    my $self = shift;
235
236
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

237
    $self->_upgrade_table('file_base_images','target','varchar(64) DEFAULT NULL');
238
239
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
    $self->_upgrade_table('requests','at_time','int(11) DEFAULT NULL');
Francesc Guasch's avatar
Francesc Guasch committed
240

241
242
    $self->_upgrade_table('iso_images','md5_url','varchar(255)');
    $self->_upgrade_table('iso_images','file_re','char(64)');
243
    $self->_upgrade_table('iso_images','device','varchar(255)');
244
245

    $self->_upgrade_table('users','language','char(3) DEFAULT NULL');
246
247
248
249
250
251
    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
252

253
    $self->_upgrade_table('networks','requires_password','int(11)');
254
255
    $self->_upgrade_table('networks','n_order','int(11) not null default 0');

256
    $self->_upgrade_table('domains','spice_password','varchar(20) DEFAULT NULL');
257
258
}

259

260
261
262
263
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
264
265
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
266
267
268
269
270
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

271
=head2 display_ip
272

273
Returns the default display IP read from the config file
274

275
=cut
276

277
sub display_ip {
278

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

281
    return $ip if $ip;
282
283
}

284
285
sub _init_config {
    my $file = shift;
286
287

    my $connector = shift;
288
    confess "Deprecated connector" if $connector;
289

290
    $CONFIG = YAML::LoadFile($file);
291
292
293

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
294
#    $CONNECTOR = ( $connector or _connect_dbh());
295
296
}

297
sub _create_vm_kvm {
298
    my $self = shift;
299

300
301
302
303
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
306

307
308
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
309
310
311
312

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
313
        $internal_vm = $vm_kvm->vm;
314
315
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
316
317
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
318
319
}

320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
=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 {
338
    my $self = shift;
339
340
341
342

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

343
344
    my @vms;
    eval { @vms = $self->vm };
345
    warn $@ if $@ && $self->warn_error;
346
347
348
349
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
350
351
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
352
353
354

        if (!$connect) {
            $vm->disconnect();
355
356
        } else {
            $vm->connect();
357
        }
358
359
360
    }
}

361
362
363
364
365
366
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

369
370
    my $err = $err_kvm;

371
372
373
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
374
375
376
377
378
379
    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;
    }
380
    if (!@vms) {
381
        warn "No VMs found: $err\n" if $self->warn_error;
382
383
384
    }
    return \@vms;

385
386
}

387
sub _check_vms {
388
389
    my $self = shift;

390
391
    my @vm;
    eval { @vm = @{$self->vm} };
392
393
394
395
396
397
398
399
400
401
    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
402
403
404
405
=head2 create_domain

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

joansp's avatar
joansp committed
406
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
407
408
409
410
411
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
412
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
413
414
415
416
417
418
419
420
         name => $name
    , id_base => 3
  );


=cut


421
sub create_domain {
422
423
    my $self = shift;

424
425
    my %args = @_;

426
427
428
    croak "Argument id_owner required "
        if !$args{id_owner};

429
430
    my $vm_name = $args{vm};
    delete $args{vm};
431

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

434
    my $vm;
435
436
437
438
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
439
    $vm = $self->vm->[0]               if !$vm;
440

441
442
    confess "No vm found"   if !$vm;

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

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

448
    return $vm->create_domain(@_);
449
450
}

Francesc Guasch's avatar
Francesc Guasch committed
451
452
453
454
455
456
457
458
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

459
460
sub remove_domain {
    my $self = shift;
461
462
    my %arg = @_;

463
    confess "Argument name required "
464
465
        if !$arg{name};

466
467
    confess "Argument uid required "
        if !$arg{uid};
468
469
470
471

    lock_hash(%arg);

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

474
475
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
476
477
}

Francesc Guasch's avatar
Francesc Guasch committed
478
479
480
481
482
483
=head2 search_domain

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

=cut

484
485
486
sub search_domain {
    my $self = shift;
    my $name = shift;
487
    my $import = shift;
488

489
490
491
492
493
494
495
496
497
498
499
500
    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 $@;

501
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
502
        my $domain = $vm->search_domain($name, $import);
503
        next if !$domain;
504
        next if !$domain->_select_domain_db && !$import;
505
506
507
        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
508
        warn $@ if $@   && $DEBUG;
509
        return $domain if $id || $import;
510
    }
511
512


513
    return;
514
}
515

Francesc Guasch's avatar
Francesc Guasch committed
516
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
517

Francesc Guasch's avatar
Francesc Guasch committed
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
  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
533

534
535
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
536
List all created domains
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552

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

553
554
555
556
557
558
559
560
561
562
563
564
565
=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;
566
567
568
569
570
571
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
572
    }
573
    $sth->finish;
574
    return \@domains;
575
576
}

577
578
579
580
581
582
583
# 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
584
#         push @domains, {                id => $domain->id
585
586
587
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
588

589
590
591
592
593
#                            }
#     }
#     return \@domains;
# }

594

Francesc Guasch's avatar
Francesc Guasch committed
595
596
597
598
599
600
601
602
603
604
605
606
607
608
=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) {
609
610
611
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
612
613
614
615
616
617
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
=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
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
=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;
}

653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
=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
668

669
670
671
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
672
673
674
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
675
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
676
677
678
679
680
681
682
683
684
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

685
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
686
687
688
689
690
691
692
693
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

694
=cut
fv3rdugo's avatar
fv3rdugo committed
695

Francesc Guasch's avatar
Francesc Guasch committed
696
697
698
699
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
700

Francesc Guasch's avatar
Francesc Guasch committed
701
702
=cut

703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
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";
    }

}
723

724
725
726
727
728
729
730
731
732
=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 "
733
        ." WHERE status <> 'done' AND STATUS <> 'requested'"
734
735
736
737
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
738
        $req->status("done","Killed ".$req->command." before completion");
739
740
741
742
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
743
744
745
746
747
748
749
750
=head2 process_requests

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

  $ravada->process_requests();

=cut

751
752
sub process_requests {
    my $self = shift;
753
    my $debug = shift;
754
    my $dont_fork = shift;
755
756
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
757

758
759
    $self->_wait_pids_nohang();

760
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
761
762
763
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
764
765
        ." ORDER BY date_req"
    );
766
767
768
769
770
771
772
    $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;

773
774
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
775
776
777
778
779
780
781
782
783

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

787
788
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
789
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
790
791
792

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
793
794
795
        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
796
            if ( $n_retry < 3) {
797
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
798
                $req->status("retry ".++$n_retry)
799
            }
800
        }
801
802
803
        next if !$DEBUG && !$debug;

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

807
808
    }
    $sth->finish;
809
810
811

}

Francesc Guasch's avatar
Francesc Guasch committed
812
=head2 process_long_requests
813
814
815
816
817
818
819
820
821
822
823

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);
824
825
}

826
827
828
829
830
831
832
833
834
835
836
837
838
=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);

839
840
}

841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
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;
}

871
872
873
874
875
876
877
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

878
879
sub _process_requests_dont_fork {
    my $self = shift;
880
    my $debug = shift;
881
    return $self->process_requests($debug, 1);
882
}
Francesc Guasch's avatar
Francesc Guasch committed
883

884
885
886
887
888
889
890
891
=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
892

893
894
895
896
897
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
898
    return keys %type;
899
900
}

901
902
903
sub _execute {
    my $self = shift;
    my $request = shift;
904
    my $dont_fork = shift;
905

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

908
909
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
910

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

913
914
915
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
916
        $request->status('done') if $request->status() ne 'done';
917
918
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
919

920
921
922
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

923
    $request->status('working');
924
925
    my $pid = fork();
    die "I can't fork" if !defined $pid;
926
927
928
929
930
    if ( $pid == 0 ) {
        $self->_do_execute_command($sub, $request) 
    } else {
        $self->_add_pid($pid, $request->id);
    }
931
#    $self->_connect_vm_kvm();
932
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
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 _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;

}

960
961
962
963
964
965
966
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});
967
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
968
    $request->error('');
969
    my $display = $domain->display($user);
970
971
    $request->result({display => $display});

972
973
}

974
975
976
977
978
979
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);
980
    my $bytes = 0;
981
    if (!$domain->can_screenshot) {
982
        die "I can't take a screenshot of the domain ".$domain->name;
983
    } else {
984
985
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
986
    }
987
    $request->error("No data received") if !$bytes;
988
989
990
}


991
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
992
993
994
    my $self = shift;
    my $request = shift;

995
    $request->status('creating domain');
996
    warn "$$ creating domain"   if $DEBUG;
997
    my $domain;
998

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

1001
    my $msg = '';
1002

1003
    if ($domain) {
1004
       $msg = 'Domain '
1005
1006
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
1007
            ." created."
1008
1009
1010
1011
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
1012
1013
1014

}

1015
1016
1017
1018
1019
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
1020
    for ( 1 .. $SECONDS_WAIT_CHILDREN ) {
1021
1022
        my $n_pids = scalar keys %{$self->{pids}};

1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
        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;
        }
1039
1040
1041
        $self->_wait_pids_nohang();
        sleep 1;

1042
1043
1044
        next if $try++;

        $req->error($msg);
1045
        $req->status('waiting') if $req->status() !~ 'waiting';
1046
    }
1047
    return scalar keys %{$self->{pids}};
1048
1049
}

1050
1051
1052
1053
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

Francesc Guasch's avatar
Francesc Guasch committed
1054
1055
1056
1057
    for my $pid ( keys %{$self->{pids}}) {
        my $kid = waitpid($pid , WNOHANG);
        next if !$kid || $kid == -1;
        $self->_set_req_done($kid);
1058
        $self->_delete_pid($kid);
Francesc Guasch's avatar
Francesc Guasch committed
1059
    }
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071

}

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

Francesc Guasch's avatar
Francesc Guasch committed
1074
1075
1076
1077
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
1081
    for my $pid ( keys %{$self->{pids}}) {
1082
1083
        $request->status("waiting for pid $pid")
            if $request && $request->status !~ /waiting/i;
1084
1085

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

1090
        $self->_delete_pid($kid);
Francesc Guasch's avatar
Francesc Guasch committed
1091
1092
1093
1094
1095
1096
1097
        return if $kid  == $pid;
    }
}

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

1100
    $self->{pids}->{$pid} = $id_req;
1101
1102
1103
1104
1105
1106
1107
1108

}

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

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

1111
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
1112
1113
1114
    my $self = shift;
    my $request = shift;

1115
1116
1117
1118
    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
1119

1120
}
Francesc Guasch's avatar
Francesc Guasch committed
1121

1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
sub _cmd_pause {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

    $domain->pause($user);

    $request->status('done');

}

sub _cmd_resume {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

1150
1151
    $domain->resume(
        remote_ip => $request->args('remote_ip')
1152
        ,user => $user
1153
    );
1154
1155
1156
1157
1158
1159

    $request->status('done');

}


1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
sub _cmd_open_iptables {
    my $self = shift;
    my $request = shift;

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

    my $domain = $self->search_domain_by_id($request->args('id_domain'));
    die "Unknown domain" if !$domain;

    $domain->open_iptables(
        remote_ip => $request->args('remote_ip')
        ,uid => $user->id
    );
}

Francesc Guasch's avatar
Francesc Guasch committed
1176
1177
1178
1179
1180
sub _cmd_start {
    my $self = shift;
    my $request = shift;

    my $name = $request->args('name');
1181

1182
1183
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
1184
1185
1186
1187

    my $uid = $request->args('uid');
    my $user = Ravada::Auth::SQL->search_by_id($uid);

1188
    $domain->start(user => $user, remote_ip => $request->args('remote_ip'));
1189
1190
1191
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
1192
            ." started"
1193
1194
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
1195
1196
1197

}

Francesc Guasch's avatar
Francesc Guasch committed
1198
1199
1200
1201
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

Francesc Guasch's avatar
Francesc Guasch committed
1202
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
1203
1204
1205
1206
    my $uid = $request->args('uid')     or confess "Missing argument uid";

    my $user = Ravada::Auth::SQL->search_by_id( $uid);

Francesc Guasch's avatar
Francesc Guasch committed
1207
    my $domain = $self->search_domain_by_id($id_domain);
1208

Francesc Guasch's avatar
Francesc Guasch committed
1209
    die "Unknown domain id '$id_domain'\n" if !$domain;
1210
1211

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
1212
1213
1214

}

1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
sub _cmd_remove_base {
    my $self = shift;
    my $request = shift;

    my $id_domain = $request->id_domain or confess "Missing request id_domain";
    my $uid = $request->args('uid')     or confess "Missing argument uid";

    my $user = Ravada::Auth::SQL->search_by_id( $uid);