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

use warnings;
use strict;

Francesc Guasch's avatar
Francesc Guasch committed
6
7
our $VERSION = '0.1.0';

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
18
use Socket qw( inet_aton inet_ntoa );
use Sys::Hostname;

Francesc Guasch's avatar
Francesc Guasch committed
19
use Ravada::Auth;
20
use Ravada::Request;
21
use Ravada::VM::KVM;
22
use Ravada::VM::Void;
23

Francesc Guasch's avatar
Francesc Guasch committed
24
25
26
27
28
29
30
31
32
33
34
35
=head1 NAME

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

36
37
38
39
40
41
42

our $FILE_CONFIG = "/etc/ravada.conf";

###########################################################################

our $CONNECTOR;
our $CONFIG = {};
43
our $DEBUG;
44
our $CAN_FORK = 1;
45
our $CAN_LXC = 0;
46
47
48
our $LIMIT_PROCESS = 2;

our %FAT_COMMAND =  map { $_ => 1 } qw(start create prepare_base remove);
49
50
51
52
53
54
55
56
57

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

has 'connector' => (
58
59
60
61
62
63
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
64
65
);

Francesc Guasch's avatar
Francesc Guasch committed
66
67
68
69
70
71
72
=head2 BUILD

Internal constructor

=cut


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

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

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
94
95
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
96
97
98
99
100
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

101
=head2 display_ip
102

103
Returns the default display IP read from the config file
104

105
=cut
106

107
108
sub display_ip {
    my $ip = $CONFIG->{display_ip};
joansp's avatar
joansp committed
109

110
    return $ip if $ip;
111
112
}

113
114
sub _init_config {
    my $file = shift;
115
116

    my $connector = shift;
117
    confess "Deprecated connector" if $connector;
118

119
    $CONFIG = YAML::LoadFile($file);
120
121
122

    $LIMIT_PROCESS = $CONFIG->{limit_process} 
        if $CONFIG->{limit_process} && $CONFIG->{limit_process}>1;
123
#    $CONNECTOR = ( $connector or _connect_dbh());
124
125
}

126
sub _create_vm_kvm {
127
    my $self = shift;
128

129
130
131
132
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
135

136
137
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
138
139
140
141

    my ($internal_vm , $storage);
    eval {
        $storage = $vm_kvm->dir_img();
142
        $internal_vm = $vm_kvm->vm;
143
144
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
145
146
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
147
148
}

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
=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 {
167
    my $self = shift;
168
169
170
171

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

172
173
    my @vms;
    eval { @vms = $self->vm };
174
    warn $@ if $@;
175
176
177
178
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
179
180
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
181
182
183

        if (!$connect) {
            $vm->disconnect();
184
185
        } else {
            $vm->connect();
186
        }
187
188
189
    }
}

190
191
192
193
194
195
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

198
199
    my $err = $err_kvm;

200
201
202
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
203
204
205
206
207
208
    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;
    }
209
    if (!@vms) {
210
        warn "No VMs found: $err\n";
211
212
213
    }
    return \@vms;

214
215
}

216
sub _check_vms {
217
218
    my $self = shift;

219
220
    my @vm;
    eval { @vm = @{$self->vm} };
221
222
223
224
225
226
227
228
229
230
    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
231
232
233
234
=head2 create_domain

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

joansp's avatar
joansp committed
235
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
236
237
238
239
240
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
241
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
242
243
244
245
246
247
248
249
         name => $name
    , id_base => 3
  );


=cut


250
sub create_domain {
251
252
    my $self = shift;

253
254
    my %args = @_;

255
256
257
    croak "Argument id_owner required "
        if !$args{id_owner};

258
259
    my $vm_name = $args{vm};
    delete $args{vm};
260

Francesc Guasch's avatar
Francesc Guasch committed
261
262
    my $request = $args{request}            if $args{request};

263
    my $vm;
264
265
266
267
    if ($vm_name) {
        $vm = $self->search_vm($vm_name);
        confess "ERROR: vm $vm_name not found"  if !$vm;
    }
268
    $vm = $self->vm->[0]               if !$vm;
269

270
271
    confess "No vm found"   if !$vm;

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

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

277
    return $vm->create_domain(@_);
278
279
}

Francesc Guasch's avatar
Francesc Guasch committed
280
281
282
283
284
285
286
287
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

288
289
sub remove_domain {
    my $self = shift;
290
291
    my %arg = @_;

292
    confess "Argument name required "
293
294
        if !$arg{name};

295
296
    confess "Argument uid required "
        if !$arg{uid};
297
298
299
300

    lock_hash(%arg);

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

303
304
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
305
306
}

Francesc Guasch's avatar
Francesc Guasch committed
307
308
309
310
311
312
=head2 search_domain

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

=cut

313
314
315
sub search_domain {
    my $self = shift;
    my $name = shift;
316
    my $import = shift;
317

318
319
320
321
322
323
324
325
326
327
328
329
    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 $@;

330
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
331
        my $domain = $vm->search_domain($name, $import);
332
        next if !$domain;
333
        next if !$domain->_select_domain_db && !$import;
334
335
336
        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
337
        warn $@ if $@   && $DEBUG;
338
        return $domain if $id || $import;
339
    }
340
341


342
    return;
343
}
344

Francesc Guasch's avatar
Francesc Guasch committed
345
=head2 search_domain_by_id
Francesc Guasch's avatar
Francesc Guasch committed
346

Francesc Guasch's avatar
Francesc Guasch committed
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
  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
362

363
364
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
365
List all created domains
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381

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

382
383
384
385
386
387
388
389
390
391
392
393
394
=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;
395
396
397
398
399
400
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
401
    }
402
    $sth->finish;
403
    return \@domains;
404
405
}

406
407
408
409
410
411
412
# 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
413
#         push @domains, {                id => $domain->id
414
415
416
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
joansp's avatar
joansp committed
417

418
419
420
421
422
#                            }
#     }
#     return \@domains;
# }

423

Francesc Guasch's avatar
Francesc Guasch committed
424
425
426
427
428
429
430
431
432
433
434
435
436
437
=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) {
438
439
440
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
441
442
443
444
445
446
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
=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
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
=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;
}

482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
=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
497

498
499
500
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
501
502
503
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
504
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
505
506
507
508
509
510
511
512
513
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

514
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
515
516
517
518
519
520
521
522
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

523
=cut
fv3rdugo's avatar
fv3rdugo committed
524

Francesc Guasch's avatar
Francesc Guasch committed
525
526
527
528
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
529

Francesc Guasch's avatar
Francesc Guasch committed
530
531
=cut

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
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";
    }

}
552

Francesc Guasch's avatar
Francesc Guasch committed
553
554
555
556
557
558
559
560
=head2 process_requests

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

  $ravada->process_requests();

=cut

561
562
sub process_requests {
    my $self = shift;
563
    my $debug = shift;
564
    my $dont_fork = shift;
565

566
    $self->_wait_pids_nohang();
567
    $self->_check_vms();
568

569
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
570
        ." WHERE status='requested' OR status like 'retry %'");
571
572
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
573
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
574
        my $req = Ravada::Request->open($id);
575
576
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
577
578
579

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
580
        $req->status('working');
581
582
583
        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
584
            if ( $n_retry < 3) {
585
                warn $req->id." ".$req->command." to retry" if $DEBUG;
joansp's avatar
joansp committed
586
                $req->status("retry ".++$n_retry)
587
            }
588
        }
589
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
joansp's avatar
joansp committed
590
            ." , error: '".($req->error or 'NONE')."'"
591
                if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
592

593
594
595
596
    }
    $sth->finish;
}

597
598
sub _process_requests_dont_fork {
    my $self = shift;
599
    my $debug = shift;
600
    return $self->process_requests($debug, 1);
601
}
Francesc Guasch's avatar
Francesc Guasch committed
602

603
604
605
606
607
608
609
610
=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
611

612
613
614
615
616
617
618
619
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

620
621
622
sub _execute {
    my $self = shift;
    my $request = shift;
623
    my $dont_fork = shift;
624

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

627
628
    confess "Unknown command ".$request->command
            if !$sub;
Francesc Guasch's avatar
Francesc Guasch committed
629

630
631
    $self->_disconnect_vm();

632
    if ($dont_fork || !$CAN_FORK ) {
joansp's avatar
joansp committed
633

Francesc Guasch's avatar
Francesc Guasch committed
634
635
        $self->_connect_vm();

636
637
638
        eval { $sub->($self,$request) };
        my $err = ($@ or '');
        $request->error($err);
639
        $request->status('done') if $request->status() ne 'done';
640
641
        return $err;
    }
Francesc Guasch's avatar
Francesc Guasch committed
642

643
    $self->_wait_children($request) if $FAT_COMMAND{$request->command};
644
645
646
    my $pid = fork();
    die "I can't fork" if !defined $pid;
    if ($pid == 0) {
joansp's avatar
joansp committed
647
        eval {
648
            $self->_connect_vm();
649
            $sub->($self,$request);
650
            $self->_disconnect_vm();
651
652
653
        };
        my $err = ( $@ or '');
        $request->error($err);
654
        $request->status('done') if $request->status() ne 'done';
655
656
657
        exit;
    }
    $self->_add_pid($pid, $request->id);
658
#    $self->_connect_vm_kvm();
659
    return '';
Francesc Guasch's avatar
Francesc Guasch committed
660
661
}

662
663
664
665
666
667
668
669
670
sub _cmd_domdisplay {
    my $self = shift;
    my $request = shift;

    $request->status('working');

    my $name = $request->args('name');
    confess "Unknown name for request ".Dumper($request)  if!$name;
    my $domain = $self->search_domain($request->args->{name});
671
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
672
    $request->error('');
673
    my $display = $domain->display($user);
674
675
676
    $request->result({display => $display});

    $request->status('done');
677
678
}

679
680
681
682
683
684
685
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);
    $request->error('');
686
    my $bytes = 0;
687
    if (!$domain->can_screenshot) {
688
        die "I can't take a screenshot of the domain ".$domain->name;
689
    } else {
690
691
        $bytes = $domain->screenshot($request->args('filename'));
        $bytes = $domain->screenshot($request->args('filename'))    if !$bytes;
692
    }
693
    $request->error("No data received") if !$bytes;
694
695
696
697
698
    $request->status('done');

}


699
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
700
701
702
    my $self = shift;
    my $request = shift;

703
    $request->status('creating domain');
704
    warn "$$ creating domain"   if $DEBUG;
705
    my $domain;
706

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

709
    my $msg = '';
710

711
    if ($domain) {
712
       $msg = 'Domain '
713
714
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
715
            ." created."
716
717
718
719
        ;
    }

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
720
721
722

}

723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
sub _wait_children {
    my $self = shift;
    my $req = shift or confess "Missing request";

    my $try = 0;
    for (;;) {
        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;

        return if $n_pids <= $LIMIT_PROCESS;

        $self->_wait_pids_nohang();
        sleep 1;

738
739
740
741
        next if $try++;

        $req->error($msg);
        $req->status('waiting');
742
743
744
    }
}

745
746
747
748
749
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

    my $kid = waitpid(-1 , WNOHANG);
Francesc Guasch's avatar
Francesc Guasch committed
750
    return if !$kid || $kid == -1;
751

752
    $self->_set_req_done($kid);
753
    delete $self->{pids}->{$kid};
754
755
756
757
758
759
760
761
762
763
764
765

}

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

Francesc Guasch's avatar
Francesc Guasch committed
768
769
770
771
sub _wait_pids {
    my $self = shift;
    my $request = shift;

Francesc Guasch's avatar
Francesc Guasch committed
772
773
    $request->status('waiting for other tasks')     if $request;

Francesc Guasch's avatar
Francesc Guasch committed
774
    for my $pid ( keys %{$self->{pids}}) {
775
776
777
        $request->status("waiting for pid $pid")    if $request;

#        warn "Checking for pid '$pid' created at ".localtime($self->{pids}->{$pid});
Francesc Guasch's avatar
Francesc Guasch committed
778
        my $kid = waitpid($pid,0);
779
#        warn "Found $kid";
780
781
782
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
783
784
785
786
787
788
789
        return if $kid  == $pid;
    }
}

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

792
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
793
794
}

795
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
796
797
798
799
    my $self = shift;
    my $request = shift;

    $request->status('working');
800
801
802
803
    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
804

805
}
Francesc Guasch's avatar
Francesc Guasch committed
806

807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
sub _cmd_pause {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    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;

    $request->status('working');
    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);

837
838
    $domain->resume(
        remote_ip => $request->args('remote_ip')
839
        ,user => $user
840
    );
841
842
843
844
845
846

    $request->status('done');

}


847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
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
863
864
865
866
sub _cmd_start {
    my $self = shift;
    my $request = shift;

867
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
868
    my $name = $request->args('name');
869

870
871
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
872
873
874
875

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

876
    $domain->start(user => $user, remote_ip => $request->args('remote_ip'));
877
878
879
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
880
            ." started"
881
882
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
883
884
885

}

Francesc Guasch's avatar
Francesc Guasch committed
886
887
888
889
890
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
Francesc Guasch's avatar
Francesc Guasch committed
891
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
892
893
894
895
    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
896
    my $domain = $self->search_domain_by_id($id_domain);
897

Francesc Guasch's avatar
Francesc Guasch committed
898
    die "Unknown domain id '$id_domain'\n" if !$domain;
899
900

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
901
902
903

}

904
905
906
907
908
909
910
911
912
913
914
915
916
917
sub _cmd_remove_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    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;

918
919
    $domain->_vm->disconnect();
    $self->_disconnect_vm();
920
921
922
923
924
    $domain->remove_base($user);

}


Francesc Guasch's avatar
Francesc Guasch committed
925

Francesc Guasch's avatar
Francesc Guasch committed
926
927
928
929
930
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
931
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
932
    my $name = $request->args('name');
933
    my $timeout = ($request->args('timeout') or 60);
934

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

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

941
942
    $domain->shutdown(timeout => $timeout, name => $name, user => $user
                    , request => $request);
Francesc Guasch's avatar
Francesc Guasch committed
943
944
945

}

946
947
948
949
950
sub _cmd_list_vm_types {
    my $self = shift;
    my $request = shift;
    $request->status('working');
    my @list_types = $self->list_vm_types();
Francesc Guasch's avatar
Francesc Guasch committed
951
    $request->result(\@list_types);
952
953
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
954

955
956
957
958
959
960
961
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
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
980
981
982
983
984
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
986
          start => \&_cmd_start
987
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
988
989
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
990
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
991
      ,shutdown => \&_cmd_shutdown
992
    ,domdisplay => \&_cmd_domdisplay
993
    ,screenshot => \&_cmd_screenshot
994
   ,remove_base => \&_cmd_remove_base
995
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
996
  ,prepare_base => \&_cmd_prepare_base
997
 ,rename_domain => \&_cmd_rename_domain
998
 ,open_iptables => \&_cmd_open_iptables
999
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
1000
1001
1002
1003
    );
    return $methods{$cmd};
}

1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
=head2 open_vm

Opens a VM of a given type


  my $vm = $ravada->open_vm('KVM');

=cut

sub open_vm {
    return search_vm(@_);
}

1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
=head2 search_vm

Searches for a VM of a given type

  my $vm = $ravada->search_vm('kvm');

=cut

sub search_vm {
    my $self = shift;
    my $type = shift;

1029
1030
    confess "Missing VM type"   if !$type;

1031
    my $class = 'Ravada::VM::'.uc($type);
Francesc Guasch's avatar
Francesc Guasch committed
1032

1033
    if ($type =~ /Void/i) {
1034
1035
1036
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
1037
1038
    my @vms;
    eval { @vms = @{$self->vm} };
1039
1040
1041
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
1042
    for my $vm (@vms) {
1043
1044
1045
1046
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
1047

1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
=head2 import_domain

Imports a domain in Ravada

    my $domain = $ravada->import_domain(
                            vm => 'KVM'
                            ,name => $name
                            ,user => $user_name
    );

=cut

sub import_domain {
    my $self = shift;
    my %args = @_;

    my $vm_name = $args{vm} or die "ERROR: mandatory argument vm required";
    my $name = $args{name} or die "ERROR: mandatory argument domain name required";
    my $user_name = $args{user} or die "ERROR: mandatory argument user required";

    my $vm = $self->search_vm($vm_name) or die "ERROR: unknown VM '$vm_name'";
    my $user = Ravada::Auth::SQL->new(name => $user_name);
    die "ERROR: unknown user '$user_name'" if !$user || !$user->id;
    
    my $domain;
    eval { $domain = $self->search_domain($name) };
    die "ERROR: Domain '$name' already in RVD"  if $domain;

    return $vm->import_domain($name, $user);
}

Francesc Guasch's avatar
Francesc Guasch committed
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
=head2 version

Returns the version of the module

=cut

sub version {
    return $VERSION;
}

1089

Francesc Guasch's avatar
Francesc Guasch committed
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
=head1 AUTHOR

Francesc Guasch-Ortiz	, frankie@telecos.upc.edu

=head1 SEE ALSO

Sys::Virt

=cut

1100
1;