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

use warnings;
use strict;

6
our $VERSION = '0.2.2';
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
our $LIMIT_PROCESS = 2;
46
47
our $DIR_SQL = "sql/mysql";
$DIR_SQL = "/usr/share/doc/ravada/sql/mysql" if ! -e $DIR_SQL;
48

49
# LONG commands take long
Francesc Guasch's avatar
Francesc Guasch committed
50
our %LONG_COMMAND =  map { $_ => 1 } qw(prepare_base remove_base screenshot);
51
52
53
54
55
56
57
58
59

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

has 'connector' => (
60
61
62
63
64
65
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
66
67
);

Francesc Guasch's avatar
Francesc Guasch committed
68
69
70
71
72
73
74
=head2 BUILD

Internal constructor

=cut


75
76
sub BUILD {
    my $self = shift;
77
    if ($self->config()) {
78
        _init_config($self->config);
79
    } else {
Francesc Guasch's avatar
Francesc Guasch committed
80
        _init_config($FILE_CONFIG) if -e $FILE_CONFIG;
81
    }
82

Francesc Guasch's avatar
Francesc Guasch committed
83
    if ( $self->connector ) {
joansp's avatar
joansp committed
84
        $CONNECTOR = $self->connector
Francesc Guasch's avatar
Francesc Guasch committed
85
86
    } else {
        $CONNECTOR = $self->_connect_dbh();
87
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
88
    }
Francesc Guasch's avatar
Francesc Guasch committed
89
    Ravada::Auth::init($CONFIG);
90
    $self->_create_tables();
91
    $self->_upgrade_tables();
92
93
}

94
95
96
97
98
99
100
101
102
103
104
105
106
107
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;

    warn "INFO: adding $field $definition to $table\n";
    $dbh->do("alter table $table add $field $definition");
}

108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
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;
149
150
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

151
152
153
154
155
156
157
158
159
    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;
}

160
161
sub _upgrade_tables {
    my $self = shift;
162
163
    return if $CONNECTOR->dbh->{Driver}{Name} !~ /mysql/i;

164
    $self->_upgrade_table('file_base_images','target','varchar(64) DEFAULT NULL');
165
166
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
    $self->_upgrade_table('requests','at_time','int(11) DEFAULT NULL');
167
168
169
}


170
171
172
173
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
174
175
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
176
177
178
179
180
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

181
=head2 display_ip
182

183
Returns the default display IP read from the config file
184

185
=cut
186

187
sub display_ip {
188

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

191
    return $ip if $ip;
192
193
}

194
195
sub _init_config {
    my $file = shift;
196
197

    my $connector = shift;
198
    confess "Deprecated connector" if $connector;
199

200
    $CONFIG = YAML::LoadFile($file);
201
202
203

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
204
#    $CONNECTOR = ( $connector or _connect_dbh());
205
206
}

207
sub _create_vm_kvm {
208
    my $self = shift;
209

210
211
212
213
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
216

217
218
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
219
220
221
222

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
223
        $internal_vm = $vm_kvm->vm;
224
225
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
226
227
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
228
229
}

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
=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 {
248
    my $self = shift;
249
250
251
252

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

253
254
    my @vms;
    eval { @vms = $self->vm };
255
    warn $@ if $@;
256
257
258
259
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
260
261
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
262
263
264

        if (!$connect) {
            $vm->disconnect();
265
266
        } else {
            $vm->connect();
267
        }
268
269
270
    }
}

271
272
273
274
275
276
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

279
280
    my $err = $err_kvm;

281
282
283
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
284
285
286
287
288
289
    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;
    }
290
    if (!@vms) {
291
        warn "No VMs found: $err\n";
292
293
294
    }
    return \@vms;

295
296
}

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

300
301
    my @vm;
    eval { @vm = @{$self->vm} };
302
303
304
305
306
307
308
309
310
311
    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
312
313
314
315
=head2 create_domain

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

joansp's avatar
joansp committed
316
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
317
318
319
320
321
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
322
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
323
324
325
326
327
328
329
330
         name => $name
    , id_base => 3
  );


=cut


331
sub create_domain {
332
333
    my $self = shift;

334
335
    my %args = @_;

336
337
338
    croak "Argument id_owner required "
        if !$args{id_owner};

339
340
    my $vm_name = $args{vm};
    delete $args{vm};
341

Francesc Guasch's avatar
Francesc Guasch committed
342
343
    my $request = $args{request}            if $args{request};

344
    my $vm;
345
346
347
348
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
349
    $vm = $self->vm->[0]               if !$vm;
350

351
352
    confess "No vm found"   if !$vm;

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

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

358
    return $vm->create_domain(@_);
359
360
}

Francesc Guasch's avatar
Francesc Guasch committed
361
362
363
364
365
366
367
368
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

369
370
sub remove_domain {
    my $self = shift;
371
372
    my %arg = @_;

373
    confess "Argument name required "
374
375
        if !$arg{name};

376
377
    confess "Argument uid required "
        if !$arg{uid};
378
379
380
381

    lock_hash(%arg);

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

384
385
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
386
387
}

Francesc Guasch's avatar
Francesc Guasch committed
388
389
390
391
392
393
=head2 search_domain

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

=cut

394
395
396
sub search_domain {
    my $self = shift;
    my $name = shift;
397
    my $import = shift;
398

399
400
401
402
403
404
405
406
407
408
409
410
    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 $@;

411
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
412
        my $domain = $vm->search_domain($name, $import);
413
        next if !$domain;
414
        next if !$domain->_select_domain_db && !$import;
415
416
417
        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
418
        warn $@ if $@   && $DEBUG;
419
        return $domain if $id || $import;
420
    }
421
422


423
    return;
424
}
425

Francesc Guasch's avatar
Francesc Guasch committed
426
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
427

Francesc Guasch's avatar
Francesc Guasch committed
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
  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
443

444
445
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
446
List all created domains
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462

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

463
464
465
466
467
468
469
470
471
472
473
474
475
=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;
476
477
478
479
480
481
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
482
    }
483
    $sth->finish;
484
    return \@domains;
485
486
}

487
488
489
490
491
492
493
# 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
494
#         push @domains, {                id => $domain->id
495
496
497
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
498

499
500
501
502
503
#                            }
#     }
#     return \@domains;
# }

504

Francesc Guasch's avatar
Francesc Guasch committed
505
506
507
508
509
510
511
512
513
514
515
516
517
518
=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) {
519
520
521
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
522
523
524
525
526
527
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
=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
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
=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;
}

563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
=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
578

579
580
581
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
582
583
584
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
585
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
586
587
588
589
590
591
592
593
594
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

595
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
596
597
598
599
600
601
602
603
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

604
=cut
fv3rdugo's avatar
fv3rdugo committed
605

Francesc Guasch's avatar
Francesc Guasch committed
606
607
608
609
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
610

Francesc Guasch's avatar
Francesc Guasch committed
611
612
=cut

613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
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";
    }

}
633

634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
=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 "
        ." WHERE status='working' "
    );
    $sth->execute;
    while (my ($id) = $sth->fetchrow) {
        my $req = Ravada::Request->open($id);
        $req->status("done","Killed before completion");
    }

}

Francesc Guasch's avatar
Francesc Guasch committed
653
654
655
656
657
658
659
660
=head2 process_requests

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

  $ravada->process_requests();

=cut

661
662
sub process_requests {
    my $self = shift;
663
    my $debug = shift;
664
    my $dont_fork = shift;
665
666
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
667

668
669
    $self->_wait_pids_nohang();

670
    my $sth = $CONNECTOR->dbh->prepare("SELECT id,id_domain FROM requests "
671
672
673
        ." WHERE "
        ."    ( status='requested' OR status like 'retry %' OR status='waiting')"
        ."   AND ( at_time IS NULL  OR at_time = 0 OR at_time<=?) "
674
675
        ." ORDER BY date_req"
    );
676
677
678
679
680
681
682
    $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;

683
684
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
685
686
687
688
689
690
691
692
693

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

697
698
        warn "[$debug_type] $$ executing request ".$req->id." ".$req->status()." "
            .$req->command
699
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
700
701
702

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
703
704
705
        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
706
            if ( $n_retry < 3) {
707
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
708
                $req->status("retry ".++$n_retry)
709
            }
710
        }
711
712
713
        next if !$DEBUG && !$debug;

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

717
718
    }
    $sth->finish;
719
720
721

}

Francesc Guasch's avatar
Francesc Guasch committed
722
=head2 process_long_requests
723
724
725
726
727
728
729
730
731
732
733

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);
734
735
}

736
737
738
739
740
741
742
743
744
745
746
747
748
=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);

749
750
}

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
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;
}

781
782
783
784
785
786
787
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

788
789
sub _process_requests_dont_fork {
    my $self = shift;
790
    my $debug = shift;
791
    return $self->process_requests($debug, 1);
792
}
Francesc Guasch's avatar
Francesc Guasch committed
793

794
795
796
797
798
799
800
801
=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
802

803
804
805
806
807
808
809
810
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

811
812
813
sub _execute {
    my $self = shift;
    my $request = shift;
814
    my $dont_fork = shift;
815

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

818
819
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
820

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

823
824
825
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
826
        $request->status('done') if $request->status() ne 'done';
827
828
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
829

830
831
832
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

833
    $request->status('working');
834
835
    my $pid = fork();
    die "I can't fork" if !defined $pid;
836
    $self->_do_execute_command($sub, $request) if $pid == 0;
837
    $self->_add_pid($pid, $request->id);
838
#    $self->_connect_vm_kvm();
839
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
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
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;

}

867
868
869
870
871
872
873
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});
874
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
875
    $request->error('');
876
    my $display = $domain->display($user);
877
878
    $request->result({display => $display});

879
880
}

881
882
883
884
885
886
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);
887
    my $bytes = 0;
888
    if (!$domain->can_screenshot) {
889
        die "I can't take a screenshot of the domain ".$domain->name;
890
    } else {
891
892
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
893
    }
894
    $request->error("No data received") if !$bytes;
895
896
897
}


898
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
899
900
901
    my $self = shift;
    my $request = shift;

902
    $request->status('creating domain');
903
    warn "$$ creating domain"   if $DEBUG;
904
    my $domain;
905

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

908
    my $msg = '';
909

910
    if ($domain) {
911
       $msg = 'Domain '
912
913
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
914
            ." created."
915
916
917
918
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
919
920
921

}

922
923
924
925
926
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
927
    for ( 1 .. 10 ) {
928
929
930
931
        my $n_pids = scalar keys %{$self->{pids}};
        my $msg = $req->id." ".$req->command." waiting for processes to finish $n_pids of $LIMIT_PROCESS running";
        warn $msg if $DEBUG;

932
        return if $n_pids < $LIMIT_PROCESS;
933
934
935
936

        $self->_wait_pids_nohang();
        sleep 1;

937
938
939
        next if $try++;

        $req->error($msg);
940
        $req->status('waiting') if $req->status() !~ 'waiting';
941
    }
942
    return scalar keys %{$self->{pids}};
943
944
}

945
946
947
948
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

Francesc Guasch's avatar
Francesc Guasch committed
949
950
951
952
953
954
    for my $pid ( keys %{$self->{pids}}) {
        my $kid = waitpid($pid , WNOHANG);
        next if !$kid || $kid == -1;
        $self->_set_req_done($kid);
        delete $self->{pids}->{$kid};
    }
955
956
957
958
959
960
961
962
963
964
965
966

}

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

Francesc Guasch's avatar
Francesc Guasch committed
969
970
971
972
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
976
    for my $pid ( keys %{$self->{pids}}) {
977
978
        $request->status("waiting for pid $pid")
            if $request && $request->status !~ /waiting/i;
979
980

#        warn "Checking for pid '$pid' created at ".localtime($self->{pids}->{$pid});
Francesc Guasch's avatar
Francesc Guasch committed
981
        my $kid = waitpid($pid,0);
982
#        warn "Found $kid";
983
984
985
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
986
987
988
989
990
991
992
        return if $kid  == $pid;
    }
}

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

995
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
996
997
}

998
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
999
1000
1001
    my $self = shift;
    my $request = shift;

1002
1003
1004
1005
    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
1006

1007
}
Francesc Guasch's avatar
Francesc Guasch committed
1008

1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
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);

1037
1038
    $domain->resume(
        remote_ip => $request->args('remote_ip')
1039
        ,user => $user
1040
    );
1041
1042
1043
1044
1045
1046

    $request->status('done');

}


1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
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
1063
1064
1065
1066
1067
sub _cmd_start {
    my $self = shift;
    my $request = shift;

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

1069
1070
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
1071
1072
1073
1074

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

1075
    $domain->start(user => $user, remote_ip => $request->args('remote_ip'));
1076
1077
1078
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
1079
            ." started"
1080
1081
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
1082
1083
1084

}

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

Francesc Guasch's avatar
Francesc Guasch committed
1089
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
1090
1091
1092
1093
    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
1094
    my $domain = $self->search_domain_by_id($id_domain);
1095

Francesc Guasch's avatar
Francesc Guasch committed
1096
    die "Unknown domain id '$id_domain'\n" if !$domain;
1097
1098

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
1099
1100
1101

}

1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
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);

    my $domain = $self->search_domain_by_id($id_domain);

    die "Unknown domain id '$id_domain'\n" if !$domain;

1115
1116
    $domain->_vm->disconnect();
    $self->_disconnect_vm();
1117
1118
1119
1120
1121
    $domain->remove_base($user);

}


1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
sub _cmd_hybernate {
    my $self = shift;
    my $request = shift;

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

    my $user = Ravada::Auth::SQL->search_by_id( $uid);
    my $domain = $self->search_domain_by_id($id_domain);

    die "Unknown domain id '$id_domain'\n" if !$domain;

    $domain->hybernate($user);

}

Francesc Guasch's avatar
Francesc Guasch committed
1138
1139
1140
1141
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

1142
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
1143
    my $name = $request->args('name');
1144
    my $timeout = ($request->args('timeout') or 60);
1145

1146
    my $domain;
1147
1148
1149
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

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

1152
1153
    $domain->shutdown(timeout => $timeout, name => $name, user => $user
                    , request => $request);
Francesc Guasch's avatar
Francesc Guasch committed
1154
1155
1156

}

1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
sub _cmd_force_shutdown {
    my $self = shift;
    my $request = shift;

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

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

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

    $domain->force_shutdown($user,$request);

}

1174
1175
1176
1177
sub _cmd_list_vm_types {
    my $self = shift;
    my $request = shift;
    my @list_types = $self->list_vm_types();
Francesc Guasch's avatar
Francesc Guasch committed
1178
    $request->result(\@list_types);
1179
1180
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
1181

1182
1183
1184
1185
1186
1187
1188
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

    $request->status('done');
    return 1;
}
Francesc Guasch's avatar
Francesc Guasch committed
1189

1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
sub _cmd_rename_domain {
    my $self = shift;
    my $request = shift;

    my $uid = $request->args('uid');
    my $name = $request->args('name');
    my $id_domain = $request->args('id_domain') or die "ERROR: Missing id_domain";

    my $user = Ravada::Auth::SQL->search_by_id($uid);
    my $domain = $self->search_domain_by_id($id_domain);

    confess "Unkown domain ".Dumper($request)   if !$domain;

    $domain->rename(user => $user, name => $name);

}

Francesc Guasch's avatar
Francesc Guasch committed
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
sub _cmd_set_driver {
    my $self = shift;
    my $request = shift;

    my $uid = $request->args('uid');
    my $id_domain = $request->args('id_domain') or die "ERROR: Missing id_domain";

    my $user = Ravada::Auth::SQL->search_by_id($uid);
    my $domain = $self->search_domain_by_id($id_domain);

    confess "Unkown domain ".Dumper($request)   if !$domain;

    die "USER $uid not authorized to set driver for domain ".$domain->name
        if $domain->id_owner != $user->id && !$user->is_admin;

    $domain->set_driver_id($request->args('id_option'));
}

Francesc Guasch's avatar
Francesc Guasch committed
1225
1226
1227
1228
1229
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

    my %methods = (
Francesc Guasch's avatar
Francesc Guasch committed
1230

Francesc Guasch's avatar
Francesc Guasch committed
1231
          start => \&_cmd_start
1232
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
1233
1234
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
1235
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
1236
      ,shutdown => \&_cmd_shutdown
1237
     ,hybernate => \&_cmd_hybernate
Francesc Guasch's avatar
Francesc Guasch committed
1238
    ,set_driver => \&_cmd_set_driver