Ravada.pm 29.1 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.1.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
149
150
151
152
153
154
155
156
157
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;
    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;
}

158
159
160
sub _upgrade_tables {
    my $self = shift;
    $self->_upgrade_table('file_base_images','target','varchar(64) DEFAULT NULL');
161
162
    $self->_upgrade_table('vms','vm_type',"char(20) NOT NULL DEFAULT 'KVM'");
    $self->_upgrade_table('requests','at_time','int(11) DEFAULT NULL');
163
164
165
}


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

}

177
=head2 display_ip
178

179
Returns the default display IP read from the config file
180

181
=cut
182

183
sub display_ip {
184

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

187
    return $ip if $ip;
188
189
}

190
191
sub _init_config {
    my $file = shift;
192
193

    my $connector = shift;
194
    confess "Deprecated connector" if $connector;
195

196
    $CONFIG = YAML::LoadFile($file);
197
198
199

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
200
#    $CONNECTOR = ( $connector or _connect_dbh());
201
202
}

203
sub _create_vm_kvm {
204
    my $self = shift;
205

206
207
208
209
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
212

213
214
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
215
216
217
218

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

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

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

249
250
    my @vms;
    eval { @vms = $self->vm };
251
    warn $@ if $@;
252
253
254
255
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
256
257
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
258
259
260

        if (!$connect) {
            $vm->disconnect();
261
262
        } else {
            $vm->connect();
263
        }
264
265
266
    }
}

267
268
269
270
271
272
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

275
276
    my $err = $err_kvm;

277
278
279
    push @vms,($vm_kvm) if $vm_kvm;

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

291
292
}

293
sub _check_vms {
294
295
    my $self = shift;

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

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

joansp's avatar
joansp committed
312
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
313
314
315
316
317
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
318
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
319
320
321
322
323
324
325
326
         name => $name
    , id_base => 3
  );


=cut


327
sub create_domain {
328
329
    my $self = shift;

330
331
    my %args = @_;

332
333
334
    croak "Argument id_owner required "
        if !$args{id_owner};

335
336
    my $vm_name = $args{vm};
    delete $args{vm};
337

Francesc Guasch's avatar
Francesc Guasch committed
338
339
    my $request = $args{request}            if $args{request};

340
    my $vm;
341
342
343
344
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
345
    $vm = $self->vm->[0]               if !$vm;
346

347
348
    confess "No vm found"   if !$vm;

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

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

354
    return $vm->create_domain(@_);
355
356
}

Francesc Guasch's avatar
Francesc Guasch committed
357
358
359
360
361
362
363
364
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

365
366
sub remove_domain {
    my $self = shift;
367
368
    my %arg = @_;

369
    confess "Argument name required "
370
371
        if !$arg{name};

372
373
    confess "Argument uid required "
        if !$arg{uid};
374
375
376
377

    lock_hash(%arg);

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

380
381
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
382
383
}

Francesc Guasch's avatar
Francesc Guasch committed
384
385
386
387
388
389
=head2 search_domain

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

=cut

390
391
392
sub search_domain {
    my $self = shift;
    my $name = shift;
393
    my $import = shift;
394

395
396
397
398
399
400
401
402
403
404
405
406
    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 $@;

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


419
    return;
420
}
421

Francesc Guasch's avatar
Francesc Guasch committed
422
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
423

Francesc Guasch's avatar
Francesc Guasch committed
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
  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
439

440
441
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
442
List all created domains
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458

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

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

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

495
496
497
498
499
#                            }
#     }
#     return \@domains;
# }

500

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

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

559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
=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
574

575
576
577
=pod

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

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

600
=cut
fv3rdugo's avatar
fv3rdugo committed
601

Francesc Guasch's avatar
Francesc Guasch committed
602
603
604
605
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
606

Francesc Guasch's avatar
Francesc Guasch committed
607
608
=cut

609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
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";
    }

}
629

630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
=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
649
650
651
652
653
654
655
656
=head2 process_requests

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

  $ravada->process_requests();

=cut

657
658
sub process_requests {
    my $self = shift;
659
    my $debug = shift;
660
    my $dont_fork = shift;
661
662
    my $long_commands = (shift or 0);
    my $short_commands = (shift or 0);
663

664
665
    $self->_wait_pids_nohang();

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

679
680
    while (my ($id_request,$id_domain)= $sth->fetchrow) {
        my $req = Ravada::Request->open($id_request);
681
682
683
684
685
686
687
688
689

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

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

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

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

713
714
    }
    $sth->finish;
715
716
717

}

Francesc Guasch's avatar
Francesc Guasch committed
718
=head2 process_long_requests
719
720
721
722
723
724
725
726
727
728
729

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);
730
731
}

732
733
734
735
736
737
738
739
740
741
742
743
744
=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);

745
746
}

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

777
778
779
780
781
782
783
sub _process_all_requests_dont_fork {
    my $self = shift;
    my $debug = shift;

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

784
785
sub _process_requests_dont_fork {
    my $self = shift;
786
    my $debug = shift;
787
    return $self->process_requests($debug, 1);
788
}
Francesc Guasch's avatar
Francesc Guasch committed
789

790
791
792
793
794
795
796
797
=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
798

799
800
801
802
803
804
805
806
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

807
808
809
sub _execute {
    my $self = shift;
    my $request = shift;
810
    my $dont_fork = shift;
811

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

814
815
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
816

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

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

826
827
828
    $self->_wait_pids_nohang();
    return if $self->_wait_children($request);

829
    $request->status('working');
830
831
    my $pid = fork();
    die "I can't fork" if !defined $pid;
832
    $self->_do_execute_command($sub, $request) if $pid == 0;
833
    $self->_add_pid($pid, $request->id);
834
#    $self->_connect_vm_kvm();
835
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
836
837
}

838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
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;

}

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

875
876
}

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


894
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
895
896
897
    my $self = shift;
    my $request = shift;

898
    $request->status('creating domain');
899
    warn "$$ creating domain"   if $DEBUG;
900
    my $domain;
901

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

904
    my $msg = '';
905

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

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
915
916
917

}

918
919
920
921
922
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
923
    for ( 1 .. 10 ) {
924
925
926
927
        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;

928
        return if $n_pids < $LIMIT_PROCESS;
929
930
931
932

        $self->_wait_pids_nohang();
        sleep 1;

933
934
935
        next if $try++;

        $req->error($msg);
936
        $req->status('waiting') if $req->status() !~ 'waiting';
937
    }
938
    return scalar keys %{$self->{pids}};
939
940
}

941
942
943
944
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

Francesc Guasch's avatar
Francesc Guasch committed
945
946
947
948
949
950
    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};
    }
951
952
953
954
955
956
957
958
959
960
961
962

}

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

Francesc Guasch's avatar
Francesc Guasch committed
965
966
967
968
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

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

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

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
982
983
984
985
986
987
988
        return if $kid  == $pid;
    }
}

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

991
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
992
993
}

994
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
995
996
997
    my $self = shift;
    my $request = shift;

998
999
1000
1001
    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
1002

1003
}
Francesc Guasch's avatar
Francesc Guasch committed
1004

1005
1006
1007
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
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);

1033
1034
    $domain->resume(
        remote_ip => $request->args('remote_ip')
1035
        ,user => $user
1036
    );
1037
1038
1039
1040
1041
1042

    $request->status('done');

}


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

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

1065
1066
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
1067
1068
1069
1070

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

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

}

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

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

Francesc Guasch's avatar
Francesc Guasch committed
1092
    die "Unknown domain id '$id_domain'\n" if !$domain;
1093
1094

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
1095
1096
1097

}

1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
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;

1111
1112
    $domain->_vm->disconnect();
    $self->_disconnect_vm();
1113
1114
1115
1116
1117
    $domain->remove_base($user);

}


Francesc Guasch's avatar
Francesc Guasch committed
1118
1119
1120
1121
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

1122
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
1123
    my $name = $request->args('name');
1124
    my $timeout = ($request->args('timeout') or 60);
1125

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

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

1132
1133
    $domain->shutdown(timeout => $timeout, name => $name, user => $user
                    , request => $request);
Francesc Guasch's avatar
Francesc Guasch committed
1134
1135
1136

}

1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
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);

}

1154
1155
1156
1157
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
1158
    $request->result(\@list_types);
1159
1160
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
1161

1162
1163
1164
1165
1166
1167
1168
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
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
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
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
1205
1206
1207
1208
1209
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
1211
          start => \&_cmd_start
1212
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
1213
1214
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
1215
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
1216
      ,shutdown => \&_cmd_shutdown
Francesc Guasch's avatar
Francesc Guasch committed
1217
    ,set_driver => \&_cmd_set_driver
1218
    ,domdisplay => \&_cmd_domdisplay
1219
    ,screenshot => \&_cmd_screenshot
1220
   ,remove_base => \&_cmd_remove_base
1221
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
1222
  ,prepare_base => \&_cmd_prepare_base
1223
 ,rename_domain => \&_cmd_rename_domain
1224
 ,open_iptables => \&_cmd_open_iptables
1225
 ,list_vm_types => \&_cmd_list_vm_types
1226
,force_shutdown => \&_cmd_force_shutdown