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

use warnings;
use strict;

6
use Carp qw(carp croak);
7
use Data::Dumper;
8
use DBIx::Connector;
9
use Hash::Util qw(lock_hash);
10
use Moose;
Francesc Guasch's avatar
Francesc Guasch committed
11
use POSIX qw(WNOHANG);
12
13
use YAML;

14
15
16
use Socket qw( inet_aton inet_ntoa );
use Sys::Hostname;

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

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

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

34
35
36
37
38
39
40

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

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

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

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

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

has 'connector' => (
56
57
58
59
60
61
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
62
63
);

Francesc Guasch's avatar
Francesc Guasch committed
64
65
66
67
68
69
70
=head2 BUILD

Internal constructor

=cut


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

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

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

}

99
=head2 display_ip
100

101
Returns the default display IP read from the config file
102

103
=cut
104

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

108
    return $ip if $ip;
109
110
}

111
112
sub _init_config {
    my $file = shift;
113
114

    my $connector = shift;
115
    confess "Deprecated connector" if $connector;
116

117
    $CONFIG = YAML::LoadFile($file);
118
119
120

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

124
sub _create_vm_kvm {
125
    my $self = shift;
126

127
128
129
130
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

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

    my $vm_kvm;
133

134
135
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
136
    return (undef, $err_kvm)    if !$vm_kvm;
137
    return ($vm_kvm,$err_kvm);
138
139
140
141
142
143
144
145
146

    my ($internal_vm , $storage);
    eval {
        $internal_vm = $vm_kvm->vm;
        $internal_vm->list_all_domains();

        $storage = $vm_kvm->dir_img();
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
147
148
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
149
150
}

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

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

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

    return if !scalar @vms;
181
182
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
183
184
185
186
187
188
189
190
191

        if (!$connect) {
            warn "disconnect VM $n $vm" if $DEBUG;
            $vm->disconnect();
            next;
        }
        warn "connect VM $n $vm"    if $DEBUG;

        $vm->reconnect();
192
193
194
    }
}

195
196
197
198
199
200
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

203
204
    my $err = $err_kvm;

205
206
207
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
208
209
210
211
212
213
    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;
    }
214
    if (!@vms) {
215
        confess "No VMs found: $err\n";
216
217
218
    }
    return \@vms;

219
220
}

221
sub _check_vms {
222
223
    my $self = shift;

224
225
    my @vm;
    eval { @vm = @{$self->vm} };
226
227
228
229
230
231
232
233
234
235
    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
236
237
238
239
=head2 create_domain

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

joansp's avatar
joansp committed
240
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
241
242
243
244
245
         name => $name
    , id_iso => 1
  );


joansp's avatar
joansp committed
246
  my $domain = $ravada->create_domain(
Francesc Guasch's avatar
Francesc Guasch committed
247
248
249
250
251
252
253
254
         name => $name
    , id_base => 3
  );


=cut


255
sub create_domain {
256
257
    my $self = shift;

258
259
    my %args = @_;

260
261
262
    croak "Argument id_owner required "
        if !$args{id_owner};

263
264
    my $vm_name = $args{vm};
    delete $args{vm};
265

Francesc Guasch's avatar
Francesc Guasch committed
266
267
    my $request = $args{request}            if $args{request};

268
    my $vm;
269
    $vm = $self->search_vm($vm_name)   if $vm_name;
270
    $vm = $self->vm->[0]               if !$vm;
271

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

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

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

659
660
661
662
663
664
665
666
667
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});
668
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
669
    $request->error('');
670
    my $display = $domain->display($user);
671
672
673
    $request->result({display => $display});

    $request->status('done');
674
675
}

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

}


696
sub _cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
697
698
699
    my $self = shift;
    my $request = shift;

700
    $request->status('creating domain');
701
    warn "$$ creating domain"   if $DEBUG;
702
    my $domain;
703

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

706
    my $msg = '';
707

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

    $request->status('done',$msg);
Francesc Guasch's avatar
Francesc Guasch committed
717
718
719

}

720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
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;
        $req->error($msg)
            if !$try++;

    }
}

740
741
742
743
744
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

747
    $self->_set_req_done($kid);
748
    delete $self->{pids}->{$kid};
749
750
751
752
753
754
755
756
757
758
759
760

}

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

Francesc Guasch's avatar
Francesc Guasch committed
763
764
765
766
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
769
    for my $pid ( keys %{$self->{pids}}) {
770
771
772
        $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
773
        my $kid = waitpid($pid,0);
774
#        warn "Found $kid";
775
776
777
        $self->_set_req_done($pid);

        delete $self->{pids}->{$kid};
Francesc Guasch's avatar
Francesc Guasch committed
778
779
780
781
782
783
784
        return if $kid  == $pid;
    }
}

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

787
    $self->{pids}->{$pid} = $id_req;
Francesc Guasch's avatar
Francesc Guasch committed
788
789
}

790
sub _cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
791
792
793
794
    my $self = shift;
    my $request = shift;

    $request->status('working');
795
796
797
798
    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
799

800
}
Francesc Guasch's avatar
Francesc Guasch committed
801

802
803
804
805
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
837
838
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);

    $domain->resume($user);

    $request->status('done');

}


Francesc Guasch's avatar
Francesc Guasch committed
839
840
841
842
sub _cmd_start {
    my $self = shift;
    my $request = shift;

843
    $request->status("working $$");
Francesc Guasch's avatar
Francesc Guasch committed
844
    my $name = $request->args('name');
845

846
847
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
848
849
850
851

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

852
    $domain->start(user => $user, remote_ip => $request->args('remote_ip'));
853
854
855
    my $msg = 'Domain '
            ."<a href=\"/machine/view/".$domain->id.".html\">"
            .$request->args('name')."</a>"
Francesc Guasch's avatar
Francesc Guasch committed
856
            ." started"
857
858
        ;
    $request->status('done', $msg);
Francesc Guasch's avatar
Francesc Guasch committed
859
860
861

}

Francesc Guasch's avatar
Francesc Guasch committed
862
863
864
865
866
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
Francesc Guasch's avatar
Francesc Guasch committed
867
    my $id_domain = $request->id_domain   or confess "Missing request id_domain";
868
869
870
871
    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
872
    my $domain = $self->search_domain_by_id($id_domain);
873

Francesc Guasch's avatar
Francesc Guasch committed
874
    die "Unknown domain id '$id_domain'\n" if !$domain;
875
876

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
877
878
879

}

880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
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;

    $domain->remove_base($user);

}


Francesc Guasch's avatar
Francesc Guasch committed
899

Francesc Guasch's avatar
Francesc Guasch committed
900
901
902
903
904
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
905
    my $uid = $request->args('uid');
Francesc Guasch's avatar
Francesc Guasch committed
906
    my $name = $request->args('name');
907
    my $timeout = ($request->args('timeout') or 60);
908

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

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

915
916
    $domain->shutdown(timeout => $timeout, name => $name, user => $user
                    , request => $request);
Francesc Guasch's avatar
Francesc Guasch committed
917
918
919

}

920
921
922
923
924
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
925
    $request->result(\@list_types);
926
927
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
928

929
930
931
932
933
934
935
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
937
938
939
940
941
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
943
          start => \&_cmd_start
944
         ,pause => \&_cmd_pause
Francesc Guasch's avatar
Francesc Guasch committed
945
946
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
947
        ,resume => \&_cmd_resume
Francesc Guasch's avatar
Francesc Guasch committed
948
      ,shutdown => \&_cmd_shutdown
949
    ,domdisplay => \&_cmd_domdisplay
950
    ,screenshot => \&_cmd_screenshot
951
   ,remove_base => \&_cmd_remove_base
952
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
953
  ,prepare_base => \&_cmd_prepare_base
954
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
955
956
957
958
    );
    return $methods{$cmd};
}

959
960
961
962
963
964
965
966
967
968
969
970
971
=head2 open_vm

Opens a VM of a given type


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

=cut

sub open_vm {
    return search_vm(@_);
}

972
973
974
975
976
977
978
979
980
981
982
983
=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;

984
985
    confess "Missing VM type"   if !$type;

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

988
    if ($type =~ /Void/i) {
989
990
991
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
992
993
    my @vms;
    eval { @vms = @{$self->vm} };
994
995
996
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
997
    for my $vm (@vms) {
998
999
1000
1001
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
1002

1003
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
1033
=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
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

1044
1;